Skip to content

Commit f2801be

Browse files
authored
Updates for v1.4
1 parent db56dae commit f2801be

1 file changed

Lines changed: 77 additions & 8 deletions

File tree

ucDriveCombo.twin

Lines changed: 77 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,7 @@ Class ucDriveCombo
99
Option Explicit
1010

1111
'********************************************************************
12-
' ucDriveCombo v1.3
12+
' ucDriveCombo v1.4
1313
' A Modern DriveList Replacement
1414
' by Jon Johnson
1515
'
@@ -33,6 +33,12 @@ Option Explicit
3333
' -Can optionally classify USB hard drives as removable.
3434
'
3535
' Changelog:
36+
' Version 1.4 (Released 25 Apr 2024)
37+
' -The .Drive legacy method now returns the same path for
38+
' mapped network drives.
39+
' -There's now a drive icon and control name/version in the
40+
' combobox during design mode instead of a generic combo.
41+
'
3642
' Version 1.3 (Released 23 Apr 2024)
3743
' -The .Drive property now returns names identical to the legacy
3844
' DriveList control, and when set, behaves identical to that
@@ -102,7 +108,12 @@ Private Const WC_COMBOBOXEX = "ComboBoxEx32"
102108
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, ByRef lpRect As RECT) As Long
103109
Private Declare PtrSafe Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hWnd As LongPtr) As LongPtr
104110
Private Declare PtrSafe Function GetVolumeInformationW Lib "kernel32" (ByVal lpRootPathName As LongPtr, ByVal lpVolumeNameBuffer As LongPtr, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As LongPtr, ByVal nFileSystemNameSize As Long) As BOOL
105-
#Else
111+
Private Declare PtrSafe Function PathIsNetworkPathW Lib "shlwapi.dll" (ByVal lpszPath As LongPtr) As BOOL
112+
Private Declare PtrSafe Function PathIsUNCW Lib "shlwapi.dll" (ByVal lpszPath As LongPtr) As BOOL
113+
Private Declare PtrSafe Function WNetGetUniversalNameW Lib "mpr.dll" (ByVal lpLocalPath As LongPtr, ByVal dwInfoLevel As NETWK_NAME_INFOLEVEL, lpBuffer As Any, lpBufferSize As Long) As Long
114+
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
115+
Private Declare PtrSafe Function lstrlenW Lib "kernel32" (lpString As Any) As Long
116+
#Else
106117
Private Enum LongPtr
107118
vbNullPtr
108119
End Enum
@@ -136,6 +147,11 @@ Private Const WC_COMBOBOXEX = "ComboBoxEx32"
136147
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, ByRef lpRect As RECT) As Long
137148
Private Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hWnd As LongPtr) As LongPtr
138149
Private Declare Function GetVolumeInformationW Lib "kernel32" (ByVal lpRootPathName As LongPtr, ByVal lpVolumeNameBuffer As LongPtr, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As LongPtr, ByVal nFileSystemNameSize As Long) As BOOL
150+
Private Declare Function PathIsNetworkPathW Lib "shlwapi.dll" (ByVal lpszPath As LongPtr) As BOOL
151+
Private Declare Function PathIsUNCW Lib "shlwapi.dll" (ByVal lpszPath As LongPtr) As BOOL
152+
Private Declare Function WNetGetUniversalNameW Lib "mpr.dll" (ByVal lpLocalPath As LongPtr, ByVal dwInfoLevel As NETWK_NAME_INFOLEVEL, lpBuffer As Any, lpBufferSize As Long) As Long
153+
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
154+
Private Declare Function lstrlenW Lib "kernel32" (lpString As Any) As Long
139155
#End If
140156

141157
Private Type RECT
@@ -159,6 +175,14 @@ Private Const WM_DEVICECHANGE = &H0219
159175
Private Const NFR_UNICODE = 2
160176
Private Const LOGPIXELSY = 90
161177

178+
Private Enum NETWK_NAME_INFOLEVEL
179+
UNIVERSAL_NAME_INFO_LEVEL = &H00000001
180+
REMOTE_NAME_INFO_LEVEL = &H00000002
181+
End Enum
182+
Private Type UNIVERSAL_NAME_INFOW
183+
lpUniversalName As LongPtr
184+
End Type
185+
162186
Private Enum FileShareMode
163187
FILE_SHARE_READ = &H00000001
164188
FILE_SHARE_WRITE = &H00000002
@@ -978,9 +1002,10 @@ Private Function GetSysImageList(uFlags As SHGFI_flags) As LongPtr
9781002
hEdit = SendMessage(hMain, CBEM_GETEDITCONTROL, 0, ByVal 0&)
9791003

9801004
SendMessage hEdit, EM_SETREADONLY, 1&, ByVal 0&
1005+
1006+
Call SendMessage(hMain, CBEM_SETIMAGELIST, 0, ByVal himl)
9811007

9821008
If Ambient.UserMode Then
983-
Call SendMessage(hMain, CBEM_SETIMAGELIST, 0, ByVal himl)
9841009
Subclass2 hMain, AddressOf ucDriveComboWndProc, hMain, ObjPtr(Me)
9851010
RefreshDriveList
9861011
Dim tFilter As DEV_BROADCAST_DEVICEINTERFACE
@@ -992,6 +1017,20 @@ Private Function GetSysImageList(uFlags As SHGFI_flags) As LongPtr
9921017
tFilter.dbcc_devicetype = DBT_DEVTYP_DEVICEINTERFACE
9931018
tFilter.dbcc_classguid = GUID_DEVINTERFACE_VOLUME
9941019
hNotify = RegisterDeviceNotification(hMain, tFilter, DEVICE_NOTIFY_WINDOW_HANDLE)
1020+
Else
1021+
Dim sSys As String
1022+
Dim l As Long
1023+
sSys = String$(MAX_PATH, 0)
1024+
l = GetWindowsDirectoryW(StrPtr(sSys), MAX_PATH)
1025+
If l Then
1026+
sSys = Left$(sSys, IIf(l < 3, l, 3))
1027+
Else
1028+
sSys = Left$(Environ("WINDIR"), 3)
1029+
End If
1030+
Dim nIcon As Long
1031+
nIcon = GetIconIndex(sSys, SHGFI_SMALLICON)
1032+
CBX_InsertItem hMain, Ambient.DisplayName, nIcon
1033+
SendMessage hMain, CB_SETCURSEL, 0, ByVal 0
9951034
End If
9961035

9971036
If mEnabled = False Then
@@ -1135,15 +1174,45 @@ Private Sub SetOldName(sPath As String, sLetter As String, nIdx As Long)
11351174
Dim sOld As String
11361175
Dim dwFlag As Long
11371176
sOld = LCase$(sLetter) & ":"
1138-
sTmp = String$(34, 0)
1139-
If GetVolumeInformationW(StrPtr(sPath), StrPtr(sTmp), 34, ByVal 0, 0, dwFlag, 0, 0) Then
1140-
If InStr(sTmp, vbNullChar) > 1 Then
1141-
sTmp = Left$(sTmp, InStr(sTmp, vbNullChar) - 1)
1142-
sOld = sOld & " [" & sTmp & "]"
1177+
If PathIsNetworkPathW(StrPtr(sPath)) Then
1178+
sOld = GetOldNetName(sOld)
1179+
Else
1180+
sTmp = String$(34, 0)
1181+
If GetVolumeInformationW(StrPtr(sPath), StrPtr(sTmp), 34, ByVal 0, 0, dwFlag, 0, 0) Then
1182+
If InStr(sTmp, vbNullChar) > 1 Then
1183+
sTmp = Left$(sTmp, InStr(sTmp, vbNullChar) - 1)
1184+
sOld = sOld & " [" & sTmp & "]"
1185+
End If
11431186
End If
11441187
End If
11451188
mDrives(nIdx).NameOld = sOld
11461189
End Sub
1190+
Private Function GetOldNetName(ByVal sLetter As String) As String
1191+
Dim tn As UNIVERSAL_NAME_INFOW
1192+
Dim lRet As Long
1193+
Dim bt() As Byte
1194+
Dim cb As Long
1195+
ReDim bt((MAX_PATH * 2 + 1) + LenB(tn))
1196+
cb = UBound(bt) + 1
1197+
lRet = WNetGetUniversalNameW(StrPtr(sLetter), UNIVERSAL_NAME_INFO_LEVEL, bt(0), cb)
1198+
If lRet = S_OK Then
1199+
CopyMemory tn, bt(0), LenB(tn)
1200+
Dim sPath As String
1201+
Dim cch As Long
1202+
cch = lstrlenW(ByVal tn.lpUniversalName)
1203+
If cch = 0 Then
1204+
GetOldNetName = sLetter
1205+
Exit Function
1206+
End If
1207+
sPath = String$(cch, 0)
1208+
CopyMemory ByVal StrPtr(sPath), ByVal tn.lpUniversalName, cch * 2
1209+
GetOldNetName = sLetter & " [" & sPath & "]"
1210+
Exit Function
1211+
Else
1212+
Debug.Print "GetOldNetName->Error: " & lRet
1213+
End If
1214+
GetOldNetName = sLetter
1215+
End Function
11471216
Private Function CBX_InsertItem(ByVal hCBoxEx As LongPtr, sText As String, Optional iImage As Long = -1, Optional iOverlay As Long = -1, Optional lParam As Long = 0, Optional iItem As Long = -1, Optional iIndent As Long = 0, Optional iImageSel As Long = -1) As Long
11481217

11491218
Dim cbxi As COMBOBOXEXITEMW

0 commit comments

Comments
 (0)