module1.bas

虚拟驱动器

Attribute VB_Name = "Module1"
'****************************************************************************
'人人为我，我为人人
'枕善居汉化收藏整理
'发布日期：05/04/08
'描  述：创建虚拟磁盘
'网  站：http://www.mndsoft.com
'e-mail：[e-mail]/blog/
'OICQ  : 88382850
'****************************************************************************
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long

Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const SYNCHRONIZE = &H100000
Private Const PROCESS_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or SYNCHRONIZE Or &HFFF)
Private Const STATUS_PENDING = &H103
Private Const STILL_ACTIVE = STATUS_PENDING

Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_USENEWUI = &H40

Private Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Public Function GetShortPath(lzPathName As String) As String
    ' Used to convert a long pathname to a short path
    Dim iRet As Long, StrA As String
    StrA = String$(165, vbNullChar) ' Create a buffer
    iRet = GetShortPathName(lzPathName, StrA, 164)
    GetShortPath = Left$(StrA, iRet) ' Trim of any nullchars
End Function

Function GetFolder(ByVal hWndOwner As Long, ByVal sTitle As String) As String
Dim bInf As BROWSEINFO
Dim RetVal As Long
Dim PathID As Long
Dim RetPath As String
Dim OffSet As Integer

    bInf.hOwner = hWndOwner
    bInf.lpszTitle = sTitle
    bInf.ulFlags = BIF_RETURNONLYFSDIRS Or BIF_USENEWUI
    PathID = SHBrowseForFolder(bInf)
    RetPath = Space$(512)
    RetVal = SHGetPathFromIDList(ByVal PathID, ByVal RetPath)
    If RetVal Then
        OffSet = InStr(RetPath, Chr$(0))
        GetFolder = Left$(RetPath, OffSet - 1)
    End If

End Function

Public Function SHWait(ByVal ProgID As Long) As Boolean
Dim mExitID As Long, hdlProg As Long
' This function is used to let the user know when a MS Dos command has finsihed
    hdlProg = OpenProcess(PROCESS_ALL_ACCESS, False, ProgID)
    GetExitCodeProcess hdlProg, mExitID
    Do While mExitID = STILL_ACTIVE
        DoEvents
        GetExitCodeProcess hdlProg, mExitID
    Loop
    CloseHandle hdlProg
    SHWait = mExitID
End Function