Keskustelu: Koodit: FilePicker

Sub OpenFilePicker()

    Dim sUrl$
    sUrl = thisComponent.URL
    sIniDir$ = Replace(Replace(Left(sUrl, InStrReverse(sURL, "/")) & "*.xml.", "/", "\"), "file:\\\","")

    sFilter$ = "Extensible Markup Language files (*.xml)|*.xml|Portable Document files(*.pdf)|*.pdf|"
    rep = GetFileDlgEx(sIniDir, sFilter)
    If rep <> "" Then
        MsgBox "Full path: " & rep & chr(13) & chr(10) &  chr(13) & chr(10) & "Full path (when using LibreOffice [StarBasic] Basic macros): " & ConvertToURL(rep)
    End If

End Sub

Function GetFileDlgEx(sIniDir As String, sFilter As String)

  Dim objShell As Object, filePicker As Object, sTitle$
  sTitle = "Avaa"
  Set objShell = CreateObject("WScript.Shell")

  If instr(sIniDir, ":") <= 0 then
    sIniDir = objShell.CurrentDirectory & "\" & sIniDir
  End If

  sIniDir = Replace(sIniDir,"\","\\")

  Set filePicker = objShell.Exec("mshta.exe ""about:<object id=d classid=clsid:3050f4e1-98b5-11cf-bb82-00aa00bdce0b></object><script>moveTo(0,-9999);eval(new ActiveXObject('Scripting.FileSystemObject').GetStandardStream(0).Read("& Len(sIniDir)+Len(sFilter)+Len(sTitle)+41 &"));function window.onload(){var p=/[^\0]*/;new ActiveXObject('Scripting.FileSystemObject').GetStandardStream(1).Write(p.exec(d.object.openfiledlg(iniDir,null,filter,title)));close();}</script><hta:application showintaskbar=no />""")

  filePicker.StdIn.Write "var iniDir='" & sIniDir & "'; var filter='" & sFilter & "';var title='" & sTitle & "';"
  GetFileDlgEx = filePicker.StdOut.ReadAll

End Function

Function InStrReverse(sText As String, search As String) As Long

    If sText = "" Or search  = "" Then
        If sText = "" And search  <> "" Then
            MsgBox "No string from which to search" : Goto jump
        ElseIF  sText <> "" And search  = "" Then
            MsgBox "No serach string" : Goto jump
        ElseIF sText = "" And search  = "" Then
            MsgBox "Nothing to do" : Goto jump
        ElseIf Len(search) > Len(sText) Then
            MsgBox "Unable to execute, the length of the search string exceeds" & _
            chr(10) & "the length of the string being searched from" :  Goto jump
        End If
    End If

    Dim i As Long

    For i = Len(sText) To 1 Step -1
        If Mid(sText, i, Len(search)) = search Then
            InStrReverse = i : Exit Function
        End If
    Next i

jump:
    InStrReverse = 0

End Function