VB6消息截获处理、删除只读文件、API创建多层文件夹

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