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