basfile.bas

功能强大的API

Attribute VB_Name = "basFile"
'文件系统相关操作
'****************************************
'汉化: 小聪明       [e-mail]
'小聪明的主页VB版:  http://coolzm.533.net
'****************************************
Option Explicit

Private Const MAX_FILENAME_LEN = 256

Public Const DRIVE_CDROM = 5
Public Const DRIVE_FIXED = 3
Public Const DRIVE_RAMDISK = 6
Public Const DRIVE_REMOTE = 4
Public Const DRIVE_REMOVABLE = 2
Public Const DRIVE_UNKNOWN = 0

Private Declare Function GetDriveTypeA Lib "kernel32" (ByVal nDrive As String) As Long

Private Declare Function GetVolumeInformation& Lib "kernel32" Alias "GetVolumeInformationA" _
   (ByVal lpRootPathName As String, ByVal pVolumeNameBuffer As String, _
    ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, _
    lpMaximumComponentLength As Long, lpFileSystemFlags As Long, _
    ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long)

Private Declare Function GetWindowsDirectoryA Lib "kernel32" _
   (ByVal lpBuffer As String, ByVal nSize As Long) As Long
   
Private Declare Function GetTempPathA Lib "kernel32" _
   (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Const UNIQUE_NAME = &H0

Private Declare Function GetTempFileNameA Lib "kernel32" (ByVal _
   lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique _
   As Long, ByVal lpTempFileName As String) As Long
   
Private Declare Function GetSystemDirectoryA Lib "kernel32" _
   (ByVal lpBuffer As String, ByVal nSize As Long) As Long


Private 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
   
Private Const SW_HIDE = 0             ' = vbHide
Private Const SW_SHOWNORMAL = 1       ' = vbNormal
Private Const SW_SHOWMINIMIZED = 2    ' = vbMinimizeFocus
Private Const SW_SHOWMAXIMIZED = 3    ' = vbMaximizedFocus
Private Const SW_SHOWNOACTIVATE = 4   ' = vbNormalNoFocus
Private Const SW_MINIMIZE = 6         ' = vbMinimizedNofocus

Private Declare Function GetShortPathNameA Lib "kernel32" _
   (ByVal lpszLongPath As String, ByVal lpszShortPath _
   As String, ByVal cchBuffer As Long) As Long
   
Private Type SHFILEOPSTRUCT
        hwnd As Long
        wFunc As Long
        pFrom As String
        pTo As String
        fFlags As Integer
        fAborted As Boolean
        hNameMaps As Long
        sProgress As String
End Type

Private Const FO_DELETE = &H3
Private Const FOF_ALLOWUNDO = &H40
Private Const FOF_SILENT = &H4
Private Const FOF_NOCONFIRMATION = &H10

Private Declare Function SHFileOperation Lib "shell32.dll" Alias _
   "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long

Private Type STARTUPINFO
    cb As Long
    lpReserved As String
    lpDesktop As String
    lpTitle As String
    dwX As Long
    dwY As Long
    dwXSize As Long
    dwYSize As Long
    dwXCountChars As Long
    dwYCountChars As Long
    dwFillAttribute As Long
    dwFlags As Long
    wShowWindow As Integer
    cbReserved2 As Integer
    lpReserved2 As Long
    hStdInput As Long
    hStdOutput As Long
    hStdError As Long
End Type

Private Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessId As Long
    dwThreadID As Long
End Type

Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
Private Const SYNCHRONIZE = &H100000

Private Declare Function CloseHandle Lib "kernel32" (hObject As Long) As Boolean

Private Declare Function WaitForSingleObject Lib "kernel32" _
    (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
    
Private Declare Function CreateProcessA Lib "kernel32" _
    (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, _
    ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
    ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
    ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _
    lpStartupInfo As STARTUPINFO, _
    lpProcessInformation As PROCESS_INFORMATION) As Long

Private Declare Function FindExecutableA Lib "shell32.dll" _
   (ByVal lpFile As String, ByVal lpdirectory As _
   String, ByVal lpResult As String) As Long

Private Declare Function SetVolumeLabelA Lib "kernel32" _
   (ByVal lpRootPathName As String, _
   ByVal lpVolumeName As String) As Long

' 返回与指定的文件相关联的执行文件
' 如果没找到则返回""

Public Function FindExecutable(s As String) As String
   Dim i As Integer
   Dim s2 As String
   
   s2 = String(MAX_FILENAME_LEN, 32) & Chr$(0)
   
   i = FindExecutableA(s & Chr$(0), vbNullString, s2)
   
   If i > 32 Then
      FindExecutable = Left$(s2, InStr(s2, Chr$(0)) - 1)
   Else
      FindExecutable = ""
   End If
   
End Function


'
' 删除数组中指定的文件.
'
Public Function ShellDelete(ParamArray vntFileName() As Variant) As Boolean
   Dim i As Integer
   Dim sFileNames As String
   Dim SHFileOp As SHFILEOPSTRUCT

   For i = LBound(vntFileName) To UBound(vntFileName)
      sFileNames = sFileNames & vntFileName(i) & vbNullChar
   Next
        
   sFileNames = sFileNames & vbNullChar

   With SHFileOp
      .wFunc = FO_DELETE
      .pFrom = sFileNames
      .fFlags = FOF_ALLOWUNDO + FOF_SILENT + FOF_NOCONFIRMATION
   End With

   i = SHFileOperation(SHFileOp)
   
   If i = 0 Then
      ShellDelete = True
   Else
      ShellDelete = False
   End If
End Function

' 运行一个命令行语句并在其结束后返回,成功返回True
' 注意:命令行语句需要完整的路径

Public Function ShellWait(cCommandLine As String) As Boolean
    Dim NameOfProc As PROCESS_INFORMATION
    Dim NameStart As STARTUPINFO
    Dim i As Long

    NameStart.cb = Len(NameStart)
    i = CreateProcessA(0&, cCommandLine, 0&, 0&, 1&, _
        NORMAL_PRIORITY_CLASS, 0&, 0&, NameStart, NameOfProc)
   
    If i <> 0 Then
       Call WaitForSingleObject(NameOfProc.hProcess, INFINITE)
       Call CloseHandle(NameOfProc.hProcess)
       ShellWait = True
    Else
       ShellWait = False
    End If
    
End Function

'此函数类似Execute函数,只是此函数当命令执行完后才返回


Public Function ExecuteWait(s As String, Optional param As Variant) As Boolean
   Dim s2 As String
   
   s2 = FindExecutable(s)
   
   If s2 <> "" Then
      ExecuteWait = ShellWait(s2 & _
         IIf(IsMissing(param), " ", " " & CStr(param) & " ") & s)
   Else
      ExecuteWait = False
   End If
End Function

'给一个字符串的最后加上一个反斜线"\",如果此字符串最后一位已经是"\"则不加
Public Function AddBackslash(s As String) As String
   If Len(s) > 0 Then
      If Right$(s, 1) <> "\" Then
         AddBackslash = s + "\"
      Else
         AddBackslash = s
      End If
   Else
      AddBackslash = "\"
   End If
End Function

'
' 调用相关的程序来执行一个文件
'    参数windowstyle 将用到以下常数
'       vbHide   0
'       vbNormalFocus  1
'       vbMinimizedFocus  2
'       vbMaximizedFocus  3
'       vbNormalNoFocus   4
'       vbMinimizedNoFocus   6
'  成功返回true
Public Function Execute(ByVal hwnd As Integer, s As String, Optional param As Variant, Optional windowstyle As Variant) As Boolean
   Dim i As Long
   
   If IsMissing(windowstyle) Then
      windowstyle = vbNormalFocus
   End If
   
   i = ShellExecute(hwnd, vbNullString, s, IIf(IsMissing(param) Or (param = ""), vbNullString, CStr(param)), GetPath(s), CLng(windowstyle))
   If i > 32 Then
      Execute = True
   Else
      Execute = False
   End If
End Function

'
'  返回一个文件的文件名
' 例如GetFile("c:\command.com")=command.com
Public Function GetFile(s As String) As String
   Dim i As Integer
   Dim j As Integer
   
   i = 0
   j = 0
   
   i = InStr(s, "\")
   Do While i <> 0
      j = i
      i = InStr(j + 1, s, "\")
   Loop
   
   If j = 0 Then
      GetFile = ""
   Else
      GetFile = Right$(s, Len(s) - j)
   End If
End Function

'
'返回一个文件的路径名
'例如GetFile("c:\command.com")="c:\"
Public Function GetPath(s As String) As String
   Dim i As Integer
   Dim j As Integer
   
   i = 0
   j = 0
   
   i = InStr(s, "\")
   Do While i <> 0
      j = i
      i = InStr(j + 1, s, "\")
   Loop
   
   If j = 0 Then
      GetPath = ""
   Else
      GetPath = Left$(s, j)
   End If
End Function
'
' 取得磁盘序列号
'
Public Function GetSerialNumber(sDrive As String) As Long
   Dim ser As Long
   Dim s As String * MAX_FILENAME_LEN
   Dim s2 As String * MAX_FILENAME_LEN
   Dim i As Long
   Dim j As Long
   
   Call GetVolumeInformation(sDrive + ":\" & Chr$(0), s, MAX_FILENAME_LEN, ser, i, j, s2, MAX_FILENAME_LEN)
   GetSerialNumber = ser
End Function


Public Function GetShortPathName(longpath As String) As String
   Dim s As String
   Dim i As Long
   
   i = Len(longpath) + 1
   s = String(i, 0)
   GetShortPathNameA longpath, s, i
   
   GetShortPathName = Left$(s, InStr(s, Chr$(0)) - 1)
End Function

Public Function GetVolumeName(sDrive As String) As String
   Dim ser As Long
   Dim s As String * MAX_FILENAME_LEN
   Dim s2 As String * MAX_FILENAME_LEN
   Dim i As Long
   Dim j As Long
   
   Call GetVolumeInformation(sDrive + ":\" & Chr$(0), s, MAX_FILENAME_LEN, ser, i, j, s2, MAX_FILENAME_LEN)
   GetVolumeName = Left$(s, InStr(s, Chr$(0)) - 1)
End Function
'
' 设置卷标
'
Public Function SetVolumeName(sDrive As String, n As String) As Boolean
   Dim i As Long
   
   i = SetVolumeLabelA(sDrive + ":\" & Chr$(0), n & Chr$(0))
   
   SetVolumeName = IIf(i = 0, False, True)
End Function
'
'返回系统目录
'
Public Function GetSystemDirectory() As String
   Dim s As String
   Dim i As Integer
   i = GetSystemDirectoryA("", 0)
   s = Space(i)
   Call GetSystemDirectoryA(s, i)
   GetSystemDirectory = AddBackslash(Left$(s, i - 1))
End Function

Public Function GetTempFileName() As String
   Dim s As String
   Dim s2 As String
   
   s2 = GetTempPath
   s = Space(Len(s2) + MAX_FILENAME_LEN)
   Call GetTempFileNameA(s2, App.EXEName, UNIQUE_NAME, s)
   GetTempFileName = Left$(s, InStr(s, Chr$(0)) - 1)
End Function

'
'  取得临时文件存放的目录名称
'
Public Function GetTempPath() As String
   Dim s As String
   Dim i As Integer
   i = GetTempPathA(0, "")
   s = Space(i)
   Call GetTempPathA(i, s)
   GetTempPath = AddBackslash(Left$(s, i - 1))
End Function

'
' 返回Windows所在的目录
'
Public Function GetWindowsDirectory() As String
   Dim s As String
   Dim i As Integer
   i = GetWindowsDirectoryA("", 0)
   s = Space(i)
   Call GetWindowsDirectoryA(s, i)
   GetWindowsDirectory = AddBackslash(Left$(s, i - 1))
End Function

'如果一个字符串最后一位是"\"则去掉,否则不变
'
Public Function RemoveBackslash(s As String) As String
   Dim i As Integer
   i = Len(s)
   If i <> 0 Then
      If Right$(s, 1) = "\" Then
         RemoveBackslash = Left$(s, i - 1)
      Else
         RemoveBackslash = s
      End If
   Else
      RemoveBackslash = ""
   End If
End Function

'
' 返回指定的驱动器类型
'
Public Function sDriveType(sDrive As String) As String
Dim lRet As Long

    lRet = GetDriveTypeA(sDrive & ":\")
    Select Case lRet
        Case 0
            
            sDriveType = "Unknown"
            
        Case 1
         
            sDriveType = "Unknown"
        Case DRIVE_CDROM:
            sDriveType = "CD-ROM Drive"
            
        Case DRIVE_REMOVABLE:
            sDriveType = "Removable Drive"
            
        Case DRIVE_FIXED:
            sDriveType = "Fixed Drive"
            
        Case DRIVE_REMOTE:
            sDriveType = "Remote Drive"
        End Select
End Function

Public Function GetDriveType(sDrive As String) As Long
  Dim lRet As Long
  lRet = GetDriveTypeA(sDrive & ":\")
  
  If lRet = 1 Then
     lRet = 0
  End If

  GetDriveType = lRet
End Function
'-----------------------------------------------------------
' 函数: FileExists
' 判断一个指定的文件是否存在
' 如果存在则返回true
'-----------------------------------------------------------
'
Public Function FileExists(ByVal strPathName As String) As Boolean
    Dim intFileNum As Integer

    On Error Resume Next

    If Right$(strPathName, 1) = "\" Then
        strPathName = Left$(strPathName, Len(strPathName) - 1)
    End If
       intFileNum = FreeFile
    Open strPathName For Input As intFileNum

    FileExists = IIf(Err, False, True)

    Close intFileNum

    Err = 0
End Function