form1.frm

这是用Vb编写的虚拟驱动程序,希望对大家有帮助.

'Getting Current Drive On The System
Public Function DriveList()
Dim strDrive As String
Dim dwDrives As Long
Dim Drives As New Collection
'Get Drives
   dwDrives = GetLogicalDrives()
'Begin with the drive A
   strDrive = "A"
   Do While (dwDrives > 0)
      If (dwDrives And 1) = 1 Then ' A logical drive with this letter exists
         TokenDrives.Add strDrive
         dwDrives = dwDrives - 1
      End If
'We need only the drive letter, nothin' else
      strDrive = Chr$(Asc(strDrive) + 1)
      dwDrives = dwDrives \ 2
   Loop
End Function
'///////////////////////////////////////////////
'///////////////////////////////////////////////
'///////////////////////////////////////////////
Public Function GetVirtuals() As String
'1-Find the subst path
'How We Can Get Virtual Drives??
'In Order Subst when run with no parameters will provide us with the current virtual drives
'on th system written in the DOS
'so what we have to do is Get The DOS Output of the SUBST.EXE
'we DON'T need the Outputs, We Save the Drives in INI file and here we read it
On Error GoTo ErrX
Dim Datas As String, Ld As String, nF As String
nF = FreeFile
Open App.Path & "\Drives.ini" For Input As #nF
If Not EOF(nF) Then Line Input #nF, Datas
While Not EOF(nF)
    Line Input #nF, Ld
    'Read Data Inside Drives.ini
    Datas = Datas & vbCrLf & Ld
Wend
Close #nF
'Replace The "," With " >"
GetVirtuals = Replace(Datas, ",", " >", 1, -1, vbTextCompare)
ErrX:
End Function
'---------------------------------------------------------------------
'Find Sub Searches for SubSt.EXE
'If not found in windows directory(and sub-dirs) program will not work
Function FindSubst()
Register
If Not Trim(GetSetting("Technosoft", "VirtualDrive", "Subst")) = "" Then
    'If we already made that search
    'Load Old SubST Location
    MySubSt = GetSetting("Technosoft", "VirtualDrive", "Subst")
    'Check If The File Still Exsists
    If Dir$(MySubSt, vbNormal + vbHidden + vbReadOnly + vbSystem + vbArchive) = "" Then SaveSetting "Technosoft", "VirtualDrive", "Subst", "": FindSubst
        'When Not Exisists : Search For It Again
    Exit Function
End If
Dim mColl As New Collection, mBuff As String
'Memory Buffer Variable
mBuff = Space$(255)
'Read Windows Directory
GetWindowsDirectory mBuff, 255
mBuff = StripTerminator(mBuff)
'Get Windows Directory Followed By "\"
mBuff = IIf(Right$(mBuff, 1) = "\", mBuff, mBuff & "\")
'Then Remove The "\"
mBuff = Left$(mBuff, Len(mBuff) - 1)
'Search For Subst.exe
FindFiles mBuff, "*", "Subst.exe", mColl
'If Not Found (The mColl will not contain anything) then Exit
If mColl.Count = 0 Then MsgBox "Subst.exe was not found in windows, Please Check your windows!", vbCritical: End
'File Found, So Save It's Location Not To Make This Search Again
SaveSetting "Technosoft", "VirtualDrive", "Subst", mColl.Item(1)
'Put The Location Into Variable In Order To Use It.
MySubSt = GetSetting("Technosoft", "VirtualDrive", "Subst")
End Function
'Add The Program's Registry Entries
Function Register()
'Check That The Current Working EXE is registered or not ...
If GetSetting("Technosoft", "VDRV", "Path") <> App.Path & "\" & App.EXEName & ".exe" Then
    'Add The Command To Folder Explorer's Menu
    SaveString HKEY_CLASSES_ROOT, "Folder\shell\Make A Virtual Drive\command", "", App.Path & "\" & App.EXEName & ".exe" & " /ADDDRV %1"
    'Add a Command To Make The Program Loads Drives Automatically When Windows Start Up
    SaveString HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Run", "Restore Drives", App.Path & "\" & App.EXEName & ".exe" & " /STARTUP"
    'Save a Sign, Not To Make This Register Each Time.........
    SaveSetting "Technosoft", "VDRV", "Path", App.Path & "\" & App.EXEName & ".exe"
    'Display Registration Box
    MsgBox "Register Done.", vbInformation
End If
End Function
Private Sub Command1_Click()
Unload Me
End
End Sub
Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
If Not Label1.Caption = Command1.Tag Then Label1.Caption = Command1.Tag
End Sub
Private Sub Command2_Click()
'If There are no free drives?
If FreeDrives.Count = 0 Then MsgBox "Virtual Drives is more than needed, Please Remove One Or More To Continue.", vbCritical: Exit Sub
Dim mRelated As String, mEmpty As String
'Get Desired Folder
mRelated = BrowseFolder(Me, "Select Related Folder")
'User Selected A Valid Folder
If Trim(mRelated) = "" Then Exit Sub
If Len(mRelated) <= 3 Then MsgBox "Please Select Folder Only" & vbCrLf & "Drive Not Created.", vbCritical: Exit Sub
'Show That We are working now ...
Label5.Caption = "Working...": DoEvents
'Get a Valid Empty Drive
mEmpty = GetDrive
'Execute SubSt
Shell MySubSt & " " & mEmpty & " " & GetShortPathName(mRelated), vbHide
'Wait Till It Done
DoEvents
'Adding Drive To Our List
AddDrive mEmpty, mEmpty, mRelated
'Show That We are Ready now ...
Label5.Caption = "Ready"
End Sub
'To Select an Empty Valid Drive
Function GetDrive() As String
'The First Item in the Empty Drives' Collection
GetDrive = FreeDrives(1) & ":"
'Remove the token drive from the list
FreeDrives.Remove (1)
End Function
Private Sub Command2_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
If Not Label1.Caption = Command2.Tag Then Label1.Caption = Command2.Tag
End Sub
Private Sub Command3_Click()
'If not selected any item yet, Exit
If Trim(ImList1.Title(ImList1.Selected)) = "" Then Exit Sub
'Sure?
If MsgBox("Are you sure you want to Remove" & vbCrLf & "the drive " & ImList1.Title(ImList1.Selected) & " from the system?", vbExclamation + vbYesNo, "Delete Drive") = vbNo Then Exit Sub
'Show That We are working now ...
Label5.Caption = "Working...": DoEvents
'The Drive that will be deleted
mEmpty = Left$(ImList1.Title(ImList1.Selected), 2)
'Execute SubSt
Shell MySubSt & " " & mEmpty & " /D", vbHide
'Add The Deleted Drive to the Empty Drives' Collection
FreeDrives.Add Left$(ImList1.Title(ImList1.Selected), 1)
'Remove it from the displayed list
ImList1.Remove ImList1.Selected
'Wait to be done
DoEvents
'Show That We are Ready now ...
Label5.Caption = "Ready"
End Sub
Private Sub Command3_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
If Not Label1.Caption = Command3.Tag Then Label1.Caption = Command3.Tag
End Sub
Private Sub Command4_Click()
'Changing Path Of Virtual Drive
'In Order We Can't Change The Path Of the Virtual Drive
'So We Well Remove the old virtual drive
'and we will put a new one containing the new path with the same letter
'here are how ...
Dim OldPath As String, NewPath As String
'If not selected any item yet, Exit
If Trim(ImList1.Title(ImList1.Selected)) = "" Then Exit Sub
Dim mRelated As String, mEmpty As String
'Get a folder
mRelated = BrowseFolder(Me, "Select Related Folder")
'User Selected a valid folder?
If Trim(mRelated) = "" Then Exit Sub
'don't select a drive!!
If Len(mRelated) <= 3 Then MsgBox "Please Select Folder Only" & vbCrLf & "Drive Not Created.", vbCritical: Exit Sub
'Show That We are Working now ...
Label5.Caption = "Working...": DoEvents
'the selected drive
mEmpty = Left$(ImList1.Title(ImList1.Selected), 2)
'the old path, we use it to copy the file that discribe the drive to the new position
OldPath = ImList1.Tip(ImList1.Selected)
'The New Path that User have selected
NewPath = mRelated
'Make Old Path followed by "\"
OldPath = IIf(Right$(OldPath, 1) = "\", OldPath, OldPath & "\")
'Make New Path followed by "\"
NewPath = IIf(Right$(NewPath, 1) = "\", NewPath, NewPath & "\")
'Execute Command TO DELETE the DRIVE
Shell MySubSt & " " & mEmpty & " /D", vbHide
'Wait
DoEvents
'Execute The Command TO CREATE THE SAME DRIVE with the NEW PATH
Shell MySubSt & " " & mEmpty & " " & GetShortPathName(mRelated), vbHide
'Modify The Image List
ImList1.SetTip ImList1.Selected, mRelated
'Wait to be done
DoEvents
'if Exsists the file that discribr the drive "AUTORUN.INF", Then copy it to the new location and delete it from the old location
If Dir$(OldPath & "Autorun.inf", vbNormal + vbHidden + vbArchive + vbReadOnly + vbSystem) <> "" Then FileCopy OldPath & "Autorun.inf", NewPath & "Autorun.inf": Kill OldPath & "Autorun.inf"
'Show That We are Ready now ...
Label5.Caption = "Ready"
End Sub
Private Sub Command4_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
If Not Label1.Caption = Command4.Tag Then Label1.Caption = Command4.Tag
End Sub
'Change Icon
Private Sub Command5_Click()
'If not selected any item yet, Exit
If Trim(ImList1.Title(ImList1.Selected)) = "" Then Exit Sub
Dim mIcon As String, mDrv As String
'Select The Icon
mIcon = DialogFile(Me, "Choose Icon", "Icons.ico", "*.ico", App.Path, "8.ico", 1)
'If User Selected Icon?
If Not Trim(mIcon) = "" Then
    'Selected Virtual Drive
    mDrv = Trim(ImList1.Title(ImList1.Selected))
    'Selected Drive Followed By "\" in [X:\] Format
    mDrv = IIf(Right$(mDrv, 1) = "\", mDrv, mDrv & "\")
    'write the icon location in the discription file [Autorun.inf] Which Must Be in the root folder
    WritePrivateProfileString "AutoRun", "Icon", mIcon, mDrv & "Autorun.inf"
    'Announce that we may need to restart the system to see the icon change
    MsgBox "You May Need to Restart Your System Before Icon Change Take Effects!", vbInformation
    'It's all
End If
End Sub
Private Sub Command5_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
If Not Label1.Caption = Command5.Tag Then Label1.Caption = Command5.Tag
End Sub
Private Sub Command6_Click()
'Auto Run Programs is Only Valid With Virtual CD-ROM, Not Valid with Virtual Logical Drives!
End Sub
Private Sub Command6_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
If Not Label1.Caption = Command6.Tag Then Label1.Caption = Command6.Tag
End Sub
Private Sub Form_Load()
'_First of all you must run a compiled EXE
If App.LogMode = 0 Then 'If the project running from Visual Basic Envirnoment
    'Sorry We Need The Compiled EXE in order to make the program registration work
    MsgBox "Compile EXE and RunIt for full function! Must Be an EXE Project.", vbCritical
    'Exit Please
    End
    'No Need To Your Command, You are forced to exit
End If
'************************************************************
'**************************COMMANDS**************************
'**/STARTUP               Load Prevous Drives
'**/ADDDRV ?????????      ADD A VIRTUAL DRIVE USING THIS PATH
'************************************************************
FindSubst
'StartUp is Restoring (Loading Old Drives)
Dim mRelated As String, mEmpty As String, nF, Ld
If UCase(Command) = "/STARTUP" Then 'Load Virtual Drives
    nF = FreeFile
    'Read Old Virtual Drives
    Open App.Path & "\Drives.ini" For Input As #nF
    While Not EOF(nF)
        Line Input #nF, Ld
        'The Drive Letter
        mEmpty = GetBF(",", Ld, 1)
        'The Path
        mRelated = GetAL(",", Ld)
        'Make It
        Shell MySubSt & " " & mEmpty & " " & GetShortPathName(mRelated), vbHide
        'Wait for it
        DoEvents
    'Do The Next Drive
    Wend
    Close #nF
    'Exit after drives made
    End
End If
'Show the window
Show: DoEvents
'The Program is busy now!
Label5.Caption = "Working..."
'Wait for Events
DoEvents
'///////////
'Listing Free Drives
DriveList
'Listing Free Drives
Dim OldDrv As Byte, CDrv As Byte
'Discover Empty Drives
OldDrv = Asc(UCase(Left$(TokenDrives(1), 1)))
For I = 2 To TokenDrives.Count
    CDrv = Asc(UCase(Left$(TokenDrives(I), 1)))
    If Val(CDrv - OldDrv) > 1 Then 'Found Empty Drives
        For S = OldDrv + 1 To CDrv - 1 'The Empty Drives Between the two drives
            If Chr(S) = "B" Then GoTo NextS 'we dont need drive B:\ for no conflicting
            FreeDrives.Add Chr(S) 'here are a free drive letter
NextS:
        'Next Empty Drive
        Next
    End If
    OldDrv = CDrv 'The Old Drive Now is the Current Drive[Move to next]
Next
'asc(Z) = 90
For I = CDrv + 1 To 90 'continue adding till drive Z
    FreeDrives.Add Chr(I)
Next
'/End Listing Free Drives
'SEARCH THE /ADDDRV COMMAND
If UCase(Left$(Command, Len("/ADDDRV"))) = "/ADDDRV" Then 'The Command is /ADDDRV
    Ld = Command$
    'Get an Empty Valid Drive
    mEmpty = GetDrive
    'Extract The Path form the command line
    mRelated = GetAF(" ", Ld, 1)
    'Make the desired virtual drive
    Shell MySubSt & " " & mEmpty & " " & GetShortPathName(mRelated), vbHide
    'wait to be done
    DoEvents
    nF = FreeFile
    'Add the new drive to the INI file
    Open App.Path & "\Drives.ini" For Append Shared As #nF
    'in order to keep information alive
    Print #nF, mEmpty & "," & mRelated
    Close #nF
    End
End If
'///////////
Dim GetVirtual
'Load Virtaul Drives From Our INI File
GetVirtual = GetVirtuals
Dim tmpCol As New Collection
'Extract Lines Form The String
GetAllAB2 GetVirtual, vbCrLf, vbCrLf, tmpCol
'Maybe oly one line
If tmpCol.Count = 0 Then tmpCol.Add GetVirtual 'so add this unique line to the list
'Listing The Drives in the Image List "Im List1"
For I = 1 To tmpCol.Count
    If Not Trim$(tmpCol(I)) = "" Then
        'Adding to list function
        AddDrive Left$(Trim(tmpCol(I)), 2) & "\", Left$(Trim(tmpCol(I)), 2) & "\", GetLongPathName(Trim(GetAL(">", tmpCol(I))))
    End If
Next
'Now we are ready
Label5.Caption = "Ready"
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
'Save Current Virtual Drives in INI File
Dim nF
nF = FreeFile
Open App.Path & "\Drives.ini" For Output As #nF
For I = 1 To ImList1.Count
'Write V Drives Information
'[Drive:\],[PATH]
Print #nF, Left$(ImList1.Title(I), 2) & "," & Trim(ImList1.Tip(I))
Next I
Close #nF
'no we don't need to make any thing else
End
End Sub
'Now, You can vote if you want!!