Option Explicit

 '**************************************

 ' 模块名称: AppendToLog 通过API写入日志

 '**************************************

 'API 声明

 Private Const GENERIC_WRITE = &H40000000

 Private Const FILE_SHARE_READ = &H1

 Private Const Create_NEW =

 Private Const OPEN_EXISTING =

 Private Const FILE_ATTRIBUTE_NORMAL = &H80

 Private Const FILE_BEGIN =

 Private Const INVALID_HANDLE_VALUE = -

 Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long

 Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long

 Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Any) As Long

 Private Declare Function FlushFileBuffers Lib "kernel32" (ByVal hFile As Long) As Long

 Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

 '调用：Call AppendToLog("测试模块名","测试日志内容")

 '**************************************

 ' 方法名称: AppendToLog

 ' 输入参数:sMdl 模块名称 sMessage 日志内容

 '**************************************

 Public Sub AppendToLog(sMdl As String, sMessage As String)

 On Error GoTo Err:

     '获取计算机名、用户名、本机ip

     Dim LocalInfo As String

     Dim strLocalIP As String

     Dim winIP As Object

     LocalInfo = LocalInfo & "  Computer:" & Environ("computername")

     LocalInfo = LocalInfo & "  User:" & Environ("username")

     Set winIP = CreateObject("MSWinsock.Winsock")

     strLocalIP = winIP.LocalIP

     LocalInfo = LocalInfo & "  IP:" & strLocalIP

     Dim lpFileName As String

     lpFileName = App.Path + "\Log"

     If Dir(lpFileName, vbDirectory) = "" Then

         MkDir (lpFileName)

     End If

     lpFileName = lpFileName + "\" + Format(Now, "yyyymmdd") + ".log"

     sMessage = "--" + Format(Now, "yyyy-mm-dd hh:mm:ss") + "  模块:" + sMdl + LocalInfo + vbNewLine + sMessage + vbNewLine

     'appends a string to a text file.

     'it's up to the coder to add a CR/LF at the end

     'of the string if (s)he so desires.

     'assume failure

     'AppendToLog = False

     'exit if the string cannot be written to disk

     If Len(sMessage) <  Then Exit Sub

     'get the size of the file (if it exists)

     Dim fLen As Long: fLen =

     If (Len(Dir(lpFileName))) Then: fLen = FileLen(lpFileName)

     'open the log file, create as necessary

     Dim hLogFile As Long

     hLogFile = CreateFile(lpFileName, GENERIC_WRITE, FILE_SHARE_READ, ByVal &, _

         IIf(Len(Dir(lpFileName)), OPEN_EXISTING, Create_NEW), _

         FILE_ATTRIBUTE_NORMAL, &)

     'ensure the log file was opened properly

     If (hLogFile = INVALID_HANDLE_VALUE) Then Exit Sub

     'move file pointer to end of file if file was not created

     If (fLen <> ) Then

         If (SetFilePointer(hLogFile, fLen, ByVal &, FILE_BEGIN) = &HFFFFFFFF) Then

             'exit sub if the pointer did not set correctly

             CloseHandle (hLogFile)

             Exit Sub

         End If

     End If

     'convert the source string to a byte array for use with WriteFile

     Dim lTemp As Long

     ReDim TempArray( To Len(sMessage) - ) As Byte

     TempArray = StrConv(sMessage, vbFromUnicode)

     lTemp = UBound(TempArray) +

     'write the string to the log file

     If (WriteFile(hLogFile, TempArray(), lTemp, lTemp, ByVal &) <> ) Then

         'the data was written correctly

         'AppendToLog = True

     End If

     'flush buffers and close the file

     FlushFileBuffers (hLogFile)

     CloseHandle (hLogFile)

     Exit Sub

 Err:

     MsgBox "日志写入出错，原因是" + Err.Description, vbExclamation, "提示信息"

 End Sub