title image


Smiley Hier ein Code...
Hallo LXus,



ich hab so was parat.



Hier der Aufruf







      

Private Sub CommandButton2_Click()

Dim path As String

path = Folder(0)

If path <> "" Then Cells(1, 8).Value = IIf(Right(path, 1) = "\", path, path & "\")



End Sub

 



Code eingefügt mit Syntaxhighlighter 3.0







unm dies in ein Modul







      

Option Explicit

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Public Type BROWSEINFO

    hOwner As Long

    pidlRoot As Long

    pszDisplayName As String

    lpszTitle As String

    ulFlags As Long

    lpfn As Long

    lParam As Long

    iImage As Long

End Type



Private Type ShortCut

    path As String

    File As String

    WorkDir As String

End Type







Public Function Folder(hWnd As Long) As String

Dim ret As Boolean, pidl As Long, BrInfo As BROWSEINFO



With BrInfo

    .hOwner = hWnd    'hwnd der aktuellen Form

    .pidlRoot = 0

    .lpszTitle = "Pfad auswählen"    'Titeltext des Dialogs

    .ulFlags = 1    'der Wert 1 sorgt dafür, dass ausschließlich Datenträger zur Auswahl stehen, keine Systemordner

End With

pidl = SHBrowseForFolder(BrInfo)

Folder = String$(512, 0)



ret = SHGetPathFromIDList(ByVal pidl, ByVal Folder)



If ret Then

    Folder = Left(Folder, InStr(Folder, Chr$(0)) - 1)

Else

    Folder = ""

End If

End Function









Private Function GetFileName(strShortcut As String) As ShortCut

  Dim psl As ShellLinkA

  Dim ppf As IPersistFile

  Dim FileObject As WIN32_FIND_DATA

  Dim strPath As String

Dim strFile As String

On Error GoTo error

Set psl = New ShellLinkA

    Set ppf = psl

    

    strPath = String(256, 0)

    strFile = String(256, 0)

    ppf.Load StrConv(strShortcut, vbUnicode), 0

    

    psl.GetWorkingDirectory strPath, Len(strPath)

    strPath = Left(strPath, InStr(1, strPath, Chr(0)) - 1)

    GetFileName.WorkDir = strPath

    

    psl.GetPath strFile, Len(strFile), FileObject, 0

    GetFileName.File = strFile

    

    Set ppf = Nothing

Set psl = Nothing

Exit Function



error:

    Debug.Print Err, error(Err)

    Set ppf = Nothing

Set psl = Nothing

End Function

 



Code eingefügt mit Syntaxhighlighter 3.0




Gruss Klapperstorch
----------------------------------------------------
Aus Felern lernt man oder...
Edjucashon isnt woerking

geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: