[VB6, twinBASIC] ucDriveCombo - A modern DriveList replacement

[fafalone]

Project Updated - Version 1.4

' Changelog:
'  Version 1.4 (Released 25 Apr 2024)
'   -The .Drive legacy method now returns the same path for
'    mapped network drives.
'   -There's now a drive icon and control name/version in the
'    combobox during design mode instead of a generic combo.

Download from GitHub

---

I went with just Ambient.DisplayName for the IDE (with icon); so it will say e.g. "ucDriveCombo1"

So for network paths, I stuck pretty closely to the proposed version earlier for WNetGetUniversalNameW; I don't know why it wasn't working. I put a mapped drive on a VM, and confirmed it's working now.

Here's what I wound up doing:

Private Sub SetOldName(sPath As String, sLetter As String, nIdx As Long)
    Dim sTmp As String
    Dim sOld As String
    Dim dwFlag As Long
    sOld = LCase$(sLetter) & ":"
    If PathIsNetworkPathW(StrPtr(sPath)) Then
        sOld = GetOldNetName(sOld)
    Else
        sTmp = String$(34, 0)
        If GetVolumeInformationW(StrPtr(sPath), StrPtr(sTmp), 34, ByVal 0, 0, dwFlag, 0, 0) Then
            If InStr(sTmp, vbNullChar) > 1 Then
                sTmp = Left$(sTmp, InStr(sTmp, vbNullChar) - 1)
                sOld = sOld & " [" & sTmp & "]"
            End If
        End If
    End If
    mDrives(nIdx).NameOld = sOld
End Sub
Private Function GetOldNetName(ByVal sLetter As String) As String
    Dim tn As UNIVERSAL_NAME_INFOW
    Dim lRet As Long
    Dim bt() As Byte
    Dim cb As Long
    ReDim bt((MAX_PATH * 2 + 1) + LenB(tn))
    cb = UBound(bt) + 1
    lRet = WNetGetUniversalNameW(StrPtr(sLetter), UNIVERSAL_NAME_INFO_LEVEL, bt(0), cb)
    If lRet = S_OK Then
        CopyMemory tn, bt(0), LenB(tn)
        Dim sPath As String
        Dim cch As Long
        cch = lstrlenW(ByVal tn.lpUniversalName)
        If cch = 0 Then
            GetOldNetName = sLetter
            Exit Function
        End If
        sPath = String$(cch, 0)
        CopyMemory ByVal StrPtr(sPath), ByVal tn.lpUniversalName, cch * 2
        GetOldNetName = sLetter & " [" & sPath & "]"
        Exit Function
    Else
        Debug.Print "GetOldNetName->Error: " & lRet
    End If
    GetOldNetName = sLetter
End Function

If something isn't right let me know.

[cliv]

I want to convert mDrives(mCt).nIcon to StdPicture in RefreshDriveList sub using OleCreatePictureIndirect.

Private Declare Function OleCreatePictureIndirect Lib "OLEPRO32.DLL" (lpPictDesc As PICTDESC, riid As Any, ByVal fPictureOwnsHandle As Long, ppRet As IPicture) As Long
Private Type PICTDESC
    Size                As Long
    Type                As Long
    hBmpOrIcon          As Long
    hPal                As Long
End Type
...
Public Sub RefreshDriveList()
	Dim diskIcon As StdPicture
	Dim dPict As PICTDESC
	dPict.Size = Len(dPict)
	dPict.Type = vbPicTypeIcon
	
	...
		mDrives(mCt).Name = sName
		mDrives(mCt).nIcon = GetIconIndex(sDrives(i), SHGFI_SMALLICON)
		
              diskIcon = 
		
	...
End sub

...can someone help me?

[VanGoghGaming]

It looks like you get a handle to the icon in the "sfi.hIcon" structure from that "GetIconIndex" function. Put that into the PICTDESC structure and you should be good to go.

[fafalone]

You also have to add the SHGFI_ICON flag for .hIcon to be set.

[cliv]

Put that into the PICTDESC

You also have to add the SHGFI_ICON flag for .hIcon to be set.

i try ..

Public Sub RefreshDriveList()
        IID_IPicture = &H7BF80980

	Dim diskIcon As StdPicture
	Dim dPict As PICTDESC
	dPict.Size = Len(dPict)
	dPict.Type = vbPicTypeIcon
	
	...
		mDrives(mCt).Name = sName
		mDrives(mCt).nIcon = GetIconIndex(sDrives(i), SHGFI_SMALLICON)
		
              dPict .hBmpOrIcon = mDrives(mCt).nIcon
              Call OleCreatePictureIndirect(dPict, IID_IPicture  , True, diskIcon)
              
             Picture1.Picture = diskIcon
	...
End sub

... but not work

[VanGoghGaming]

There is a pointer to IUnknown IID:

Private Type tIID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Const IID_IUnknown As String = "{00000000-0000-0000-C000-000000000046}"
Private Declare Function IIDFromString Lib "ole32" (ByVal lpString As Long, rIID As Any) As Long

Dim tIID As tIID

IIDFromString StrPtr(IID_IUnknown), tIID ' Put this tIID in the call to OleCreatePictureIndirect

[VanGoghGaming]

IID_IPicture also works only you've got it wrong, it's not a Long constant as you defined it, it's a pointer to a 16-bytes structure like in the example above.

i try ..

              dPict .hBmpOrIcon = mDrives(mCt).nIcon

... but not work

This is also wrong, you need the hIcon not the nIcon, both reported by the "SHGetFileInfoW" function in the "sfi" structure. I'm sure Fafalone will provide the complete code if you don't manage by then.

[cliv]

...
GetIconIndex = sfi.hIcon
...

I can't make it work...

[VanGoghGaming]

Yes, like that, but only if you got the correct hIcon into "dPict"!

[cliv]

Yes, like that, but only if you got the correct hIcon into "dPict"!

thanks! work i fogot to change SHGFI_SMALLICON into SHGFI_ICON

[AAraya]

Project Updated - Version 1.4

So for network paths, I stuck pretty closely to the proposed version earlier for WNetGetUniversalNameW; I don't know why it wasn't working. I put a mapped drive on a VM, and confirmed it's working now.

Here's what I wound up doing:

Private Sub SetOldName(sPath As String, sLetter As String, nIdx As Long)
    Dim sTmp As String
    Dim sOld As String
    Dim dwFlag As Long
    sOld = LCase$(sLetter) & ":"
    If PathIsNetworkPathW(StrPtr(sPath)) Then
        sOld = GetOldNetName(sOld)
    Else
        sTmp = String$(34, 0)
        If GetVolumeInformationW(StrPtr(sPath), StrPtr(sTmp), 34, ByVal 0, 0, dwFlag, 0, 0) Then
            If InStr(sTmp, vbNullChar) > 1 Then
                sTmp = Left$(sTmp, InStr(sTmp, vbNullChar) - 1)
                sOld = sOld & " [" & sTmp & "]"
            End If
        End If
    End If
    mDrives(nIdx).NameOld = sOld
End Sub
Private Function GetOldNetName(ByVal sLetter As String) As String
    Dim tn As UNIVERSAL_NAME_INFOW
    Dim lRet As Long
    Dim bt() As Byte
    Dim cb As Long
    ReDim bt((MAX_PATH * 2 + 1) + LenB(tn))
    cb = UBound(bt) + 1
    lRet = WNetGetUniversalNameW(StrPtr(sLetter), UNIVERSAL_NAME_INFO_LEVEL, bt(0), cb)
    If lRet = S_OK Then
        CopyMemory tn, bt(0), LenB(tn)
        Dim sPath As String
        Dim cch As Long
        cch = lstrlenW(ByVal tn.lpUniversalName)
        If cch = 0 Then
            GetOldNetName = sLetter
            Exit Function
        End If
        sPath = String$(cch, 0)
        CopyMemory ByVal StrPtr(sPath), ByVal tn.lpUniversalName, cch * 2
        GetOldNetName = sLetter & " [" & sPath & "]"
        Exit Function
    Else
        Debug.Print "GetOldNetName->Error: " & lRet
    End If
    GetOldNetName = sLetter
End Function

If something isn't right let me know.

WNetGetUniversalNameW is working now. Great job. A couple of slight differences between ucDriveCombo.Drive value and VB6.DriveListBox for network shares are:

1. Yours includes a trailing backslash after the Share where VB's does not.
2. Drive letter is lower case in VB6 but in yours it's upper case

[fafalone]

2 is certainly weird...

    sOld = LCase$(sLetter) & ":"
    If PathIsNetworkPathW(StrPtr(sPath)) Then
        sOld = GetOldNetName(sOld)

Private Function GetOldNetName(ByVal sLetter As String) As String

(...)

GetOldNetName = sLetter & " [" & sPath & "]"

So how is it getting back to uppercase??

I can't reproduce on my test machine; it's coming out lowercase for me. I guess try forcing it again by changing that final line to GetOldNetName = LCase$(sLetter) & " [" & sPath & "]". If *that* doesn't work, LCase is broken on your computer lol

In the next update I'll do that just to be sure, and remove the backslash:

GetOldNetName = LCase$(sLetter) & " [" & RemoveBackslash(sPath) & "]"

...

Private Function RemoveBackslash(sPath As String) As String
    If (Len(sPath) > 1) Then
        If Right$(sPath, 1) = "\" Then
            RemoveBackslash = Left$(sPath, Len(sPath) - 1)
            Exit Function
        End If
    End If
    RemoveBackslash = sPath
End Function

[AAraya]

The LCase issue is probably one of my own creation. I copied and pasted your code into my own rather than redownloading from GitHub. I probably messed something up. No worries as I've got it resolved in my version.

[-Franky-]

Hi fafalone
I haven't been able to test your UC yet. But I looked at your code on GitHub and a property may still be missing. I also have 3 hidden network drives in my environment. These are not displayed in Explorer either. But they can be addressed normally via the drive letter. Maybe an additional property (ShowHiddenDrives) in your UC would be useful with which you can show or hide hidden drives in the UC.

[fafalone]

It's not loading them from the shell display; it's loading them from GetLogicalDriveStrings; if it's mapped, it should show up.

Although the issue might be admin/nonadmin. Drives have to be mapped in both or some registry key changed.

Could you give it a try and let me know? Or what you had in mind to list hidden drives?

[-Franky-]

Hi fafalone
What I mean is this: https://www.tenforums.com/tutorials/...s-windows.html
These drives are then not visible in Explorer. That's why an additional feature for your UC might be useful to hide these drives in your UC if you want to.

[AAraya]

fafalone you've got a typo in your latest code on Github. The WS_TABSTOP constant has a random "Q" at the end of the value which causes a compile error.

[fafalone]

In this project? Where? I just checked every file in the repo.

[AAraya]

Well that's weird. I'm not seeing it in GitHub code now either. I downloaded the code and opened it in VB6 and immediately had the issue. Oh well. Sorry for the false alarm.

[fafalone]

No worries, had things like that happen to me too.

@-Franky-, That's an Explorer policy so I'm pretty sure it's not going to impact this project, since I'm not enumerating with IShellFolder or IShellItem. Let me know for sure when you have a chance to check; I've just got too much open right now to log off to apply that key.

[-Franky-]

That's an Explorer policy so I'm pretty sure it's not going to impact this project, since I'm not enumerating with IShellFolder or IShellItem.

That's exactly what I mean. The drive letters hidden via RegKey can be seen in your UC. There are good reasons why you hide drive letters from a user and therefore my suggestion is to allow these drive letters to be displayed in your UC using the ShowHiddenDrives property. The default would be to not allow these drive letters to be displayed in your UC.

[fafalone]

Sorry misunderstood. Yeah I can add that.

[-Franky-]

Sorry misunderstood.

No problem. Maybe I just didn't explain it correctly.

[fafalone]

Project Updated - Version 1.6

I've updated all versions and binaries for the project to v1.6, adding the feature to not show Explorer-hidden drives by default.

Download from GitHub

[-Franky-]

I think you could also check whether the drive letter is hidden using IShellItem::GetAttributes with the mask SFGAO_HIDDEN.

[fafalone]

Probably but then I'd have a complicated dependency system, since it would have to require oleexp.tlb in VB6 and WinDevLib (or local interface defs) in twinBASIC, or much more complicated DispCallFunc calls that are impenetrable to all but the most advanced VB/tB programmers.

Once tB can export type libraries, I'll be able to make a single dependency system like that which covers both 32bit VB6 and 64bit twinBASIC (and 64bit VBA), and oleexp will go into bugfix-only deprecated status, but for now if it's a small project with only one or two easily avoided shell interfaces, makes more sense to do that when I'm writing for VB6 backwards compatibility.