VBA shell works om 32 bit office but not 64

[tomtomas]

I have a macro that looks at a user's desktop shortcuts to insure that they are formatted properly for my workbooks. The macro works fine on my three PCs. My PCs are all various versions of 64 bit Win 10. My office programs are all 32 bit. Two have Office 14 and 11, one has 365. A client has 64 bit Office 365 and that's where the problem is. My code (attached in a striped down version) uses Shell32 and "WScript.Shell". Reference to Microsoft Shell Controls and Automation is turned on. Can you suggest code that will allow this to work in both 32 bit and 64 bit office? Thank you

Sub Shortcut()
    
    Dim B As String
    Dim FileLoc(3, 2) As String
    Dim i As Integer
    Dim oShell  As Shell32.Shell
    Dim oFolder As Shell32.Folder
    Dim oWsh As Object
    Dim Rw As Integer
    Cells.ClearContents
    Set oShell = New Shell32.Shell
    Set oWsh = CreateObject("WScript.Shell")
    FileLoc(1, 0) = Environ("USERPROFILE") & "\DESKTOP"
    Set oFolder = oShell.Namespace(FileLoc(1, 0))
    For i = oFolder.Items.Count - 1 To 0 Step -1
        B = UCase(oFolder.Items.Item(i))
        Cells(Rw + 1, 1) = B
        Rw = Rw + 1
    Next i

End Sub

 

[Jaafar Tribak]

I tested your code in Win10 64bit Excel 2016 x64bit and worked fine.

Unless I am missing something, you can always usea non-Shell32.Shell method such as the FyleSystemObject to return the shortcuts in the desktop folder.

Here is an custom function:

Function GetShortcuts(ByVal LookInFolder As String) As Variant()

    Dim oFSO As Object, oFileItem As Object, oFolder As Object
    Dim vArray() As Variant, i As Long
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(LookInFolder)
    For Each oFileItem In oFolder.Files
        If Right(oFileItem.Name, 3) = "lnk" Then
            ReDim Preserve vArray(i)
            vArray(i) = oFileItem.Name
            Debug.Print vArray(i)
            i = i + 1
        End If
    Next    
   GetShortcuts = vArray
    
End Function

An to test the above function:

Sub test()

    Dim ShortCutsList() As Variant
    
    ShortCutsList = GetShortcuts(LookInFolder:=Environ("USERPROFILE") & "\DESKTOP")
    
    If Not Not ShortCutsList Then
        ShortCutsList = Application.Transpose(ShortCutsList)
        Range("a1:a" & Rows.Count).ClearContents
        Range("a1:a" & UBound(ShortCutsList)) = ShortCutsList
    Else
        MsgBox "No shortcuts found."
    End If

End Sub