Without subst.exe
DefineDosDevice(0, sDriveLetter, sMountPath)
DefineDosDevice(DDD_REMOVE_DEFINITION, sDriveLetter, sMountPath)
DefineDosDevice(0, sDriveLetter, sMountPath)
DefineDosDevice(DDD_REMOVE_DEFINITION, sDriveLetter, sMountPath)
Code:
Private Sub Command3_Click()
DefineDosDevice 0, "M:", "C:\Users\Public\Desktop\AAA"
End Sub
Private Sub Command4_Click()
DefineDosDevice 2, "M:", "C:\Users\Public\Desktop\AAA"
End SubCode:
Private Sub Command1_Click()
FolderToDriver "M", "C:\Users\Public\Desktop\AAA"
End Sub
Private Sub Command2_Click()
'Remove Driver
FolderToDriver "M", "C:\Users\Public\Desktop\AAA", True
End SubCode:
'Virtual directory is a drive
Private Declare Function DefineDosDevice Lib "kernel32" Alias "DefineDosDeviceA" (ByVal dwFlags As Long, ByVal lpDeviceName As String, Optional ByVal lpTargetPath As String = vbNullString) As Long
'Get Drive Type ...
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
'---- constant ----------------------------------------
'Mobile device identification
Private Const DDD_REMOVE_DEFINITION As Long = &H2
'drive type ID ...
Private Const DRIVE_REMOVABLE = 2
Private Const DRIVE_FIXED = 3
Private Const DRIVE_REMOTE = 4
Private Const DRIVE_CDROM = 5
Private Const DRIVE_RAMDISK = 6
'Does the folder exist
Public Function FolderExists(ByVal sPath As String) As Boolean
On Error GoTo FolderExists_Error
If Dir(sPath, vbDirectory) <> "" Then
FolderExists = True
Else
FolderExists = False
End If
Exit Function
FolderExists_Error:
MsgBox Err.Number & " : " & vbCrLf & vbCrLf & Err.Description, vbInformation, "An error occurred !"
Exit Function
End Function
'Create a virtual drive, with the third parameter being TRUE, representing uninstalling the drive
Public Function FolderToDriver(ByVal sDriveLetter As String, ByVal sMountPath As String, Optional ByVal bUnmount As Boolean = False) As Boolean
On Error GoTo FolderToDriver_Error
Dim lDriveType As Long
sDriveLetter = Trim(sDriveLetter)
If Len(sDriveLetter) <> 1 Then
Err.Raise 1002, "FolderToDriver", "An error occurred."
FolderToDriver = False
End If
If FolderExists(sMountPath) = False Then
Err.Raise 1001, "FolderToDriver", "The specified drive path is incorrect or an invalid folder."
FolderToDriver = False
End If
'DefineDosDevice ...
sDriveLetter = sDriveLetter & ":"
'Get Drive Type
lDriveType = GetDriveType(sDriveLetter & "\")
'If the specified drive letter is already in use, such as a local disk...
Select Case lDriveType
Case DRIVE_CDROM
Err.Raise 1002, "FolderToDriver", "The specified drive is invalid and cannot load the virtual drive!"
FolderToDriver = False
'Virtual drive, when installed successfully, is considered a local fixed drive. So, here we will uninstall the executed code...
Case DRIVE_FIXED
If bUnmount = False Then
Err.Raise 1002, "FolderToDriver", "The specified drive is invalid and cannot load the virtual drive!"
FolderToDriver = False
Else
FolderToDriver = CBool(DefineDosDevice(DDD_REMOVE_DEFINITION, sDriveLetter, sMountPath))
FolderToDriver = True
End If
Case DRIVE_RAMDISK
Err.Raise 1002, "FolderToDriver", "The specified drive is invalid and cannot load the virtual drive!"
FolderToDriver = False
Case DRIVE_REMOVABLE
Err.Raise 1002, "FolderToDriver", "The specified drive is invalid and cannot load the virtual drive!"
FolderToDriver = False
Case DRIVE_REMOTE:
Err.Raise 1002, "FolderToDriver", "The specified drive is invalid and cannot load the virtual drive!"
FolderToDriver = False
Case Else:
If bUnmount = False Then
FolderToDriver = CBool(DefineDosDevice(0, sDriveLetter, sMountPath))
FolderToDriver = True
End If
End Select
Exit Function
FolderToDriver_Error:
MsgBox Err.Number & vbCrLf & vbCrLf & Err.Description, vbCritical, Err.Source
FolderToDriver = False
Exit Function
End Function
Public Function GetDriveTypeEx(sDriveLetter As String, GetDriveTypeStr As String) As Long
Dim lDriveType As String
sDriveLetter = Trim(sDriveLetter)
If Len(sDriveLetter) <> 1 Then
MsgBox "Specify only the drive letter and do not add anything. For example, if you want to obtain the type of drive C:, simply enter C。", vbInformation, "prompt..."
GetDriveTypeStr = ""
Exit Function
End If
lDriveType = GetDriveType(sDriveLetter & ":\")
GetDriveTypeEx = lDriveType
End Function