mfindfile.bas

1.如果在向导设置班级数为8时,此数值为班级总数

Attribute VB_Name = "mFindFile"
Option Explicit
Public Const SHGFI_LARGEICON = &H0
Public Const SHGFI_SMALLICON = &H1
Public Const DRIVE_REMOVABLE = 2
Public Const DRIVE_FIXED = 3
Public Const DRIVE_REMOTE = 4
Public Const DRIVE_CDROM = 5
Public Const DRIVE_RAMDISK = 6
Public Const SHGFI_ICON = &H100
Public Const MAX_PATH = 260
Type filAttribute
    filName As String
    filDir As String
    filSuffix As String
    filLen As String
    filDate As String
End Type
Type TypeIcon
    cbSize As Long
    picType As PictureTypeConstants
    hIcon As Long
End Type
Type CLSID
    id(16) As Byte
End Type
Type SHFILEINFO
    hIcon As Long                      '  out: icon
    iIcon As Long                      '  out: icon index
    dwAttributes As Long               '  out: SFGAO_ flags
    szDisplayName As String * MAX_PATH '  out: display name (or path)
    szTypeName As String * 80          '  out: type name
End Type
Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Declare Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionA" (ByVal lpszLocalName As String, ByVal lpszRemoteName As String, cbRemoteName As Long) As Long
Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (pDicDesc As TypeIcon, riid As CLSID, ByVal fown As Long, lpUnk As Object) As Long
Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
'========================================================
Function GetFileAttrib(ByVal strFile$) As filAttribute
    Dim strFileName_WithOutDir$
    strFileName_WithOutDir = GetFileFullName$(strFile$)
    GetFileAttrib.filName = strFileName_WithOutDir
    GetFileAttrib.filDir = Left(strFile$, Len(strFile) - Len(strFileName_WithOutDir))
    GetFileAttrib.filSuffix = GetFileSuffix(strFileName_WithOutDir)
    GetFileAttrib.filLen = GetFileLen(strFile$)
    GetFileAttrib.filDate = FileDateTime(strFile$)
End Function
'========================================================
'========================================================
' 获取文件的文件名及后缀名，不包含路径
Function GetFileFullName$(ByVal strFileName$)
    Dim nPos&, nTmpStr$
    nTmpStr$ = strFileName$
    Do
        nPos& = InStr(1, nTmpStr$, "\")
        If nPos& = 0 Then Exit Do   '未找到 \ 符号，则取消搜索
        nTmpStr$ = Right(nTmpStr$, Len(nTmpStr) - nPos&)
    Loop
    GetFileFullName$ = nTmpStr$
End Function
'========================================================
'========================================================
' 获取文件的文件名,不包含路径及后缀名
Function GetFileName$(ByVal strFileName_WithOutDir$)
    Dim nPos&, nPosPrev&, nTmpStr$
    nTmpStr$ = strFileName_WithOutDir$
    On Error Resume Next
    nPos& = 0
    Do
        nPos& = InStr(nPos& + 1, nTmpStr$, ".")
        If nPos& = 0 Then Exit Do
        nPosPrev& = nPos&
    Loop
    If nPosPrev& = 0 Then
        GetFileName = strFileName_WithOutDir$
    Else
        GetFileName$ = Left(strFileName_WithOutDir$, nPosPrev& - 1)
    End If
End Function
'========================================================
'========================================================
' 获取文件的后缀名
Function GetFileSuffix$(ByVal strFileName_WithOutDir$)
    Dim nPos&, nPosPrev&, nTmpStr$
    nTmpStr$ = strFileName_WithOutDir$
    On Error Resume Next
    nPos& = 0
    Do
        nPos& = InStr(nPos& + 1, nTmpStr$, ".")
        If nPos& = 0 Then Exit Do
        nPosPrev& = nPos&
    Loop
    GetFileSuffix$ = UCase(Right(strFileName_WithOutDir, _
            Len(strFileName_WithOutDir) - nPosPrev&))
End Function
'========================================================
'========================================================
' 获取文件的大小
Function GetFileLen$(ByVal strFileName$)
    Dim nLen As Double
    nLen = FileLen(strFileName$)
    If nLen < 1024 Then
        GetFileLen$ = CStr(nLen) & "字节"
    Else
        GetFileLen$ = Format((nLen / 1024), "Fixed") & "KB"
    End If
End Function
'========================================================
'========================================================
' 查找单一目录下的文件，将其查找到的文件的全路径及
' 名称添加到 ByRef colFiles 集合中。
Function FindFilesInSingleDir&(ByVal strDir$, _
            ByVal strPattern$, _
            ByRef colFiles As Collection)
    Dim cFind As New cFindFile
    Dim strFile$
    If Right(strDir, 1) <> "\" Then _
            strDir = strDir & "\"
    strFile = cFind.Find(strDir & strPattern)
    Do While Len(strFile)
        If (cFind.FileAttributes And vbDirectory) = 0 Then
            ' 将含有目录的文件名添加到集合中
            colFiles.Add strDir & strFile
        End If
        strFile = cFind.FindNext
    Loop
    FindFilesInSingleDir& = colFiles.Count
    Set cFind = Nothing
End Function
'========================================================
'========================================================
' 查找包含子目录下的文件，将其查找到的文件的全路径及
' 名称添加到 ByRef colFiles 集合中。
Function FindAllFiles&(ByVal strSearchPath$, _
            strPattern As String, _
            Optional colFiles As Collection, _
            Optional colDirs As Collection, _
            Optional blnDirsOnly As Boolean, _
            Optional blnBoth As Boolean)
    Dim cFind As New cFindFile
    Dim strFile$
    Dim intDirsFound%
    If Right(strSearchPath, 1) <> "\" Then _
            strSearchPath = strSearchPath & "\"
    strFile = cFind.Find(strSearchPath & strPattern)
    Do While Len(strFile)
        If cFind.FileAttributes And vbDirectory Then
            If Left(strFile, 1) <> "." Then
                If blnDirsOnly Or blnBoth Then
                    colDirs.Add strSearchPath & strFile & "\"
                End If
                intDirsFound = intDirsFound + 1
                intDirsFound = intDirsFound + FindAllFiles( _
                        strSearchPath & strFile & "\", strPattern, _
                        colFiles, colDirs, blnDirsOnly)
            End If
            strFile = cFind.FindNext()
        Else
            If Not blnDirsOnly Or blnBoth Then
                ' 将含有目录的文件名添加到集合中
                colFiles.Add strSearchPath & strFile
            End If
            strFile = cFind.FindNext()
        End If
    Loop
    FindAllFiles = intDirsFound
    Set cFind = Nothing
End Function
'========================================================
'========================================================
' Convert an icon handle into an IPictureDisp.
Public Function IconToPicture(hIcon As Long) As IPictureDisp
    Dim cls_id As CLSID
    Dim hRes As Long
    Dim new_icon As TypeIcon
    Dim lpUnk As IUnknown
    With new_icon
        .cbSize = Len(new_icon)
        .picType = vbPicTypeIcon
        .hIcon = hIcon
    End With
    With cls_id
        .id(8) = &HC0
        .id(15) = &H46
    End With
    hRes = OleCreatePictureIndirect(new_icon, _
            cls_id, 1, lpUnk)
    If hRes = 0 Then Set IconToPicture = lpUnk
End Function
'========================================================
'========================================================
' 从文件中获取其图标
Public Function GetIcon(filename As String, icon_size As Long) As IPictureDisp
    Dim index As Integer
    Dim hIcon As Long
    Dim item_num As Long
    Dim icon_pic As IPictureDisp
    Dim sh_info As SHFILEINFO
    SHGetFileInfo filename, 0, sh_info, _
            Len(sh_info), SHGFI_ICON + icon_size
    hIcon = sh_info.hIcon
    Set icon_pic = IconToPicture(hIcon)
    Set GetIcon = icon_pic
End Function
'========================================================