VB 磁盘信息,文件夹,文件操作

最新推荐文章于 2015-04-24 19:39:43 发布
华芸智森
最新推荐文章于 2015-04-24 19:39:43 发布
阅读量1.9k
点赞数
分类专栏： VB 文章标签：磁盘 vb attributes exe null class
本文链接：https://blog.csdn.net/mstop/article/details/3053387
版权
VB 专栏收录该内容
19 篇文章 0 订阅
订阅专栏
 
 '文件,文件夹操作类 
' 
'/工程==>引用==>Microsoft Scripting Runtime 
Option Explicit
Private Const HKEY_CLASSES_ROOT = 
Private Const HKEY_CURRENT_USER = 
Private Const HKEY_LOCAL_MACHINE = 
Private Const HKEY_USERS = 
Private Const HKEY_PERFORMANCE_DATA = 
Private Const HKEY_CURRENT_CONFIG = 
Private Const HKEY_DYN_DATA = 
Private Const REG_NONE = 0
Private Const REG_SZ = 1
Private Const REG_EXPAND_SZ = 2
Private Const REG_BINARY = 3
Private Const REG_DWORD = 4
Private Const REG_DWORD_BIG_ENDIAN = 5
Private Const REG_MULTI_SZ = 7
Private Const MAX_PATH = 255
'/磁盘信息结构 
Public Type SmDriveInfo
     DriveName As String       '代号或路径 
     DriveType As String       '类型 
     DriveVolume As String     '卷标 
     DriveNumber As String     '序列号 
     DriveFileSystem As String '文件系统 
     DriveSize As String       '驱动器大小 
     DriveFree As String       '可用空间 
     DriveIsReady As String    '是否可用 
End Type
'/文件夹信息结构 
Public Type SmFoldInfo
     Attr As String             '属性 
     Size As String             '大小 
     DateCreated As String      '建立日期 
     DateLastAcce As String     '最后一次存取日期 
     DateLastModified As String '最后一次修改日期 
End Type
'/文件信息结构 
Public Type SmFileInfo
     Attr As String             '属性 
     Size As String             '大小 
     DateCreated As String      '建立日期 
     DateLastAcce As String     '最后一次存取日期 
     DateLastModified As String '最后一次修改日期 
End Type
'/常量定义 
'/程序的显示方式 
Private Const SW_SHOWNORMAL = 1
Private Const SW_SHOW = 5
Private Const SW_HIDE = 0
Private Const SW_MINIMIZE = 6
Private Const SW_MAXIMIZE = 3
Private Const SW_RESTORE = 9
Private Const WM_CLOSE = 
'/Synchronize 
Private Const INFINITE = 
Private Const NORMAL_PRIORITY_CLASS = 
Private Const SYNCHRONIZE = 
Private Const REALTIME_PRIORITY_CLASS = 
'/结构体 
Private Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
End Type
Private Type PROCESS_INFORMATION
        hProcess As Long
        hThread As Long
        dwProcessId As Long
        dwThreadId As Long
End Type
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 M_AttrRHSA(3, 1) As String
Private Declare Function WritePrivateProfileString _
Lib "kernel32" Alias "WritePrivateProfileStringA" _
(ByVal lpApplicationname As String, ByVal _
lpKeyName As Any, ByVal lsString As Any, _
ByVal lplFilename As String) As Long
Private Declare Function GetPrivateProfileString Lib _
"kernel32" Alias "GetPrivateProfileStringA" _
(ByVal lpApplicationname As String, ByVal _
lpKeyName As String, ByVal lpDefault As _
String, ByVal lpReturnedString As String, _
ByVal nSize As Long, ByVal lpFileName As _
String) 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 Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, _
                    ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
'/建立一个新的进程或线程 
Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" _
                                        (ByVal lpApplicationname As String, _
                                         ByVal lpCommandLine As String, _
                                         ByVal lpProcessAttributes As Long, _
                                         ByVal lpThreadAttributes As Long, _
                                         ByVal bInheritHandles As Long, _
                                         ByVal dwCreationFlags As Long, _
                                         lpEnvironment As Any, _
                                         ByVal lpCurrentDirectory As String, _
                                         lpStartupInfo As STARTUPINFO, _
                                         lpProcessInformation As PROCESS_INFORMATION) As Long
'/参数说明: 
'/lpApplicationName       可执行文件或模块的名字.如果lpCommandLine是NULL,则CreateProcess _ 
                         执行这个参数中指定的程序.
'/lpCommandLine           如果lpApplicationName是NULL,那么这个参数中程序要启动的程序名字 _ 
                         如果lpApplicationName和lpCommandLine都是NULL , 那么程序的名字在 _
                         lpApplicationName中指定 , 参数在lpCommandLine中指定.
'/lpProcessAttributes     SECURITY_ATTRIBUTES结构,它定义进程是否能够被继承,一般设为0, _ 
                         但一般将其定义为ByVal as Long,    (**这与API浏览器中不同)
'/lpThreadAttributes      SECURITY_ATTRIBUTES结构,它定义线程是否能够被断承.一般设为0, _ 
                         但一般将其定义为ByVal as Long,    (**这与API浏览器中不同)
'/bInheritHandles         布尔值,它表示新创建的进程能否继承调用进程的句柄. 
'/dwCreationFlags         为进程指定附加配置参数的标志. 
'/lpEnvironment           包含一个以NULL结束的环境参数列表的字符串.如果参数被设为NULL, _ 
                         则当前的环境被用在新的进程中.
'/lpCurrentDriectory      指向新进程的默认目录的字符串. 
'/lpStartupInfo           STARTUPINFO结构,,它配置新进程的外观. 
'/lpProcessInformation    PROCESS_INFORMATION结构,返回新建进程的有关信息. 
'/返回值                  如果调用成功,则返回一个非零值.如果返回值为0,则调用失败,调用函 _ 
                         GetLastError可以获取更多的错误信息.
'/--------------------------------------------------------------------------- 
'等待进程返回或者发生超时.负责调用CreateProcess这个同步操作. 
Private Declare Function WaitForSingleObject Lib "kernel32" _
                        (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
'/参数说明: 
'/hHandle                等待进程的句柄 
'/dwMilliseconds         等待的时间段,以毫秒为单位.;如果它被设为INFINITE,则这个API将无限期的 _ 
                        等待的进程返回.
'/返回值                 如果调用成功,则返回引起这个函数返回的值,它可以是以下几个值: _ 
                        WAIT_ABANDONED,WAIT_OBJECT_O,或者WAIT_TIMEOUT.如果发生了错误,则返回 _
                        WAIT_FAILED.
'/--------------------------------------------------------------------------- 
'/取临时文件名. 
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
' 
'/关闭以前打开的进程. 
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Sub ExitProcess Lib "kernel32" (ByVal uExitCode As Long)
'/参数说明: 
'/hObject                被关闭的句柄. 
'/返回值                 如果调用成功,返回一个非零值.若失败则返回值0. 
'/--------------------------------------------------------------------------- 
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" Alias _
        "GetDiskFreeSpaceExA" (ByVal lpRootPathName As String, _
        lpFreeBytesAvailableToCaller As Any, lpTotalNumberOfBytes _
        As Any, lpTotalNumberOfFreeBytes As Any) As Long
' 
'RelatFile 
'文件关联. 
'函数:RelatFile 
'参数: FilePath 关联的Exe文件路径,ExpName 关联的扩展名(如.DOC), IcoName图标路径, ShowName 在属性中显示的名称 
'返回值:无 
Public Function RelatFile(FilePath As String, ExpName As String, IcoName As String, ShowName As String)
    Dim hKey As Long
    Dim IconDir As String
    Dim PathName As String
    
    PathName = FilePath
    IconDir = IcoName & ",0"    '图标路径 
    PathName = PathName & " %1" '关联的文件名 
    
    hKey = HKEY_CLASSES_ROOT
    RegSetValue hKey, "." & ExpName, REG_SZ, ExpName & "File", 7
    RegSetValue hKey, ExpName & "File", REG_SZ, ShowName, 9
    RegSetValue hKey, ExpName & "File/shell", REG_SZ, "open", 5
    RegSetValue hKey, ExpName & "File/shell/open/command", REG_SZ, _
                PathName, LenB(StrConv(PathName, vbFromUnicode)) + 1
    RegSetValue hKey, ExpName & "File/DefaultIcon", REG_SZ, _
                IconDir, LenB(StrConv(IconDir, vbFromUnicode)) + 1
    RegCloseKey hKey
End Function
' 
'取文件扩展名. 
'函数:FileExpName 
'参数: Fname 文件绝对路径. 
'返回值:文件名. 
'如:"C:/PROMAS/AA.EXE",则返回 "EXE" 
Public Function FileExpName(Fname As String) As String
    On Error Resume Next
    
    Dim I As Integer
    
    I = InStrRev(Fname, ".")
    If I = 0 Then Exit Function
    FileExpName = Mid$(Fname, I + 1, 12)
End Function
' 
'取文件名,没有扩展名 
'函数:FileName 
'参数: Fname 文件绝对路径. 
'返回值:文件名. 
'如:"C:/PROMAS/AA.EXE",则返回 "AA" 
Public Function Filename(Fname As String) As String
      Dim A As Integer
      Dim B As Integer
      Dim JlStr As String
      Filename = "":  B = 0
      For A = Len(Fname) To 1 Step -1
          If Mid$(Fname, A, 1) = "/" Then
             B = A: GoTo 100
          End If
      Next A
    
100:
    JlStr = Right$(Fname, Len(Fname) - B)
    B = 1
    For A = Len(JlStr) To 1 Step -1
        If Mid$(JlStr, A, 1) = "." Then
           B = A: GoTo 200
        End If
    Next A
200:
      Filename = Left$(JlStr, B - 1)
End Function
' 
'取文件名,有扩展名 
'函数:FileNameExp 
'参数: Fname 文件绝对路径. 
'返回值:文件名. 
'如:"C:/PROMAS/AA.EXE",则返回 "AA.EXE" 
Public Function FileNameExp(Fname As String) As String
    Dim A As Integer
    Dim B As Integer
    Dim JlStr As String
    FileNameExp = ""
    B = 0
    For A = Len(Fname) To 1 Step -1
        If Mid$(Fname, A, 1) = "/" Then
           B = A: GoTo 100
        End If
    Next A
100:
    JlStr = Right$(Fname, Len(Fname) - B)
    FileNameExp = JlStr
End Function
' 
'取路径名 
'函数:FilePath 
'参数: Fname 文件绝对路径. 
'返回值:路径名. 
'如:"C:/PROMAS/AA.EXE",则返回 "C:/PROMAS/" 
Public Function FilePath(Fname As String) As String
    Dim A As Integer
    Dim B As Integer
    Dim JlStr As String
    FilePath = ""
    B = 0
    For A = Len(Fname) To 1 Step -1
        If Mid$(Fname, A, 1) = "/" Then
           B = A: GoTo 100
        End If
    Next A
    
100:
    JlStr = Left$(Fname, B)
    FilePath = JlStr
End Function
' 
'建立文件夹 
'函数:CreateDir 
'参数: DirPath 新建文件夹路径. 
'返回值:=T 成功,=F 失败. 
Public Function CreateDir(DirPath As String) As Boolean
     Dim c As String
     Dim A As Long
     Dim LeftName As String
     
     On Error Resume Next
     
     c = Trim$(DirPath)
     If Len(c) < 2 Then Err.Number = -1: GoTo Errhan
     If Dir$(Left$(c, 2), vbDirectory) = "" Then Err.Number = -1: GoTo Errhan '根目录是否存在 
     '/------------------------------------------------------- 
     If Right$(c, 1) <> "/" Then c = c & "/"
     For A = 1 To Len(c)
         If Mid$(c, A, 1) = "/" Then
            LeftName = Left$(c, A)
            If Dir$(LeftName, vbDirectory + vbHidden) = "" Then MkDir LeftName: DoEvents
         End If
     Next A
Errhan:
     If Err.Number = 0 Then
        Err.Clear
        CreateDir = True
     Else
        Err.Clear
        CreateDir = False
     End If
End Function
' 
'取磁盘信息 
'函数:GetDiskInfo 
'参数: DriveName 目标驱动器. 
'返回值:SmDriveInfo 结构. 
Public Function GetDiskInfo(DriveName As String) As SmDriveInfo
      Dim C1 As Currency
      Dim C2 As Currency
      Dim C3 As Currency
      Dim A1 As Long
      Dim Fs As New FileSystemObject
      Dim Dr As Drive
      Dim ReturnValue As SmDriveInfo
      On Error Resume Next
      Set Dr = Fs.GetDrive(DriveName)
    '/------------------------------------------ 
      ReturnValue.DriveName = Dr.Path                 '代号或路径 
      GetDiskFreeSpaceEx DriveName, C1, C2, C3
      ReturnValue.DriveIsReady = Dr.IsReady           '是否可用 
      ReturnValue.DriveType = Dr.DriveType            '类型 
      ReturnValue.DriveVolume = Dr.VolumeName         '卷标 
      ReturnValue.DriveNumber = Hex(Dr.SerialNumber)  '序列号 
      ReturnValue.DriveFileSystem = Dr.FileSystem     '文件系统 
      ReturnValue.DriveSize = C2 * 10000              '驱动器大小 
      ReturnValue.DriveFree = C1 * 10000              '可用空间 
      GetDiskInfo = ReturnValue
      Set Fs = Nothing
End Function
' 
'文件夹属性. 
'函数:GetFolderInfo 
'参数: FolderPath 目标文件夹路径. 
'返回值:SmFoldInfo 结构. 
Public Function GetFolderInfo(FolderPath As String) As SmFoldInfo
    Dim Fs As New FileSystemObject
    Dim Fd As Folder
    Dim RetuAttr As Long
    Dim FdAttr As String
    Dim A As Long
    Dim Fsize As Long
    Dim ReturnValue As SmFoldInfo
    On Error Resume Next
     
    If Len(FolderPath) = 0 Then Exit Function
    Set Fd = Fs.GetFolder(FolderPath)
    If Fd.IsRootFolder Then               '根目录 
       ReturnValue.Size = ""              '大小 
       ReturnValue.DateCreated = ""       '建立时间 
       ReturnValue.DateLastAcce = ""      '最后一次存取日期 
       ReturnValue.DateLastModified = ""  '最后一次修改时间 
       ReturnValue.Attr = ""              '属性 
    Else
       Call FAattr
       RetuAttr = Fd.Attributes
       For A = 0 To 3
           If (RetuAttr And CInt(M_AttrRHSA(A, 0))) <> 0 Then
               FdAttr = FdAttr & M_AttrRHSA(A, 1)
           End If
       Next A
       Fsize = Fd.Size
       ReturnValue.Size = Fsize
       ReturnValue.DateCreated = Fd.DateCreated             '建立时间 
       ReturnValue.DateLastAcce = Fd.DateLastAccessed       '最后一次存取日期 
       ReturnValue.DateLastModified = Fd.DateLastModified   '最后一次修改时间 
       ReturnValue.Attr = FdAttr                            '属性 
    End If
    GetFolderInfo = ReturnValue
    Set Fs = Nothing
End Function
' 
'文件信息 
'函数:GetFileInfo 
'参数: FileName 目标文件名. 
'返回值:FileInfo结构. 
Public Function GetFileInfo(Filename As String) As SmFileInfo
        Dim Fs As New FileSystemObject
        Dim F As File
        Dim RetuAttr As Long
        Dim FdAttr As String
        Dim A As Long
        Dim Fsize As Long
        Dim ReturnValue As SmFileInfo
        On Error Resume Next
        Fsize = 0
        Set F = Fs.GetFile(Filename)
        RetuAttr = F.Attributes
        For A = 0 To 3
            If (RetuAttr And CInt(M_AttrRHSA(A, 0))) <> 0 Then
               FdAttr = FdAttr & M_AttrRHSA(A, 1)
            End If
        Next A
        Fsize = F.Size: DoEvents
        ReturnValue.Size = Fsize
        ReturnValue.DateCreated = F.DateCreated            '建立时间 
        ReturnValue.DateLastAcce = F.DateLastAccessed      '最后一次存取日期 
        ReturnValue.DateLastModified = F.DateLastModified  '最后一次修改时间 
        ReturnValue.Attr = FdAttr
        GetFileInfo = ReturnValue
        Set Fs = Nothing
End Function
' 
'文件复制 
'函数:FileCopy 
'参数: SourFile 源文件名,ObjFile 目标文件名 
'返回值:=T 成功,=F 失败. 
Function FileCopy(SourFile As String, ObjFile As String) As Boolean  '文件复制 
    Dim Fs As New FileSystemObject
    On Error Resume Next
    Fs.CopyFile SourFile, ObjFile, True
    If Err.Number <> 0 Then
       Err.Clear
       FileCopy = False
    Else
       FileCopy = True
    End If
End Function
' 
'文件移动 
'函数:FileRename 
'参数: SourFile 源文件名,ObjFile 目标文件名 
'返回值:=T 成功,=F 失败. 
Function FileMove(SourFile As String, ObjFile As String) As Boolean '文件移动 
    Dim Fs As New FileSystemObject
    On Error Resume Next
    Fs.MoveFile SourFile, ObjFile
    If Err.Number <> 0 Then
       Err.Clear
       FileMove = False
    Else
       FileMove = True
    End If
    Set Fs = Nothing
End Function
' 
'文件更名 
'函数:FileRename 
'参数: SOURFILE 源文件名.OBJFILE 更改后的名字(绝对路径) 
'返回值:=T 成功,=F 失败. 
Function FileRename(SourFile As String, ObjFile As String) As Boolean '文件改名 
  Dim Fs As New FileSystemObject
  On Error Resume Next
  SetAttr SourFile, 0
  Call FileCopy(SourFile, ObjFile)
  Call FileDel(SourFile)
  If Err.Number <> 0 Then
     Err.Clear
     FileRename = False
  Else
     FileRename = True
  End If
  Set Fs = Nothing
End Function
' 
'文件删除 
'函数:FileDel 
'参数: SOURFILE 删除的文件名称 
'返回值:=T 成功,=F 失败. 
Function FileDel(SourFile As String) As Boolean
   Dim Fs As New FileSystemObject
   On Error Resume Next
   SetAttr SourFile, 0       '取消一切属性 
   Fs.DeleteFile SourFile, True
   If Err.Number <> 0 Then
      Err.Clear
      FileDel = False
   Else
      FileDel = True
   End If
   Set Fs = Nothing
End Function
' 
'文件夹的复制 
'函数:FolderCopy 
'参数: SOURFOLDER 源文件夹名,OBJFILDER 目标文件夹名 
'返回值:=T 成功,=F 失败. 
Function FolderCopy(SourFolder As String, ObjFolder As String) As Boolean
    Dim Fs As New FileSystemObject
    On Error Resume Next
    Fs.CopyFolder SourFolder, ObjFolder, True
    If Err.Number <> 0 Then
       Err.Clear
       FolderCopy = False
    Else
       FolderCopy = True
    End If
End Function
' 
'文件夹的移动 
'函数:FolderMove 
'参数: SOURFILDER 源文件夹名, OBJFOLDER 目标文件夹名 
'返回值:=T 成功,=F 失败. 
Function FolderMove(SourFolder As String, ObjFolder As String) As Boolean
    Dim Fs As New FileSystemObject
    On Error Resume Next
    Fs.MoveFolder SourFolder, ObjFolder
    If Err.Number <> 0 Then
       Err.Clear
       FolderMove = False
    Else
       FolderMove = True
    End If
    Set Fs = Nothing
End Function
' 
'文件夹的删除 
'函数:FolderDel 
'参数:SourFolder 删除的文件夹名称 
'返回值:=T 成功,=F 失败. 
Function FolderDel(SourFolder As String) As Boolean
    Dim Fs As New FileSystemObject
    On Error Resume Next
    Fs.DeleteFolder SourFolder, True
    If Err.Number <> 0 Then
       Err.Clear
       FolderDel = False
    Else
       FolderDel = True
    End If
    Set Fs = Nothing
End Function
' 
'文件夹更名 
'函数:FolderRename 
'参数:SourFolder 原文件夹名称,ObjFolder 更改后的文件夹名称. 
'返回值:=T 成功,=F 失败. 
Function FolderRename(SourFolder As String, ObjFolder As String) As Boolean
    Dim Fs As New FileSystemObject
    On Error Resume Next
    If Right(SourFolder, 1) = "/" Then SourFolder = Left(SourFolder, Len(SourFolder) - 1)
    If Right(ObjFolder, 1) = "/" Then ObjFolder = Left(ObjFolder, Len(ObjFolder) - 1)
    Fs.MoveFolder SourFolder, ObjFolder
    If Err.Number <> 0 Then
       Err.Clear
       FolderRename = False
    Else
       FolderRename = True
    End If
    Set Fs = Nothing
End Function
' 
'设置驱动器卷标 
'函数:SetVolume 
'参数:DriveName 驱动器名称,NewVolueName 新的卷标名. 
'返回值:无 
Public Function SetVolume(DriveName As String, NewVolueName As String)
        Dim Fs As New FileSystemObject
        Dim Dr As Drive
        On Error Resume Next
        Set Dr = Fs.GetDrive(DriveName)
        Dr.VolumeName = NewVolueName
        Set Fs = Nothing
End Function
Private Sub FAattr()
    M_AttrRHSA(0, 0) = 1: M_AttrRHSA(0, 1) = "R"
    M_AttrRHSA(1, 0) = 2: M_AttrRHSA(1, 1) = "H"
    M_AttrRHSA(2, 0) = 32: M_AttrRHSA(2, 1) = "A"
    M_AttrRHSA(3, 0) = 4: M_AttrRHSA(3, 1) = "S"
End Sub
' 
'打开一个文件. 
'函数: ShellFile 
'参数: 
'    FileName 要打开的文件名 _ 
'    Wait     布尔值,是否同步启动: =TRUE 同步, =FALSE 异步 _ 
'    DoPath   文件的所在目录 
'返回值:  =1 成功,=0 失败 
'*注:如果是打开一个关联文件,必须用异步方式,即Wait=False, 
'    例如要直接打开某个 ".DOC" 文档,则 WAIT=FALSE. 
Public Function ShellFile(ByVal Filename As String, _
                          Optional WinHwnd As Long = 0, _
                          Optional Wait As Boolean = False) As Long
                          
  Dim Proc As PROCESS_INFORMATION
  Dim Start As STARTUPINFO
  Dim Rc As Long
  Dim Mdriv As String
  Dim OpenName As String
  Dim OpenPath As String
  
  OpenName = FileNameExp(Filename): OpenPath = FilePath(Filename)
  If Wait Then '如果T,同步启动 
     Start.cb = Len(Start)
     '/建立一个新的进程 
     Rc = CreateProcess(Filename, OpenPath, _
                        ByVal 0, ByVal 0, 1, _
                        NORMAL_PRIORITY_CLASS, _
                        ByVal 0, OpenPath, _
                        Start, Proc)
     '/等待,直到进程结束 
     Rc = WaitForSingleObject(Proc.hProcess, INFINITE)
     '/关闭进程 
     Rc = CloseHandle(Proc.hProcess)
  Else
     '/否则,异步启动,(资源管理器启动) 
     Rc = ShellExecute(WinHwnd, "Open", OpenName, "", OpenPath, SW_MAXIMIZE)
  End If
  ShellFile = Rc
End Function
' 
'启动EXE文件 
'函数:OpenExe 
'参数:FileName EXE文件名,WorkPath 工作目录. 
'返回值:该EXE的进程句柄 
Public Function OpenExe(ByVal Filename As String, _
                        Optional WorkPath As String = "") As Long
  Dim Proc As PROCESS_INFORMATION
  Dim Start As STARTUPINFO
  Dim Rc As Long
  Dim Mdriv As String
  Dim A As String
  Dim B As String
  Dim ExeName As String
  
  On Error Resume Next
  
  ExeName = FileNameExp(Filename)
  WorkPath = FilePath(Filename)
  ChDrive Left$(WorkPath, 2)
  ChDir WorkPath
  Rc = CreateProcess(ExeName, WorkPath, _
                     ByVal 0, ByVal 0, 1, _
                     NORMAL_PRIORITY_CLASS, _
                     ByVal 0, vbNullString, _
                     Start, Proc)
  OpenExe = Proc.hProcess
End Function
' 
'关闭一个EXE文件 
'函数:CloseExe 
'参数:ProID 该EXE的进程句柄 
'返回值:无 
Public Function CloseExe(ProID As Long)
     Dim Rc As Long
     '/中断一个进程 
      Call TerminateProcess(ProID, 0)
     '/关闭该进程 
      Call CloseHandle(ProID)
End Function
' 
'运行一个程序或文档. 
'函数:RunFile 
'参数:FilePath 要打开的文件路径 
'返回值:无 
'注:实际上是 [开始]==>[运行] 
Public Function RunFile(FilePath As String)
       Call Shell("rundll32.exe url.dll,FileProtocolHandler " & FilePath, 1)
End Function
Private Sub Class_Initialize()
'    Dim T As New ClsRev 
'    Call T.GetIniVal 
'    Set T = Nothing 
End Sub
' 
'取临时文件名. 
'函数:GetTempName 
'参数:TmpNameDir 创建临时文件目录,FilePreFix 临时文件前缀. 
'返回值:一件临时文件名. 
Public Function GetTempName(Optional TmpDir As String = "", Optional FilePreFix = "TmpFile") As String
   Dim TempFileName As String * 256
   Dim X As Long
   Dim DriveName As String
   Dim SysTmpDir As New SmSysCls
      
   If Len(Trim$(TmpDir)) = 0 Then
      TmpDir = SysTmpDir.GetFolder(SmWinTempDirectory)
   End If
   If Len(Trim$(TmpDir)) = 0 Then TmpDir = "C:/"
   If Dir$(TmpDir, vbDirectory + vbAlias + vbSystem + vbHidden) = "" Then TmpDir = "C:/"
   If Right$(TmpDir, 1) <> "/" Then TmpDir = TmpDir & "/"
   
   DriveName = TmpDir
   X = GetTempFileName(DriveName, FilePreFix, 0, TempFileName)
   GetTempName = Left$(TempFileName, InStr(TempFileName, Chr$(0)) - 1)
   Set SysTmpDir = Nothing
End Function
' 
'判断某个文件是否存在. 
'函数:FileCheck 
'参数:FileName 目标文件名. 
'返回值:=TRUE 存在,=FALSE 不存在. 
Public Function FileCheck(Filename As String) As Boolean
     Dim FileID As Long
     
     On Error Resume Next
     
     FileID = FreeFile()
     Open Filename For Input As #FileID
     Close #FileID
     FileCheck = (Err.Number = 0)
     Err.Clear
End Function
' 
'读INI文件. 
'函数:GetIniStr 
'参数:AppName 项目名.In_Key 键名,sFileName 文件名 
'返回值:成功:对应的键值.失败或不存在:"" 
Public Function GetIniStr(ByVal AppName As String, ByVal In_Key As String, ByVal sFileName As String) As String
    
    On Error GoTo GetIniStrErr
    
    If VBA.Trim$(In_Key) = "" Then
       GoTo GetIniStrErr
    End If
    Dim GetStr As String
    GetStr = VBA.String(128, 0)
    GetPrivateProfileString AppName, In_Key, "", GetStr, 256, sFileName
    GetStr = VBA.Replace(GetStr, VBA.Chr(0), "")
    If GetStr = "" Then
       GoTo GetIniStrErr
    Else
       GetIniStr = GetStr
       GetStr = ""
    End If
    Exit Function
GetIniStrErr:
       Err.Clear
       GetIniStr = ""
       GetStr = ""
End Function
' 
'写INI文件. 
'函数:WriteIniStr 
'参数:AppName 项目名.In_Key 键名,In_Data 键值,sFileName 文件名 
'返回值:成功=TRUE.失败=FALSE 
Public Function WriteIniStr(ByVal AppName As String, ByVal In_Key As String, ByVal in_data As String, ByVal sFileName As String) As Boolean
    On Error GoTo WriteIniStrErr
    WriteIniStr = True
    If VBA.Trim(In_Key) = "" Or VBA.Trim(AppName) = "" Then
       GoTo WriteIniStrErr
    Else
     WritePrivateProfileString AppName, In_Key, in_data, sFileName
    End If
    Exit Function
    
WriteIniStrErr:
       Err.Clear
       WriteIniStr = False
End Function
' 
'读TEXT文件 
'函数:RedTextFile 
'参数:FileName 打开的TXT文件名. 
'返回值:成功 返回文件内容.失败  返回"" 
Public Function RedTextFile(Filename As String) As String
     Dim FileID As Long
     Dim InputStr As String
     Dim LineStr As String
     
     On Error Resume Next
     
     InputStr = "": LineStr = ""
     FileID = FreeFile()
     Open Filename For Input As #FileID
          Do While Not EOF(FileID)           ' 循环至文件尾。 
             LineStr = ""
             Line Input #FileID, LineStr
             InputStr = InputStr & LineStr
          Loop
     Close #FileID
     RedTextFile = IIf(Err.Number = 0, InputStr, "")
     Err.Clear
End Function
' 
'写TEXT文件 
'函数:WritTextFile 
'参数:FileName 目标文件名.WritStr 写到目标的字符串. 
'返回值:成功 返回文件内容.失败  返回"" 
'注:如果同名,目标字符串将覆盖原文件内容. 
Public Function WritTextFile(Filename As String, WritStr As String) As Boolean
'/保存文件 
    Dim FileID As Long, ConTents As String
    Dim A As Long, B As Long
    
    On Error Resume Next
    
    FileID = FreeFile
    Open Filename For Output As #FileID
         Print #FileID, WritStr
    Close #FileID
    WritTextFile = (Err.Number = 0)
    Err.Clear
End Function
' 
 
华芸智森
关注
0
点赞
踩
1

收藏

觉得还不错? 一键收藏
1
评论
VB 磁盘信息,文件夹,文件操作

文件,文件夹操作类 /工程==>引用==>Microsoft Scripting Runtime Option ExplicitPrivate Const HKEY_CLASSES_ROOT = Private Const HKEY_CURRENT_USER = Private Const HKEY_LOCAL_MACHINE = Priv
复制链接

扫一扫
专栏目录