VB6消息截获处理、删除只读文件、API创建多层文件夹
Attribute VB_Name = "mdlMessage"
'/***********************************************************************
'* 文件名:mdlMessage.bas
'* 文件描述:提供主窗体消息截获 特别处理应用系统异常消息
'* 创建人:Shi.Mingjie 2004/07/15
'* 版本号:1.0
'* 修改记录:
'* 版权所有 2003-2004
'*
'************************************************************************/
Option Explicit
Private Const WM_CLOSE = &H10 '* 系统消息 关闭进程
Private Const WM_RESTARTCOMPUTERFORCE = &H477 '* 自定义消息 重新启动计算机
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _
ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long _
) As Long
Global gprevWndproc As Long '// 保存窗体消息处理句柄,用于退出程序时恢复Windows消息处理
'/*================================================================
' *
' * 函 数 名:WndProc
' *
' * 参 数:ByVal hwnd As Long
' * ByVal Msg As Long 消息代码
' * ByVal wParam As Long
' * ByVal lParam As Long
' *
' * 功能描述: 截获窗体消息,处理自定义消息,其余消息归还Windows处理
' *
' * 返 回 值:默认
' *
' * 异常处理:跳到下一行继续执行
' *
' * 作 者:Shi.Mingjie 2003/07/15
' *
' ================================================================*/
Public Function WndProc(ByVal hwnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
On Error Resume Next
Select Case Msg
Case WM_RESTARTCOMPUTERFORCE '// 自定义消息 系统不可恢复异常,需要强制重新启动计算机
Call WriteToLog("Message->WndProc", "收到强制重新启动消息...", 2)
gudtControl.bRestartMeForce = True
Case Else '// 其他消息交由Windows处理
WndProc = CallWindowProc(gprevWndproc, hwnd, Msg, wParam, lParam)
End Select
End Function
'/*===============================================================
' *
' * 函 数 名:CreateFlag
' *
' * 参 数:szFlagFile 标识文件名
' *
' * 功能描述: 创建指定标识文件
' *
' * 返 回 值:成功返回TRUE,失败返回FALSE
' *
' * 异常处理:异常记录,返回失败
' *
' * 作 者:Shi.Mingjie 2004/11/03
' *
' ================================================================*/
Private Function CreateFlag(ByVal szFlagFile As String) As Boolean
On Error GoTo ErrHandle
Close #245
Open (App.Path & "/" & szFlagFile) For Output As #245
Close #245
CreateFlag = True
Exit Function
ErrHandle:
CreateFlag = False
Call WriteToLog("Message->CreateFlag : " & szFlagFile, "发生异常:" & Err.Description, 4)
End Function
'界面消息处理的代码
Private Const WM_CLOSE = &H10
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" ( _
ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long _
) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String _
) As Long
Private Const GWL_WNDPROC = (-4)
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long _
) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long _
) As Long
'Load
gprevWndproc = GetWindowLong(Me.hwnd, GWL_WNDPROC) '* 获取当前消息处理句柄
SetWindowLong Me.hwnd, GWL_WNDPROC, AddressOf WndProc '* 设置当前消息处理函数
'Unload
SetWindowLong Me.hwnd, GWL_WNDPROC, gprevWndproc '* 恢复消息Windows处理
'/*================================================================
' *
' * 函 数 名:ClearSpecialFile
' *
' * 参 数:无
' *
' * 功能描述: 自动删除指定文件列表中的文件
' *
' * 返 回 值:无
' *
' * 异常处理:跳出函数处理,记录错误到日志
' *
' * 作 者:Shi.Mingjie 2003/07/15
' *
' ================================================================*/
Private Sub ClearSpecialFile()
On Error GoTo ErrHandle
Dim szFile As String
Dim iFileNumber As Integer
Dim iCycleControl As Integer
Dim szFileList(100) As String
Dim i As Integer
Dim lpWin32FileData As WIN32_FIND_DATA
Dim nFindFileHandle As Long
szFile = Dir(App.Path & "/vidsClear.ini")
If Len(szFile) <> 0 Then
iFileNumber = FreeFile
Open szFile For Input As #iFileNumber
iCycleControl = 1
Do Until EOF(iFileNumber)
If iCycleControl <= 100 Then
Line Input #iFileNumber, szFileList(iCycleControl)
iCycleControl = iCycleControl + 1
Else
Exit Do
End If
Loop
Close #iFileNumber
For i = 1 To iCycleControl - 1
nFindFileHandle = FindFirstFile(szFileList(i), lpWin32FileData)
Call FindClose(nFindFileHandle)
If INVALID_HANDLE_VALUE <> nFindFileHandle Then
If 0 = DeleteFile(szFileList(i)) Then
If 0 <> SetFileAttributes(szFileList(i), FILE_ATTRIBUTE_NORMAL) Then
DoEvents
If 0 = DeleteFile(szFileList(i)) Then
Call WriteToLog("Main->ClearSpecialFile", "删除指定文件:" & szFileList(i) & " 失败!", 3)
End If
Else
Call WriteToLog("Main->ClearSpecialFile", "更改文件:" & szFileList(i) & " 属性失败!", 3)
End If
End If
End If
Next i
Else
Call WriteToLog("Main->ClearSpecialFile", "未找到指定文件:" & App.Path & "/vdsClear.ini", 3)
End If
Exit Sub
ErrHandle:
Call WriteToLog("Main->ClearSpecialFile", "异常:" & Err.Description, 3)
End Sub
'/*================================================================
' *
' * 函 数 名:CreateFolder
' *
' * 参 数:szCheckFolder 需要检测的文件夹
' *
' * 功能描述: 检查参数中传入的文件夹,不存在则创建
' *
' * 返 回 值:成功返回 TRUE,失败返回 FALSE
' *
' * 异常处理:记入日志
' *
' * 作 者:Shi.Mingjie 2003/09/16
' *
' ================================================================*/
Private Function CreateFolder(ByVal szCheckFolder As String) As Boolean
On Error GoTo ErrHandle
Dim szFolderBuff As Variant
Dim nFolderLayer As Long
Dim szFolderNow As String
Dim i As Long
Dim attFolder As SECURITY_ATTRIBUTES
Dim szFolder As String
szFolderNow = ""
szFolderBuff = Split(szCheckFolder, "/", 20)
nFolderLayer = UBound(szFolderBuff)
If nFolderLayer < 1 Then
CreateFolder = False
Else
CreateFolder = True
attFolder.nLength = Len(attFolder)
attFolder.lpSecurityDescriptor = &O0
attFolder.bInheritHandle = False
szFolderNow = szFolderBuff(0)
For i = 1 To UBound(szFolderBuff)
szFolderNow = szFolderNow & "/" & szFolderBuff(i)
szFolder = Dir(szFolderNow, vbDirectory)
If 0 = Len(szFolder) Then
If CreateDirectory(szFolderNow, attFolder) = 0 Then
Call WriteToLog("Main->CreateFolder", "[Failure] create: " & szFolderNow, 4)
CreateFolder = False
End If
End If
Next i
End If
Exit Function
ErrHandle:
CreateFolder = False
Call WriteToLog("Public->CreateFolder", " [Exception] create: " & szCheckFolder & " ErrNo: " & Err.Number & " Description: " & Err.Description, 4)
End Function