frmmain.frm

虚拟驱动器

    Strln = ""
    mDrive = ""
    mPath = ""
    mCount = ""
    
End Function
Private Function FixPath(lzPath As String) As String
    ' 修复路径错误
    If Right$(lzPath, 1) = "\" Then FixPath = lzPath Else FixPath = lzPath & "\"
End Function

Private Sub DoUpdate()
    GetVirtualsDriveList
    GetAveDrivesList cbodrives
End Sub

Private Sub GetAveDrivesList(cboBox As ComboBox)
Dim iRet As Long
Dim Counter As Integer
    
    cboBox.Clear ' 清除列表框
    iRet = GetLogicalDrives '获取驱动器
    
    For Counter = 0 To 25
        If Not (iRet And 2 ^ Counter) <> 0 Then cboBox.AddItem Chr(65 + Counter) & ":"
    Next
    cboBox.ListIndex = 0
    Counter = 0
    iRet = 0
    
End Sub

Private Sub GetVirtualsDriveList()
Dim Counter As Integer, Strln As String, lzTmp As String, mDrive As String, mPath As String, vData As Variant
Dim TFile As Long, mDone As Boolean
'On Error Resume Next

    lstDrives.ListItems.Clear
    ChDir AbsRoot ' 改变到 C:\
    
    iWait = Shell("command.com /c" & "subst > tmpout.txt", vbHide) '执行命令并写入文件
    mDone = SHWait(iWait) ' 等待
    
    If Not mDone Then
        lzTmp = AbsRoot & "tmpout.txt" ' 读取临时文件
        If FileLen(lzTmp) = 0 Then Kill AbsRoot & "tmpout.txt": Exit Sub ' Check if anything in the text file by checking the filesize
        
        TFile = FreeFile ' Pointer to free file
        
        Open lzTmp For Input As #TFile
            Do While Not EOF(TFile) ' Loop while we are not at the end of the file
                Counter = Counter + 1 ' Add one to our counter
                Input #TFile, Strln ' Read in each line
                vData = Split(Strln, "=>") ' Used for split command
                mDrive = Mid(vData(0), 1, 3) ' Get the virtual drive name
                mPath = Trim(vData(1))       ' Get the virtual drives path
                lstDrives.ListItems.Add , "A" & Counter, mDrive, 1, 1 ' Add the virtual drivename to the list view
                lstDrives.ListItems(Counter).SubItems(1) = mPath    ' Add the virtual path to the listview
                DoEvents
            Loop
        Close #TFile
    End If
    
    ' Clear vars
    Erase vData
    Counter = 0
    Strln = ""
    mPath = ""
    mDrive = ""
    lzTmp = ""
    Kill AbsRoot & "tmpout.txt" ' This will delete the temp file as we have now finished with it
    ChDir AbsPath
End Sub

Private Sub cmdabout_Click()
    mnuabout_Click ' Call cmdabout_Click
End Sub

Private Sub cmdcreate_Click()
Dim iWait As Long, mDone As Boolean

    ChDir AbsRoot ' Change to the system root path eg C:\
    
    iWait = Shell("command.com /c" & "subst " & cbodrives.Text & " " & txtPathName.Text, vbHide)  'Run the subst command
    mDone = SHWait(iWait) ' Wait until the command has finished
    
    If Not mDone Then
        MsgBox "当前虚拟盘 " & cbodrives.Text & " 创建成功.", vbInformation, frmmain.Caption
    End If
    
    DoUpdate ' 更新到列表
End Sub

Private Sub cbodrives_Change()
    cbodrives.Text = mOld
    'The code above is only used to hold what was last in the combo box edit box
    ' Just saves users right clicking and deleteing the text.
End Sub

Private Sub cbodrives_Click()
    mOld = cbodrives.Text
End Sub

Private Sub chkrestore_Click()
Dim Counter As Integer

    If lstDrives.ListItems.Count = 0 Then Exit Sub
    ChDir AbsPath
    
    If chkrestore Then
        SaveString HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Run", "VDriveC", FixPath(App.Path) & App.EXEName & ".exe -r"
        For Counter = 1 To lstDrives.ListItems.Count
            mLst = lstDrives.ListItems(Counter).Text & "=>" & lstDrives.ListItems(Counter).SubItems(1)
            SaveSetting "dmVDriveC", "Config", "Drives" & Counter, mLst
        Next
        SaveSetting "dmVDriveC", "Config", "Count", Counter - 1
        SaveSetting "dmVDriveC", "Config", "Restore", 1
    Else
         DeleteValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Run", "VDriveC"
         DeleteSetting "dmVDriveC", "Config"
    End If

End Sub

Private Sub cmdbroswe_Click()
Dim FolName As String
    FolName = GetFolder(frmmain.hWnd, "请选择想要创建的虚拟磁盘:")
    
    If Not Len(FolName) > 1 Then
        cmdcreate.Enabled = False
        txtPathName.Text = ""
    Else
        cmdcreate.Enabled = True
        txtPathName.Text = GetShortPath(FolName)
    End If
    
End Sub

Private Sub cmddelete_Click()
Dim mDrv As String, Ans As String, mDone As Boolean, iWait As Long
Dim LstIdx As Long

    mDrv = Mid(lstDrives.SelectedItem.Text, 1, 2)
    
    Ans = MsgBox("确认要删除当前虚拟驱动盘 " & mDrv, vbYesNo Or vbQuestion, frmmain.Caption)
    If Ans = vbNo Then Exit Sub
    ChDir AbsRoot
    
    iWait = Shell("command.com /c" & "subst " & mDrv & " /d", vbHide) 'Run the subst command
    mDone = SHWait(iWait) ' Wait until the command has finished
    
    If Not mDone Then
        MsgBox "当前虚拟磁盘已经删除", vbInformation, frmmain.Caption
    End If

    If lstDrives.ListItems.Count = 0 Then
        cmddelete.Enabled = False
        chkrestore.Enabled = False
    End If
    DoUpdate
End Sub

Private Sub cmdexit_Click()
    mnuexit_Click ' mnuexit_Click
End Sub

Private Sub Form_Load()
Dim mRes As String, mFirstTime As String, Ans As Integer
Dim sCommand As String

        mFirstTime = GetSetting("dmVDriveC", "main", "FirstTime", "yes")
        
        If mFirstTime = "yes" Then ' Check this is the first time the programs been run
            Ans = MsgBox("This is your first time useing " & frmmain.Caption _
            & vbCrLf & vbCrLf & "Would you like to add the option " _
            & "To allow you to add folder paths from explorer" _
            & vbCrLf & "This will be done by adding in menu item to the windows right menu for folders?" _
            , vbYesNo Or vbQuestion, "First Time")
            ' The code above will show a message to user asking if they like to
            ' Add right click support to expoler to allow the user to add folders.
        
            If Ans = vbNo Then ' The user does not to add the support
                SaveSetting "dmVDriveC", "main", "FirstTime", "no"
                ' write the value that this is not the first time the program been run
            Else
                SaveKey HKEY_CLASSES_ROOT, "Folder\shell\Create Virtual Drive" ' Add the reg key
                SaveKey HKEY_CLASSES_ROOT, "Folder\shell\Create Virtual Drive\command" ' Add the reg key command
                SaveString HKEY_CLASSES_ROOT, "Folder\shell\Create Virtual Drive\command", "", FixPath(App.Path) & App.EXEName & " -ADD %1"
                SaveSetting "dmVDriveC", "main", "FirstTime", "no" ' just to let us know that the program has been run
            End If
        End If
        
        lstDrives.ColumnHeaders.Add , , "磁盘", 850 ' Add the drive column Header
        lstDrives.ColumnHeaders.Add , , "物理路径", lstDrives.Width - 900 ' Add the path column header
    
        mRes = GetSetting("dmVDriveC", "Config", "Restore", "") ' Check if the resotre option is in the registry
    
        chkrestore.Value = CInt(Val(mRes)) ' Convert the string to a int val

        sCommand = UCase(Trim(Command$)) ' Get what is in the command line
        AbsRoot = Mid(CurDir(App.Path), 1, 3) ' Gets the Current drive Path
        AbsPath = FixPath(App.Path) ' Get the path of this program
        
        If sCommand = "-R" Then
            frmmain.Hide
            ' The code above tells us that the user has requested that the
            ' virtual drives are to be restored the next time windows starts
            SetUpVDrives
            Unload frmmain
            End
        ElseIf Left(sCommand, 4) = "-ADD" Then
             cmdcreate.Enabled = True
             txtPathName.Text = Mid(sCommand, 5, Len(sCommand))
             DoUpdate
             Exit Sub
        Else
            DoUpdate
        End If
        
        ' Clear old vars
        Ans = 0
        mFirstTime = ""
        sCommand = ""
        mRes = ""
    
End Sub

Private Sub Form_Resize()
    Line3D1.Width = frmmain.ScaleWidth
    Line3D2.Width = frmmain.ScaleWidth
End Sub

Private Sub Form_Unload(Cancel As Integer)
    mOld = ""
    Set frmmain = Nothing
End Sub

Private Sub lstDrives_ItemClick(ByVal Item As MSComctlLib.ListItem)
    If lstDrives.ListItems.Count = 0 Then Exit Sub
    cmddelete.Enabled = True
    
End Sub

Private Sub mnuabout_Click()
    frmabout.Show vbModal, frmmain
End Sub

Private Sub mnuexit_Click()
    AbsPath = ""
    AbsRoot = ""
    Unload frmmain
End Sub