سلام
من یک برنامه نوشتم که یک شاخه رو به یک درایو برای دسترسی بهتر تبدیل می کنه
امیدوارم به درد تون بخوره
Virtual_Drive.zip
سلام
من یک برنامه نوشتم که یک شاخه رو به یک درایو برای دسترسی بهتر تبدیل می کنه
امیدوارم به درد تون بخوره
Virtual_Drive.zip
میشه سورسش رو هم بزاری ؟
یک پروزه جدید ایجاد کنید و اشیای زیر را روی فرم قرار دهید:
یک لیست باکس با نام lstDrives
سه تا کامندباتن با نام های btnMount و btnUnmount و btnBrowseFolder
یک تکست باکس با نام txtFolderPath
حالا توی فرم کد زیر را وارد کن:
Option Explicit
Private Sub btnBrowseFolder_Click()
Dim sFolderPath As String
sFolderPath = mBrowseForFolder.BrowseForFolder(Me, "Select Folder to Mount ...", ROOTDIR_COMMON_DESKTOP, , , True, False, "Done !")
If Len(Trim(sFolderPath)) > 0 Then
txtFolderPath.Text = sFolderPath
End If
End Sub
Private Sub btnMount_Click()
If Len(Trim(txtFolderPath.Text)) = 0 Then
MsgBox "Please specify a valid Folder Path to mount as Virtual Drive.", vbInformation, "Do it this way please ..."
btnBrowseFolder.SetFocus
Exit Sub
Else
If mMountDrive.MountVD(lstDrives.List(lstDrives.ListI ndex), txtFolderPath.Text) Then
MsgBox txtFolderPath.Text & " has been successfully mounted as " & lstDrives.List(lstDrives.ListIndex) & " Drive on this machine !" & vbCrLf & vbCrLf & "However, it's worth to note that, this is temporary and will get vanished on next System Shut-Down or Restart. The only work-around for this is ... simply add your tool to system start-up and then it will create your Virtual Drive on every System-boot. Of course, you need to save the settings like Drive Letter and Folder Path to somewhere in Registry so that same Virtual Mount will be created.", vbInformation, "Done ! What's Next ?"
Else
MsgBox "There was an Error while mounting " & txtFolderPath.Text & " as " & lstDrives.List(lstDrives.ListIndex) & " Drive on this machine. This may be due to the insufficient previlege to perform this action (if you are on Network PC) or the required API is not supported by your OS Version (very rare case though !)", vbInformation, "Oops ! Error ... Operation failed."
End If
End If
End Sub
Private Sub btnUnmount_Click()
If Len(Trim(txtFolderPath.Text)) = 0 Then
MsgBox "Please specify a valid Folder Path to mount as Virtual Drive.", vbInformation, "Do it this way please ..."
btnBrowseFolder.SetFocus
Exit Sub
Else
If mMountDrive.MountVD(lstDrives.List(lstDrives.ListI ndex), txtFolderPath.Text, True) Then
MsgBox txtFolderPath.Text & " has been successfully Unmounted.", vbInformation, "Done ! What's Next ?"
Else
MsgBox "There was an Error while mounting " & txtFolderPath.Text & " as " & lstDrives.List(lstDrives.ListIndex) & " Drive on this machine. This may be due to the insufficient previlege to perform this action (if you are on Network PC) or the required API is not supported by your OS Version (very rare case though !)", vbInformation, "Oops ! Error ... Operation failed."
End If
End If
End Sub
Private Sub Form_Load()
Dim iCnt As Integer
For iCnt = 65 To 90
lstDrives.AddItem Chr(iCnt)
Next iCnt
mMountDrive.SetAlwaysOnTopMode Me.hWnd, True
End Sub
Private Sub lstDrives_Click()
Dim sDriveType As String
Dim lDriveType As Long
lDriveType = mMountDrive.GetDriveTypeEx(lstDrives.List(lstDrive s.ListIndex), sDriveType)
If sDriveType = "Unknown" Then
btnMount.Enabled = True
btnUnmount.Enabled = True
btnBrowseFolder.Enabled = True
txtFolderPath.Enabled = True
Else
btnMount.Enabled = False
btnBrowseFolder.Enabled = False
txtFolderPath.Enabled = False
End If
End Sub
یک ماژول به اسم mBrowseForFolder بساز و کد زیر را داخلش بریز:
Option Explicit
Private Type SH_ITEM_ID
cb As Long
abID As Byte
End Type
Private Type ITEMIDLIST
mkid As SH_ITEM_ID
End Type
Private Type BrowseInfo
hWndOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Public Enum ROOTDIR_ID
ROOTDIR_CUSTOM = -1
ROOTDIR_ALL = &H0
ROOTDIR_MY_COMPUTER = &H11
ROOTDIR_DRIVES = &H11
ROOTDIR_ALL_NETWORK = &H12
ROOTDIR_NETWORK_COMPUTERS = &H3D
ROOTDIR_WORKGROUP = &H3D
ROOTDIR_USER = &H28
ROOTDIR_USER_DESKTOP = &H10
ROOTDIR_USER_MY_DOCUMENTS = &H5
ROOTDIR_USER_START_MENU = &HB
ROOTDIR_USER_START_MENU_PROGRAMS = &H2
ROOTDIR_USER_START_MENU_PROGRAMS_STARTUP = &H7
ROOTDIR_COMMON_DESKTOP = &H19
ROOTDIR_COMMON_DOCUMENTS = &H2E
ROOTDIR_COMMON_START_MENU = &H16
ROOTDIR_COMMON_START_MENU_PROGRAMS = &H17
ROOTDIR_COMMON_START_MENU_PROGRAMS_STARTUP = &H18
ROOTDIR_WINDOWS = &H24
ROOTDIR_SYSTEM = &H25
ROOTDIR_FONTS = &H14
ROOTDIR_PROGRAM_FILES = &H26
ROOTDIR_PROGRAM_FILES_COMMON_FILES = &H2B
End Enum
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128 ' Maintenance string For PSS usage
End Type
Private Const MAX_PATH = 260
Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED = 2
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Private Const BFFM_SETSELECTION = (WM_USER + 102)
Private Const BFFM_SETOKTEXT = (WM_USER + 105)
Private Const BFFM_ENABLEOK = (WM_USER + 101)
Private Const BIF_DEFAULT = &H0
Private Const BIF_RETURNONLYFSDIRS = &H1 ' only local Directory
Private Const BIF_DONTGOBELOWDOMAIN = &H2
Private Const BIF_STATUSTEXT = &H4 ' Not With BIF_NEWDIALOGSTYLE
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_EDITBOX = &H10
Private Const BIF_VALIDATE = &H20 ' use With BIF_EDITBOX or BIF_USENEWUI
Private Const BIF_NEWDIALOGSTYLE = &H40 ' Use OleInitialize before
Private Const BIF_USENEWUI = &H50 ' = (BIF_NEWDIALOGSTYLE + BIF_EDITBOX)
Private Const BIF_BROWSEINCLUDEURLS = &H80
Private Const BIF_UAHINT = &H100 ' use With BIF_NEWDIALOGSTYLE, add Usage Hint if no EditBox
Private Const BIF_NONEWFOLDERBUTTON = &H200
Private Const BIF_NOTRANSLATETARGETS = &H400
Private Const BIF_BROWSEFORCOMPUTER = &H1000
Private Const BIF_BROWSEFORPRINTER = &H2000
Private Const BIF_BROWSEINCLUDEFILES = &H4000
Private Const BIF_SHAREABLE = &H8000 ' use With BIF_NEWDIALOGSTYLE
Private Declare Function SHSimpleIDListFromPath Lib "shell32.dll" Alias "#162" (ByVal szPath As String) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" (lpbi As BrowseInfo) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hWndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Private Declare Sub OleInitialize Lib "ole32.dll" (pvReserved As Any)
Private Declare Function PathIsDirectory Lib "shlwapi.dll" Alias "PathIsDirectoryA" (ByVal pszPath As String) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function SendMessage2 Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32.dll" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private m_CurrentDirectory As String
Private OK_BUTTON_TEXT As String
Private Function isNT2000XP() As Boolean
Dim lpv As OSVERSIONINFO
lpv.dwOSVersionInfoSize = Len(lpv)
GetVersionEx lpv
If lpv.dwPlatformId = 2 Then
isNT2000XP = True
Else
isNT2000XP = False
End If
End Function
Private Function isME2KXP() As Boolean
Dim lpv As OSVERSIONINFO
lpv.dwOSVersionInfoSize = Len(lpv)
GetVersionEx lpv
If ((lpv.dwPlatformId = 2) And (lpv.dwMajorVersion >= 5)) Or _
((lpv.dwPlatformId = 1) And (lpv.dwMajorVersion >= 4) And (lpv.dwMinorVersion >= 90)) Then
isME2KXP = True
Else
isME2KXP = False
End If
End Function
Private Function GetPIDLFromPath(sPath As String) As Long
If isNT2000XP Then
GetPIDLFromPath = SHSimpleIDListFromPath(StrConv(sPath, vbUnicode))
Else
GetPIDLFromPath = SHSimpleIDListFromPath(sPath)
End If
End Function
Private Function GetSpecialFolderID(ByVal CSIDL As ROOTDIR_ID) As Long
Dim IDL As ITEMIDLIST, r As Long
r = SHGetSpecialFolderLocation(ByVal 0&, CSIDL, IDL)
If r = 0 Then
GetSpecialFolderID = IDL.mkid.cb
Else
GetSpecialFolderID = 0
End If
End Function
Private Function GetAddressOfFunction(zAdd As Long) As Long
GetAddressOfFunction = zAdd
End Function
Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
On Local Error Resume Next
Dim sBuffer As String
Select Case uMsg
Case BFFM_INITIALIZED
SendMessage hWnd, BFFM_SETSELECTION, 1, m_CurrentDirectory
If OK_BUTTON_TEXT <> vbNullString Then SendMessage2 hWnd, BFFM_SETOKTEXT, 1, StrPtr(OK_BUTTON_TEXT)
Case BFFM_SELCHANGED
sBuffer = Space$(MAX_PATH)
SHGetPathFromIDList lp, sBuffer
sBuffer = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)
If Len(sBuffer) = 0 Then
SendMessage2 hWnd, BFFM_ENABLEOK, 1, 0
SendMessage hWnd, BFFM_SETSTATUSTEXT, 1, ""
Else
SendMessage hWnd, BFFM_SETSTATUSTEXT, 1, sBuffer
End If
End Select
BrowseCallbackProc = 0
End Function
Public Function BrowseForFolder(Optional OwnerForm As Form = Nothing, Optional ByVal Title As String = "", Optional ByVal RootDir As ROOTDIR_ID = ROOTDIR_ALL, Optional ByVal CustomRootDir As String = "", Optional ByVal StartDir As String = "", Optional ByVal NewStyle As Boolean = True, Optional ByVal IncludeFiles As Boolean = False, Optional ByVal OkButtonText As String = "") As String
Dim lpIDList As Long, sBuffer As String, tBrowseInfo As BrowseInfo, clRoot As Boolean
If Len(OkButtonText) > 0 Then
OK_BUTTON_TEXT = OkButtonText
Else
OK_BUTTON_TEXT = vbNullString
End If
clRoot = False
If RootDir = ROOTDIR_CUSTOM Then
If Len(CustomRootDir) > 0 Then
If (PathIsDirectory(CustomRootDir) And (Left$(CustomRootDir, 2) <> "\\")) Or (Left$(CustomRootDir, 2) = "\\") Then
tBrowseInfo.pidlRoot = GetPIDLFromPath(CustomRootDir)
clRoot = True
Else
tBrowseInfo.pidlRoot = GetSpecialFolderID(ROOTDIR_MY_COMPUTER)
End If
Else
tBrowseInfo.pidlRoot = GetSpecialFolderID(ROOTDIR_ALL)
End If
Else
tBrowseInfo.pidlRoot = GetSpecialFolderID(RootDir)
End If
If (Len(StartDir) > 0) Then
m_CurrentDirectory = StartDir & vbNullChar
Else
m_CurrentDirectory = vbNullChar
End If
If Len(Title) > 0 Then
tBrowseInfo.lpszTitle = Title
Else
tBrowseInfo.lpszTitle = "Select A Directory"
End If
tBrowseInfo.lpfnCallback = GetAddressOfFunction(AddressOf BrowseCallbackProc)
tBrowseInfo.ulFlags = BIF_RETURNONLYFSDIRS
If IncludeFiles Then tBrowseInfo.ulFlags = tBrowseInfo.ulFlags + BIF_BROWSEINCLUDEFILES
If NewStyle And isME2KXP Then
tBrowseInfo.ulFlags = tBrowseInfo.ulFlags + BIF_NEWDIALOGSTYLE + BIF_UAHINT
OleInitialize Null ' Initialize OLE and COM
Else
tBrowseInfo.ulFlags = tBrowseInfo.ulFlags + BIF_STATUSTEXT
End If
If Not (OwnerForm Is Nothing) Then tBrowseInfo.hWndOwner = OwnerForm.hWnd
lpIDList = SHBrowseForFolder(tBrowseInfo)
If clRoot = True Then CoTaskMemFree tBrowseInfo.pidlRoot
If (lpIDList) Then
sBuffer = Space$(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
CoTaskMemFree lpIDList
sBuffer = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)
BrowseForFolder = sBuffer
Else
BrowseForFolder = ""
End If
End Function
و یک ماژول با نام mMountDrive ساخته و کد زیر را داخلش بنویس:
Option Explicit
Private Declare Function DefineDosDevice Lib "kernel32" Alias "DefineDosDeviceA" (ByVal dwFlags As Long, ByVal lpDeviceName As String, Optional ByVal lpTargetPath As String = vbNullString) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Sub SetWindowPos Lib "User32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
Private Const DDD_REMOVE_DEFINITION As Long = &H2
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
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_SHOWWINDOW = &H40
Public Function SetAlwaysOnTopMode(ByVal H_Wnd As Long, Optional ByVal OnTop As Boolean = True)
SetWindowPos H_Wnd, IIf(OnTop, HWND_TOPMOST, HWND_NOTOPMOST), 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_SHOWWINDOW
End Function
Public Function IsFolder(ByVal sPath As String) As Boolean
If Dir(sPath, vbHidden Or vbNormal Or vbReadOnly Or vbSystem) <> "" Then
IsFolder = False
Else
IsFolder = True
End If
End Function
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, "Error !"
Exit Function
End Function
Public Function MountVD(ByVal sDriveLetter As String, ByVal sMountPath As String, Optional ByVal bUnmount As Boolean = False) As Boolean
On Error GoTo MountVD_Error
Dim lDriveType As Long
sDriveLetter = Trim(sDriveLetter)
If Len(sDriveLetter) <> 1 Then
Err.Raise 1002, "MountVD", "Specified Drive Letter is wrong."
MountVD = False
End If
If FolderExists(sMountPath) = False Then
Err.Raise 1001, "MountVD", "Specified mount path is wrong or does not point to a valid Windows Folder item."
MountVD = False
End If
sDriveLetter = sDriveLetter & ":"
lDriveType = GetDriveType(sDriveLetter & "\")
Select Case lDriveType
Case DRIVE_CDROM
Err.Raise 1002, "MountVD", "Specified Drive letter is not available to mount virtual drive."
MountVD = False
Case DRIVE_FIXED
If bUnmount = False Then
Err.Raise 1002, "MountVD", "Specified Drive letter is not available to mount virtual drive."
MountVD = False
Else
MountVD = CBool(DefineDosDevice(DDD_REMOVE_DEFINITION, sDriveLetter, sMountPath))
MountVD = True
End If
Case DRIVE_RAMDISK
Err.Raise 1002, "MountVD", "Specified Drive letter is not available to mount virtual drive."
MountVD = False
Case DRIVE_REMOVABLE
Err.Raise 1002, "MountVD", "Specified Drive letter is not available to mount virtual drive."
MountVD = False
Case DRIVE_REMOTE:
Err.Raise 1002, "MountVD", "Specified Drive letter is not available to mount virtual drive."
MountVD = False
Case Else:
If bUnmount = False Then
MountVD = CBool(DefineDosDevice(0, sDriveLetter, sMountPath))
MountVD = True
End If
End Select
Exit Function
MountVD_Error:
MsgBox Err.Number & vbCrLf & vbCrLf & Err.Description, vbCritical, Err.Source
MountVD = 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 Drive letter and nothing else. For example, if you want to get the Drive Type for C Drive then pass only character C to this function.", vbInformation, "Do it in this way please ..."
GetDriveTypeStr = ""
Exit Function
End If
lDriveType = GetDriveType(sDriveLetter & ":\")
Select Case lDriveType
Case 2: GetDriveTypeStr = "Removable"
Case 3: GetDriveTypeStr = "Fixed"
Case 4: GetDriveTypeStr = "Remote"
Case 5: GetDriveTypeStr = "CD-Rom"
Case 6: GetDriveTypeStr = "RAM-Drive"
Case Else: GetDriveTypeStr = "Unknown"
End Select
GetDriveTypeEx = lDriveType
End Function
برنامه را اجرا کرده و حالشو ببرید.
از نام دکمه ها معلومه چه کاری انجام میدن.
یک پروزه جدید ایجاد کنید و اشیای زیر را روی فرم قرار دهید:
یک لیست باکس با نام lstDrives
سه تا کامندباتن با نام های btnMount و btnUnmount و btnBrowseFolder
یک تکست باکس با نام txtFolderPath
حالا توی فرم کد زیر را وارد کن:
Option Explicit
Private Sub btnBrowseFolder_Click()
Dim sFolderPath As String
sFolderPath = mBrowseForFolder.BrowseForFolder(Me, "Select Folder to Mount ...", ROOTDIR_COMMON_DESKTOP, , , True, False, "Done !")
If Len(Trim(sFolderPath)) > 0 Then
txtFolderPath.Text = sFolderPath
End If
End Sub
Private Sub btnMount_Click()
If Len(Trim(txtFolderPath.Text)) = 0 Then
MsgBox "Please specify a valid Folder Path to mount as Virtual Drive.", vbInformation, "Do it this way please ..."
btnBrowseFolder.SetFocus
Exit Sub
Else
If mMountDrive.MountVD(lstDrives.List(lstDrives.ListI ndex), txtFolderPath.Text) Then
MsgBox txtFolderPath.Text & " has been successfully mounted as " & lstDrives.List(lstDrives.ListIndex) & " Drive on this machine !" & vbCrLf & vbCrLf & "However, it's worth to note that, this is temporary and will get vanished on next System Shut-Down or Restart. The only work-around for this is ... simply add your tool to system start-up and then it will create your Virtual Drive on every System-boot. Of course, you need to save the settings like Drive Letter and Folder Path to somewhere in Registry so that same Virtual Mount will be created.", vbInformation, "Done ! What's Next ?"
Else
MsgBox "There was an Error while mounting " & txtFolderPath.Text & " as " & lstDrives.List(lstDrives.ListIndex) & " Drive on this machine. This may be due to the insufficient previlege to perform this action (if you are on Network PC) or the required API is not supported by your OS Version (very rare case though !)", vbInformation, "Oops ! Error ... Operation failed."
End If
End If
End Sub
Private Sub btnUnmount_Click()
If Len(Trim(txtFolderPath.Text)) = 0 Then
MsgBox "Please specify a valid Folder Path to mount as Virtual Drive.", vbInformation, "Do it this way please ..."
btnBrowseFolder.SetFocus
Exit Sub
Else
If mMountDrive.MountVD(lstDrives.List(lstDrives.ListI ndex), txtFolderPath.Text, True) Then
MsgBox txtFolderPath.Text & " has been successfully Unmounted.", vbInformation, "Done ! What's Next ?"
Else
MsgBox "There was an Error while mounting " & txtFolderPath.Text & " as " & lstDrives.List(lstDrives.ListIndex) & " Drive on this machine. This may be due to the insufficient previlege to perform this action (if you are on Network PC) or the required API is not supported by your OS Version (very rare case though !)", vbInformation, "Oops ! Error ... Operation failed."
End If
End If
End Sub
Private Sub Form_Load()
Dim iCnt As Integer
For iCnt = 65 To 90
lstDrives.AddItem Chr(iCnt)
Next iCnt
mMountDrive.SetAlwaysOnTopMode Me.hWnd, True
End Sub
Private Sub lstDrives_Click()
Dim sDriveType As String
Dim lDriveType As Long
lDriveType = mMountDrive.GetDriveTypeEx(lstDrives.List(lstDrive s.ListIndex), sDriveType)
If sDriveType = "Unknown" Then
btnMount.Enabled = True
btnUnmount.Enabled = True
btnBrowseFolder.Enabled = True
txtFolderPath.Enabled = True
Else
btnMount.Enabled = False
btnBrowseFolder.Enabled = False
txtFolderPath.Enabled = False
End If
End Sub
یک ماژول به اسم mBrowseForFolder بساز و کد زیر را داخلش بریز:
Option Explicit
Private Type SH_ITEM_ID
cb As Long
abID As Byte
End Type
Private Type ITEMIDLIST
mkid As SH_ITEM_ID
End Type
Private Type BrowseInfo
hWndOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Public Enum ROOTDIR_ID
ROOTDIR_CUSTOM = -1
ROOTDIR_ALL = &H0
ROOTDIR_MY_COMPUTER = &H11
ROOTDIR_DRIVES = &H11
ROOTDIR_ALL_NETWORK = &H12
ROOTDIR_NETWORK_COMPUTERS = &H3D
ROOTDIR_WORKGROUP = &H3D
ROOTDIR_USER = &H28
ROOTDIR_USER_DESKTOP = &H10
ROOTDIR_USER_MY_DOCUMENTS = &H5
ROOTDIR_USER_START_MENU = &HB
ROOTDIR_USER_START_MENU_PROGRAMS = &H2
ROOTDIR_USER_START_MENU_PROGRAMS_STARTUP = &H7
ROOTDIR_COMMON_DESKTOP = &H19
ROOTDIR_COMMON_DOCUMENTS = &H2E
ROOTDIR_COMMON_START_MENU = &H16
ROOTDIR_COMMON_START_MENU_PROGRAMS = &H17
ROOTDIR_COMMON_START_MENU_PROGRAMS_STARTUP = &H18
ROOTDIR_WINDOWS = &H24
ROOTDIR_SYSTEM = &H25
ROOTDIR_FONTS = &H14
ROOTDIR_PROGRAM_FILES = &H26
ROOTDIR_PROGRAM_FILES_COMMON_FILES = &H2B
End Enum
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128 ' Maintenance string For PSS usage
End Type
Private Const MAX_PATH = 260
Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED = 2
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Private Const BFFM_SETSELECTION = (WM_USER + 102)
Private Const BFFM_SETOKTEXT = (WM_USER + 105)
Private Const BFFM_ENABLEOK = (WM_USER + 101)
Private Const BIF_DEFAULT = &H0
Private Const BIF_RETURNONLYFSDIRS = &H1 ' only local Directory
Private Const BIF_DONTGOBELOWDOMAIN = &H2
Private Const BIF_STATUSTEXT = &H4 ' Not With BIF_NEWDIALOGSTYLE
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_EDITBOX = &H10
Private Const BIF_VALIDATE = &H20 ' use With BIF_EDITBOX or BIF_USENEWUI
Private Const BIF_NEWDIALOGSTYLE = &H40 ' Use OleInitialize before
Private Const BIF_USENEWUI = &H50 ' = (BIF_NEWDIALOGSTYLE + BIF_EDITBOX)
Private Const BIF_BROWSEINCLUDEURLS = &H80
Private Const BIF_UAHINT = &H100 ' use With BIF_NEWDIALOGSTYLE, add Usage Hint if no EditBox
Private Const BIF_NONEWFOLDERBUTTON = &H200
Private Const BIF_NOTRANSLATETARGETS = &H400
Private Const BIF_BROWSEFORCOMPUTER = &H1000
Private Const BIF_BROWSEFORPRINTER = &H2000
Private Const BIF_BROWSEINCLUDEFILES = &H4000
Private Const BIF_SHAREABLE = &H8000 ' use With BIF_NEWDIALOGSTYLE
Private Declare Function SHSimpleIDListFromPath Lib "shell32.dll" Alias "#162" (ByVal szPath As String) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" (lpbi As BrowseInfo) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hWndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Private Declare Sub OleInitialize Lib "ole32.dll" (pvReserved As Any)
Private Declare Function PathIsDirectory Lib "shlwapi.dll" Alias "PathIsDirectoryA" (ByVal pszPath As String) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function SendMessage2 Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32.dll" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private m_CurrentDirectory As String
Private OK_BUTTON_TEXT As String
Private Function isNT2000XP() As Boolean
Dim lpv As OSVERSIONINFO
lpv.dwOSVersionInfoSize = Len(lpv)
GetVersionEx lpv
If lpv.dwPlatformId = 2 Then
isNT2000XP = True
Else
isNT2000XP = False
End If
End Function
Private Function isME2KXP() As Boolean
Dim lpv As OSVERSIONINFO
lpv.dwOSVersionInfoSize = Len(lpv)
GetVersionEx lpv
If ((lpv.dwPlatformId = 2) And (lpv.dwMajorVersion >= 5)) Or _
((lpv.dwPlatformId = 1) And (lpv.dwMajorVersion >= 4) And (lpv.dwMinorVersion >= 90)) Then
isME2KXP = True
Else
isME2KXP = False
End If
End Function
Private Function GetPIDLFromPath(sPath As String) As Long
If isNT2000XP Then
GetPIDLFromPath = SHSimpleIDListFromPath(StrConv(sPath, vbUnicode))
Else
GetPIDLFromPath = SHSimpleIDListFromPath(sPath)
End If
End Function
Private Function GetSpecialFolderID(ByVal CSIDL As ROOTDIR_ID) As Long
Dim IDL As ITEMIDLIST, r As Long
r = SHGetSpecialFolderLocation(ByVal 0&, CSIDL, IDL)
If r = 0 Then
GetSpecialFolderID = IDL.mkid.cb
Else
GetSpecialFolderID = 0
End If
End Function
Private Function GetAddressOfFunction(zAdd As Long) As Long
GetAddressOfFunction = zAdd
End Function
Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
On Local Error Resume Next
Dim sBuffer As String
Select Case uMsg
Case BFFM_INITIALIZED
SendMessage hWnd, BFFM_SETSELECTION, 1, m_CurrentDirectory
If OK_BUTTON_TEXT <> vbNullString Then SendMessage2 hWnd, BFFM_SETOKTEXT, 1, StrPtr(OK_BUTTON_TEXT)
Case BFFM_SELCHANGED
sBuffer = Space$(MAX_PATH)
SHGetPathFromIDList lp, sBuffer
sBuffer = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)
If Len(sBuffer) = 0 Then
SendMessage2 hWnd, BFFM_ENABLEOK, 1, 0
SendMessage hWnd, BFFM_SETSTATUSTEXT, 1, ""
Else
SendMessage hWnd, BFFM_SETSTATUSTEXT, 1, sBuffer
End If
End Select
BrowseCallbackProc = 0
End Function
Public Function BrowseForFolder(Optional OwnerForm As Form = Nothing, Optional ByVal Title As String = "", Optional ByVal RootDir As ROOTDIR_ID = ROOTDIR_ALL, Optional ByVal CustomRootDir As String = "", Optional ByVal StartDir As String = "", Optional ByVal NewStyle As Boolean = True, Optional ByVal IncludeFiles As Boolean = False, Optional ByVal OkButtonText As String = "") As String
Dim lpIDList As Long, sBuffer As String, tBrowseInfo As BrowseInfo, clRoot As Boolean
If Len(OkButtonText) > 0 Then
OK_BUTTON_TEXT = OkButtonText
Else
OK_BUTTON_TEXT = vbNullString
End If
clRoot = False
If RootDir = ROOTDIR_CUSTOM Then
If Len(CustomRootDir) > 0 Then
If (PathIsDirectory(CustomRootDir) And (Left$(CustomRootDir, 2) <> "\\")) Or (Left$(CustomRootDir, 2) = "\\") Then
tBrowseInfo.pidlRoot = GetPIDLFromPath(CustomRootDir)
clRoot = True
Else
tBrowseInfo.pidlRoot = GetSpecialFolderID(ROOTDIR_MY_COMPUTER)
End If
Else
tBrowseInfo.pidlRoot = GetSpecialFolderID(ROOTDIR_ALL)
End If
Else
tBrowseInfo.pidlRoot = GetSpecialFolderID(RootDir)
End If
If (Len(StartDir) > 0) Then
m_CurrentDirectory = StartDir & vbNullChar
Else
m_CurrentDirectory = vbNullChar
End If
If Len(Title) > 0 Then
tBrowseInfo.lpszTitle = Title
Else
tBrowseInfo.lpszTitle = "Select A Directory"
End If
tBrowseInfo.lpfnCallback = GetAddressOfFunction(AddressOf BrowseCallbackProc)
tBrowseInfo.ulFlags = BIF_RETURNONLYFSDIRS
If IncludeFiles Then tBrowseInfo.ulFlags = tBrowseInfo.ulFlags + BIF_BROWSEINCLUDEFILES
If NewStyle And isME2KXP Then
tBrowseInfo.ulFlags = tBrowseInfo.ulFlags + BIF_NEWDIALOGSTYLE + BIF_UAHINT
OleInitialize Null ' Initialize OLE and COM
Else
tBrowseInfo.ulFlags = tBrowseInfo.ulFlags + BIF_STATUSTEXT
End If
If Not (OwnerForm Is Nothing) Then tBrowseInfo.hWndOwner = OwnerForm.hWnd
lpIDList = SHBrowseForFolder(tBrowseInfo)
If clRoot = True Then CoTaskMemFree tBrowseInfo.pidlRoot
If (lpIDList) Then
sBuffer = Space$(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
CoTaskMemFree lpIDList
sBuffer = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)
BrowseForFolder = sBuffer
Else
BrowseForFolder = ""
End If
End Function
و یک ماژول با نام mMountDrive ساخته و کد زیر را داخلش بنویس:
Option Explicit
Private Declare Function DefineDosDevice Lib "kernel32" Alias "DefineDosDeviceA" (ByVal dwFlags As Long, ByVal lpDeviceName As String, Optional ByVal lpTargetPath As String = vbNullString) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Sub SetWindowPos Lib "User32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
Private Const DDD_REMOVE_DEFINITION As Long = &H2
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
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_SHOWWINDOW = &H40
Public Function SetAlwaysOnTopMode(ByVal H_Wnd As Long, Optional ByVal OnTop As Boolean = True)
SetWindowPos H_Wnd, IIf(OnTop, HWND_TOPMOST, HWND_NOTOPMOST), 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_SHOWWINDOW
End Function
Public Function IsFolder(ByVal sPath As String) As Boolean
If Dir(sPath, vbHidden Or vbNormal Or vbReadOnly Or vbSystem) <> "" Then
IsFolder = False
Else
IsFolder = True
End If
End Function
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, "Error !"
Exit Function
End Function
Public Function MountVD(ByVal sDriveLetter As String, ByVal sMountPath As String, Optional ByVal bUnmount As Boolean = False) As Boolean
On Error GoTo MountVD_Error
Dim lDriveType As Long
sDriveLetter = Trim(sDriveLetter)
If Len(sDriveLetter) <> 1 Then
Err.Raise 1002, "MountVD", "Specified Drive Letter is wrong."
MountVD = False
End If
If FolderExists(sMountPath) = False Then
Err.Raise 1001, "MountVD", "Specified mount path is wrong or does not point to a valid Windows Folder item."
MountVD = False
End If
sDriveLetter = sDriveLetter & ":"
lDriveType = GetDriveType(sDriveLetter & "\")
Select Case lDriveType
Case DRIVE_CDROM
Err.Raise 1002, "MountVD", "Specified Drive letter is not available to mount virtual drive."
MountVD = False
Case DRIVE_FIXED
If bUnmount = False Then
Err.Raise 1002, "MountVD", "Specified Drive letter is not available to mount virtual drive."
MountVD = False
Else
MountVD = CBool(DefineDosDevice(DDD_REMOVE_DEFINITION, sDriveLetter, sMountPath))
MountVD = True
End If
Case DRIVE_RAMDISK
Err.Raise 1002, "MountVD", "Specified Drive letter is not available to mount virtual drive."
MountVD = False
Case DRIVE_REMOVABLE
Err.Raise 1002, "MountVD", "Specified Drive letter is not available to mount virtual drive."
MountVD = False
Case DRIVE_REMOTE:
Err.Raise 1002, "MountVD", "Specified Drive letter is not available to mount virtual drive."
MountVD = False
Case Else:
If bUnmount = False Then
MountVD = CBool(DefineDosDevice(0, sDriveLetter, sMountPath))
MountVD = True
End If
End Select
Exit Function
MountVD_Error:
MsgBox Err.Number & vbCrLf & vbCrLf & Err.Description, vbCritical, Err.Source
MountVD = 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 Drive letter and nothing else. For example, if you want to get the Drive Type for C Drive then pass only character C to this function.", vbInformation, "Do it in this way please ..."
GetDriveTypeStr = ""
Exit Function
End If
lDriveType = GetDriveType(sDriveLetter & ":\")
Select Case lDriveType
Case 2: GetDriveTypeStr = "Removable"
Case 3: GetDriveTypeStr = "Fixed"
Case 4: GetDriveTypeStr = "Remote"
Case 5: GetDriveTypeStr = "CD-Rom"
Case 6: GetDriveTypeStr = "RAM-Drive"
Case Else: GetDriveTypeStr = "Unknown"
End Select
GetDriveTypeEx = lDriveType
End Function
برنامه را اجرا کرده و حالشو ببرید.
از نام دکمه ها معلومه چه کاری انجام میدن.
قوانین ایجاد تاپیک در تالار
پاسخ با نقل قول