Private Declare Function RegisterEventSource Lib "advapi32.dll" Alias "RegisterEventSourceA" (ByVal lpUNCServerName As String, ByVal lpSourceName As String) As Long
Private Declare Function DeregisterEventSource Lib "advapi32.dll" (ByVal hEventLog As Long) As Long
Private 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
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long

Enum EventTypeEnum
  EVENTLOG_SUCCESS =  0 
  EVENTLOG_ERROR_TYPE =  1 
  EVENTLOG_WARNING_TYPE =  2 
  EVENTLOG_INFORMATION_TYPE =  4 
  EVENTLOG_AUDIT_SUCCESS =  8 
  EVENTLOG_AUDIT_FAILURE =  10 
End Enum

Public Sub LogNTEvent(EventString As String, Optional EvenType As EventTypeEnum = EVENTLOG_INFORMATION_TYPE)
Const EVT_PATH = "SYSTEM\CurrentControlSet\Services\EventLog\Application\"
Dim hEventLog As Long
Dim hMsgs As Long
Dim cbStringSize As Long
  
  On Error GoTo ErrorHandler
  
  Dim EventID As Long
  Select Case EvenType
    Case EVENTLOG_SUCCESS:          EventID = &H0
    Case EVENTLOG_ERROR_TYPE:       EventID = &HC0000001
    Case EVENTLOG_WARNING_TYPE:     EventID = &H80000002
    Case EVENTLOG_INFORMATION_TYPE: EventID = &H40000004
  End Select
  
  ' Register application
  Dim EventMessageFile As String

  EventMessageFile = App.Path & "\" & App.EXEName & ".DLL" 'или .EXE
  If RegGetKeyValue(HKEY_LOCAL_MACHINE, EVT_PATH & App.EXEName, "EventMessageFile") <> EventMessageFile Then
    RegSetKeyValue HKEY_LOCAL_MACHINE, EVT_PATH & App.EXEName, "EventMessageFile", App.Path & "\" & App.EXEName & ".DLL"
  End If
  
  ' Write to event log
  hEventLog = RegisterEventSource("", App.EXEName)
  If hEventLog =  0  Then 
      Err.Raise  13 , "LogNTEvent", "RegisterEventSource failed " & Err.LastDllError
  end if
  cbStringSize = Len(EventString) +  1 
  hMsgs = GlobalAlloc(&H40, cbStringSize)
  If hMsgs =  0  Then Err.Raise  13 
  CopyMemory ByVal hMsgs, ByVal EventString, cbStringSize
  Call ReportEvent(hEventLog, EvenType,  0 , EventID,  0 &,  1 ,  0 , hMsgs,  0 )
  Call GlobalFree(hMsgs)
  Call DeregisterEventSource(hEventLog)
  
  Exit Sub
ErrorHandler:
  If hMsgs <>  0  Then Call GlobalFree(hMsgs)
  If hEventLog <>  0  Then Call DeregisterEventSource(hEventLog)
End Sub