Dereference in Application.FileDialog

[advnath]

I'm trying to have a FileDialog select a shortcut (*.lnk) file, and not the destination file in VBA.

E.g. 'C:\MyShortcut.lnk' is a shortcut to 'C:\SomeFolder\BurriedDeep\MyFile.xls' and I want to select the shortcut and update it to 'C:\SomeFolder\BurriedDeep\MyNewFile.xls'

MSDN link about FileDialog:
https://msdn.microsoft.com/en-us/library/office/ff862446.aspx?f=255&MSPPError=-2147217396

Code is:
Dim objFileDialog As FileDialog
Set objFileDialog = Application.FileDialog(msoFileDialogFilePicker)
objFileDialog.AllowMultiSelect = False
objFileDialog.Filters.Add "Shortcuts", "*.lnk", 1
objFileDialog.Show
'User to select file
MsgBox objFileDialog.SelectedItems(1)

However, whenever I select the shortcut, the value returned is the path and name of the destination file, not the shortcut.

From what I can discover, Visual Studio allows the use of a "DereferenceLinks" property to alleviate this problem, but I'm using Excel 2010 VBA and not Visual Studio and I can't find a similar property in VBA.
https://msdn.microsoft.com/en-us/li...ms.filedialog.dereferencelinks(v=vs.110).aspx

Does anyone know of a good workaround?

 

[Jaafar Tribak]

Hi and welcome to the forum.

Try using the GetOpenFileName API exported by the comdlg32.dll and set the OFN_NODEREFERENCELINKS flag .. Something like this :

Option Explicit

Private Type OPENFILENAME
        lStructSize As Long
#If VBA7 Then
        hwndOwner As LongPtr
        hInstance As LongPtr
#Else
        hwndOwner As Long
        hInstance As Long
#End If
        lpstrFilter As String
        lpstrCustomFilter As String
        nMaxCustFilter As Long
        nFilterIndex As Long
        lpstrFile As String
        nMaxFile As Long
        lpstrFileTitle As String
        nMaxFileTitle As Long
        lpstrInitialDir As String
        lpstrTitle As String
        flags As Long
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
#If VBA7 Then
        lCustData As LongPtr
        lpfnHook As LongPtr
#Else
        lCustData As Long
        lpfnHook As Long
#End If
        lpTemplateName As String
'#if (_WIN32_WINNT >= 0x0500)
        'pvReserved As LongPtr
        'dwReserved As Long
        'FlagsEx As Long
'#endif // (_WIN32_WINNT >= 0x0500)
End Type


#If VBA7 Then
    Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
#Else
    Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
#End If


Private Const OFN_NODEREFERENCELINKS = &H100000


Sub Test()
    Dim OpenFile As OPENFILENAME
    Dim lReturn As Long
    
    With OpenFile
        .lStructSize = LenB(OpenFile)
        .lpstrFile = String(1024, vbNullChar)
        .nMaxFile = LenB(.lpstrFile) - 1
        .lpstrFileTitle = .lpstrFile
        .nMaxFileTitle = .nMaxFile
        .hwndOwner = Application.Hwnd
        .lpstrTitle = "Select a Shortcut."
        .flags = OFN_NODEREFERENCELINKS
        .lpstrFilter = "Shortcuts (*.lnk)" & vbNullChar & "*.lnk" & vbNullChar
        .nFilterIndex = 1
        lReturn = GetOpenFileName(OpenFile)
        If lReturn Then
            MsgBox "You selected : " & vbCrLf & Trim(Left(.lpstrFile, InStr(1, .lpstrFile, vbNullChar) - 1))
        Else
            MsgBox "You cancelled."
        End If
    End With
End Sub

 

[GTO]

@ Jaafar:

Greetings

As you are aware, I am quite the rookie with API, and I cannot imagine this is not already something you are familiar with, but just on the off-chance, I thought I'd mention:

<font face=Courier New>********<SPAN style="color:#00007F">If</SPAN> lReturn <SPAN style="color:#00007F">Then</SPAN><br>************MsgBox "You selected : " & vbCrLf & Trim(Left(.lpstrFile, InStr(1, .lpstrFile, vbNullChar) - 1))<br>************MsgBox "You selected : " & vbCrLf & Left$(.lpstrFile, lstrlenW(StrPtr(.lpstrFile)))<br>********<SPAN style="color:#00007F">Else</SPAN><br>************MsgBox "You cancelled."</FONT>

...where lsrlenW is declared:

<font face=Courier New><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Declare</SPAN> <SPAN style="color:#00007F">Function</SPAN> lstrlenW <SPAN style="color:#00007F">Lib</SPAN> "kernel32" (<SPAN style="color:#00007F">ByVal</SPAN> lpString <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br></FONT>

I read somewhere that it's a tiny bit faster than InStr()

Have a great day!

Mark

 

[Jaafar Tribak]

Hi Mark,

For the purposes of this particular scenario, the the difference in speed would be trivial .. Out of curiosity, I have ran a small test and the VBA Instr function turned out to be slightly faster on my machine !

Option Explicit

#If VBA7 Then
    Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
    Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
    Declare PtrSafe Function lstrlenW Lib "kernel32" (ByVal lpString As LongPtr) As Long
#Else
    Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
    Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
    Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
#End If
    
Private Sub Command1_Click()
    Dim Freq As Currency
    Dim startTime As Currency
    Dim endTime As Currency
    Dim i As Long
    Dim StrLen As Long
    Dim sInitString As String
    Dim sNewString As String

    If QueryPerformanceFrequency(Freq) <> 0 Then
        ' lstrlen test
        sInitString = "A"
        QueryPerformanceCounter startTime
        For i = 1 To 100000
            sNewString = String(i, sInitString) & String(1, vbNullChar)
            StrLen = lstrlenW(StrPtr(sNewString))
        Next
        QueryPerformanceCounter endTime
        Debug.Print "(lstrlen) took : " & vbTab & Format((endTime - startTime) / Freq, "0.00000") & " Secs."
        
        ' Instr test
        sInitString = "A"
        QueryPerformanceCounter startTime
        For i = 1 To 100000
            sNewString = String(i, sInitString) & String(1, vbNullChar)
            StrLen = InStr(1, sNewString, vbNullChar)-1
        Next
        QueryPerformanceCounter endTime
        Debug.Print "(Instr) took   : " & vbTab & Format((endTime - startTime) / Freq, "0.00000") & " Secs."
        Debug.Print "=================================="
    End If

End Sub

This is the output I got from 4 runs :

(lstrlen) took :    7,60935 Secs.
(Instr) took   :    7,44041 Secs.
==================================
(lstrlen) took :    7,61903 Secs.
(Instr) took   :    7,44696 Secs.
==================================
(lstrlen) took :    7,60778 Secs.
(Instr) took   :    7,42920 Secs.
==================================
(lstrlen) took :    7,59664 Secs.
(Instr) took   :    7,43572 Secs.
==================================

 

[GTO]

Hi Jaafar,

I agree that barring some hideous amount of looping, the speed difference wouldn't be much, I just thought to mention what I had read. I tested your code as posted (excepting declarations as Private due to plunking the code in the sheet's module) and got similar results:

CommandButton1 Results:

(lstrlen) took :  3.88455 Secs.
(Instr) took   :  3.42002 Secs.
==================================
(lstrlen) took :  3.87625 Secs.
(Instr) took   :  3.41942 Secs.
==================================
(lstrlen) took :  3.86982 Secs.
(Instr) took   :  3.42124 Secs.
==================================
(lstrlen) took :  3.89420 Secs.
(Instr) took   :  3.44334 Secs.
==================================

Although the PC I am sitting at appears possibly a bit quicker, I see the variance is a bit more on average. Anyways, this made me a bit curious as well, and I wondered if moving the string-building out of the timed section would change the variance at all. In this testing (code below), I got output of:

(lstrlen) took :  0.04132 Secs.
(Instr) took   :  0.03931 Secs.
==================================
(lstrlen) took :  0.04077 Secs.
(Instr) took   :  0.03650 Secs.
==================================
(lstrlen) took :  0.03790 Secs.
(Instr) took   :  0.03765 Secs.
==================================
(lstrlen) took :  0.03773 Secs.
(Instr) took   :  0.03971 Secs.
==================================

While of course the times are smaller with the string array being 'pre-built', it seems to me that the variance is smaller (percentage wise I mean) and sometimes lstrlenW edges out.

In Sheet1's Module:

Option Explicit
  
Private Type LARGE_INTEGER
    LowPart As Long
    HighPart As Long
End Type
  
#If VBA7 Then
Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Private Declare PtrSafe Function QueryPerformanceCounterAliased Lib "kernel32" Alias "QueryPerformanceCounter" (lpPerformanceCount As LARGE_INTEGER) As Long
Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
Private Declare PtrSafe Function QueryPerformanceFrequencyAliased Lib "kernel32" Alias "QueryPerformanceFrequency" (lpFrequency As LARGE_INTEGER) As Long
Private Declare PtrSafe Function lstrlenW Lib "kernel32" (ByVal lpString As LongPtr) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
#Else
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Private Declare Function QueryPerformanceCounterAliased Lib "kernel32" Alias "QueryPerformanceCounter" (lpPerformanceCount As LARGE_INTEGER) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
Private Declare Function QueryPerformanceFrequencyAliased Lib "kernel32" Alias "QueryPerformanceFrequency" (lpFrequency As LARGE_INTEGER) As Long
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
#End If
  
Private Const UPPERBOUND As Long = 100000
  
Private arrstrRandomStrings(1 To UPPERBOUND) As String
    
Private Sub Setup()
Dim i As Long
Dim n As Long
Dim StrLen As Long
Dim sInitString As String
  
  For i = 1 To UPPERBOUND
    StrLen = vbaRandBetween(2, 1000)
    sInitString = vbNullString
    For n = 1 To StrLen - 1
      sInitString = sInitString & Chr$(vbaRandBetween(32, 126))
    Next
    arrstrRandomStrings(i) = sInitString & vbNullChar
  Next
End Sub
  
Private Sub CommandButton3_Click()
Dim liFreq As LARGE_INTEGER
Dim curFreq As Currency
Dim liStart As LARGE_INTEGER
Dim liEnd As LARGE_INTEGER
Dim curStartTime As Currency
Dim curEndTime As Currency
Dim i As Long
Dim StrLen As Long
Dim sInitString As String
Dim sNewString As String
  
  '// my slacker "safety" to make sure I didn't reset and forgot to run setup() //
  For i = 1 To UPPERBOUND
    If Len(arrstrRandomStrings(i)) < 2 Then
      Setup
      Exit For
    End If
  Next
  
  If Not QueryPerformanceFrequencyAliased(liFreq) = 0 Then
    
    curFreq = LargeIntToCurrency(liFreq)
    
    ' lstrlen test
    QueryPerformanceCounterAliased liStart
    For i = 1 To UPPERBOUND
      StrLen = lstrlenW(StrPtr(arrstrRandomStrings(i)))
    Next
    QueryPerformanceCounterAliased liEnd


    curStartTime = LargeIntToCurrency(liStart)
    curEndTime = LargeIntToCurrency(liEnd)


    Debug.Print "(lstrlen) took : " & vbTab & Format((curEndTime - curStartTime) / curFreq, "0.00000") & " Secs."
  
    ' Instr test
    QueryPerformanceCounterAliased liStart
    For i = 1 To UPPERBOUND
      StrLen = InStr(1, arrstrRandomStrings(i), vbNullChar) - 1
    Next
    QueryPerformanceCounterAliased liEnd
    
    curStartTime = LargeIntToCurrency(liStart)
    curEndTime = LargeIntToCurrency(liEnd)
    
    Debug.Print "(Instr) took   : " & vbTab & Format((curEndTime - curStartTime) / curFreq, "0.00000") & " Secs."
    Debug.Print "=================================="
    
  End If
  
End Sub
  
Private Function vbaRandBetween(LowNumber As Long, HighNumber As Long) As Long
  vbaRandBetween = Int((HighNumber - LowNumber + 1) * Rnd + LowNumber)
End Function
  
Private Function LargeIntToCurrency(liInput As LARGE_INTEGER) As Currency
  
  CopyMemory LargeIntToCurrency, liInput, LenB(liInput)
  LargeIntToCurrency = LargeIntToCurrency * 10000
  
End Function

Thank you for your testing and the conversation. Always nice to "chat".

Mark

 

[Jaafar Tribak]

Thank you Mark for the followup.