VB6-AppendToLog 通过API写入日志
工作中免不了需要为自己的程序添加日志，我也从网上扒拉了一个老外写的模块，修改修改了下，凑合用吧。
1 Option Explicit 2 '************************************** 3 ' 模块名称: AppendToLog 通过API写入日志 4 '************************************** 5 'API 声明 6 Private Const GENERIC_WRITE = &H40000000 7 Private Const FILE_SHARE_READ = &H1 8 Private Const Create_NEW = 1 9 Private Const OPEN_EXISTING = 3 10 Private Const FILE_ATTRIBUTE_NORMAL = &H80 11 Private Const FILE_BEGIN = 0 12 Private Const INVALID_HANDLE_VALUE = -1 13 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 14 Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long 15 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 16 Private Declare Function FlushFileBuffers Lib "kernel32" (ByVal hFile As Long) As Long 17 Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long 18 19 '调用：Call AppendToLog("测试模块名","测试日志内容") 20 '************************************** 21 ' 方法名称: AppendToLog 22 ' 输入参数:sMdl 模块名称 sMessage 日志内容 23 '************************************** 24 Public Sub AppendToLog(sMdl As String, sMessage As String) 25 26 On Error GoTo Err: 27 28 '获取计算机名、用户名、本机ip 29 Dim LocalInfo As String 30 Dim strLocalIP As String 31 Dim winIP As Object 32 LocalInfo = LocalInfo & " Computer:" & Environ("computername") 33 LocalInfo = LocalInfo & " User:" & Environ("username") 34 Set winIP = CreateObject("MSWinsock.Winsock") 35 strLocalIP = winIP.LocalIP 36 LocalInfo = LocalInfo & " IP:" & strLocalIP 37 38 Dim lpFileName As String 39 lpFileName = App.Path + "\Log" 40 If Dir(lpFileName, vbDirectory) = "" Then 41 MkDir (lpFileName) 42 End If 43 44 lpFileName = lpFileName + "\" + Format(Now, "yyyymmdd") + ".log" 45 46 sMessage = "--" + Format(Now, "yyyy-mm-dd hh:mm:ss") + " 模块:" + sMdl + LocalInfo + vbNewLine + sMessage + vbNewLine 47 'appends a string to a text file. 48 'it's up to the coder to add a CR/LF at the end 49 'of the string if (s)he so desires. 50 'assume failure 51 'AppendToLog = False 52 'exit if the string cannot be written to disk 53 If Len(sMessage) < 1 Then Exit Sub 54 'get the size of the file (if it exists) 55 Dim fLen As Long: fLen = 0 56 If (Len(Dir(lpFileName))) Then: fLen = FileLen(lpFileName) 57 'open the log file, create as necessary 58 Dim hLogFile As Long 59 hLogFile = CreateFile(lpFileName, GENERIC_WRITE, FILE_SHARE_READ, ByVal 0&, _ 60 IIf(Len(Dir(lpFileName)), OPEN_EXISTING, Create_NEW), _ 61 FILE_ATTRIBUTE_NORMAL, 0&) 62 'ensure the log file was opened properly 63 If (hLogFile = INVALID_HANDLE_VALUE) Then Exit Sub 64 'move file pointer to end of file if file was not created 65 If (fLen <> 0) Then 66 If (SetFilePointer(hLogFile, fLen, ByVal 0&, FILE_BEGIN) = &HFFFFFFFF) Then 67 'exit sub if the pointer did not set correctly 68 CloseHandle (hLogFile) 69 Exit Sub 70 End If 71 End If 72 'convert the source string to a byte array for use with WriteFile 73 Dim lTemp As Long 74 ReDim TempArray(0 To Len(sMessage) - 1) As Byte 75 TempArray = StrConv(sMessage, vbFromUnicode) 76 lTemp = UBound(TempArray) + 1 77 'write the string to the log file 78 If (WriteFile(hLogFile, TempArray(0), lTemp, lTemp, ByVal 0&) <> 0) Then 79 'the data was written correctly 80 'AppendToLog = True 81 End If 82 'flush buffers and close the file 83 FlushFileBuffers (hLogFile) 84 CloseHandle (hLogFile) 85 Exit Sub 86 Err: 87 MsgBox "日志写入出错，原因是" + Err.Description, vbExclamation, "提示信息" 88 89 End Sub
