EventLogNT

Option Explicit
Declare Function RegisterEventSource Lib "advapi32.dll" Alias _
"RegisterEventSourceA" (ByVal lpUNCServerName As String, _
ByVal lpSourceName As String) As Long
Declare Function DeregisterEventSource Lib "advapi32.dll" ( _
ByVal hEventLog As Long) As Long
Declare Function ReportEvent Lib "advapi32.dll" Alias _
"ReportEventA" (ByVal hEventLog As Long, ByVal wType As Integer, _
ByVal wCategory As Integer, ByVal dwEventID As Long, _
ByVal lpUserSid As Any, ByVal wNumStrings As Integer, _
ByVal dwDataSize As Long, plpStrings As Long, _
lpRawData As Any) As Boolean
Declare Function GetLastError Lib "kernel32" () As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
hpvDest As Any, hpvSource As Any, _
ByVal cbCopy As Long)
Declare Function GlobalAlloc Lib "kernel32" ( _
ByVal wFlags As Long, _
ByVal dwBytes As Long) As Long
Declare Function GlobalFree Lib "kernel32" ( _
ByVal hMem As Long) As Long
Public Const EVENTLOG_SUCCESS = 0
Public Const EVENTLOG_ERROR_TYPE = 1
Public Const EVENTLOG_WARNING_TYPE = 2
Public Const EVENTLOG_INFORMATION_TYPE = 4
Public Const EVENTLOG_AUDIT_SUCCESS = 8
Public Const EVENTLOG_AUDIT_FAILURE = 10
Public Sub LogNTEvent(sString As String, iLogType As Integer, _
iEventID As Long)
Dim bRC As Boolean
Dim iNumStrings As Integer
Dim hEventLog As Long
Dim hMsgs As Long
Dim cbStringSize As Long
hEventLog = RegisterEventSource("", App.Title)
cbStringSize = Len(sString) + 1
hMsgs = GlobalAlloc(&H40, cbStringSize)
CopyMemory ByVal hMsgs, ByVal sString, cbStringSize
iNumStrings = 1
If ReportEvent(hEventLog, _
iLogType, 0, _
iEventID, 0&, _
iNumStrings, cbStringSize, _
hMsgs, hMsgs) = 0 Then
MsgBox GetLastError()
End If
Call GlobalFree(hMsgs)
DeregisterEventSource (hEventLog)
End Sub

Sub Main()
Call LogNTEvent("Information from " & App.EXEName, _
EVENTLOG_INFORMATION_TYPE, 1001)
Call LogNTEvent("Warning from " & App.EXEName, _
EVENTLOG_WARNING_TYPE, 1002)
Call LogNTEvent("Error from " & App.EXEName, _
EVENTLOG_ERROR_TYPE, 1003)
MsgBox "Done"
End Sub