Dateien im Verzeichnisbaum anzeigen und auswählen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

hi Fritz
in Modul1

Sub bilddateien_lesen()
Application.ScreenUpdating = False

Dim strInitialDir As String, strPath As String
    Dim sFile As String, sPattern As String, sPath As String
    Dim iRow As Integer
    Columns(1).ClearContents
    sPath = BrowseDirectory()
    If sPath = "" Then Exit Sub
'einlesen
    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
    sPattern = "*.*"
Dim ordner As String
Dim oBilder As Worksheet
Dim FS As FileSearch
Dim sName As String
'Name des Bildauswahlblattes
sName = "Ohne Namen"

'ORDNER DURCHSUCHEN
'FileSearch definieren
Set FS = Application.FileSearch
With FS
    .NewSearch
    .LookIn = sPath
    .SearchSubFolders = True
    .FileType = msoFileTypeAllFiles
    .Execute

End With

'BLATT ERSTELLEN UND EINRICHTEN
On Error GoTo fehler
Set oBilder = Worksheets.Add
oBilder.Name = sName
'Blattkopf
oBilder.Cells(1, 1).Value = "Bilder aus " & sPath
oBilder.Cells(2, 1).Value = "Vorschau"
oBilder.Cells(2, 2).Value = "Link"
With oBilder.Cells(1, 1).Font
    .Bold = True
    .Size = .Size + 4
End With
With oBilder.Range(Cells(2, 1), Cells(2, 2)).Font
    .Bold = True
    .Size = .Size + 2
End With

'DATEIEN AUS ORDNER EINLESEN
On Error GoTo 0
Dim iZeile As Integer
iZeile = 3
For i = 1 To FS.FoundFiles.Count
'Vereinbarung der Typen, die gesucht werden können
    If FS.FoundFiles(i) Like "*.*" Then

        'Festsetzung von Bild- und Zeilenhöhe
        oBilder.Rows(iZeile).RowHeight = 150
        'Text vertikal mittig in Zeile
        oBilder.Rows(iZeile).VerticalAlignment = xlVAlignCenter
        'gefundenes Bild einfügen und Höhe auf Zeilenhöhe setzen
        oBilder.Cells(iZeile, 1).Select
        ActiveSheet.Pictures.Insert(FS.FoundFiles(i)).Select
        With Selection.ShapeRange
            .LockAspectRatio = msoTrue
            .Height = 150
            oBilder.Hyperlinks.Add Anchor:=.Item(1), Address:=FS.FoundFiles(i)
        End With
        'maximale Breite merken
        If Selection.ShapeRange.Width > maxWidth Then _
            maxWidth = Selection.ShapeRange.Width
        'Hyperlink mit Dateinamen in Spalte B
        oBilder.Hyperlinks.Add Anchor:=oBilder.Cells(iZeile, 2), _
            Address:=FS.FoundFiles(i), _
            TextToDisplay:=FS.FoundFiles(i), _
            ScreenTip:="Hier klicken, um das Bild anzuzeigen ..."
        'Zeilenzähler hochsetzen
        iZeile = iZeile + 2
    End If
Next
'Breite der 1. Spalte auf max. Breite, der 2. Spalte auf optimale Breite
maxWidth = maxWidth * oBilder.Columns(1).ColumnWidth / _
    oBilder.Columns(1).Width + 5
If maxWidth > 255 Then maxWidth = 255
oBilder.Columns(1).ColumnWidth = maxWidth
oBilder.Columns(2).AutoFit
oBilder.Cells(3, 1).Select

Exit Sub

fehler:

If Err.Number = 1004 Then sName = sName & "_": Resume

Application.ScreenUpdating = True

End Sub

Modul2
Private Declare Function SHBrowseForFolder Lib "shell32" _
    (lpbi As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" _
    (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
    (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
     lParam As Any) As Long
Private Declare Function SHSimpleIDListFromPath Lib "shell32" Alias "#162" _
    (ByVal szPath As String) As Long
Private Const BIF_RETURNONLYFSDIRS As Long = 1
Private Const BIF_DONTGOBELOWDOMAIN As Long = 2
Private Const BFFM_INITIALIZED As Long = 1
Private Const MAX_PATH As Long = 260
Private Const WM_USER As Long = &H400
Private Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100)
Private Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Private Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
Private Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)
Private Type BROWSEINFO
    hwndOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type

' Callback für die Browse-Directory-Methode - "pidList"-Methode
' zur Verwendung in der BrowseDirectory()-Funktion
Private Function BrowseCallBackProc(ByVal hwnd As Long, _
        ByVal uMsg As Long, ByVal lParam As Long, _
        ByVal lpData As Long) As Long
    'Voreinstellung des Verzeichnisses im Verzeichnis-
    'Dialog unter Verwendung des Parameters "pidList"
    Select Case uMsg
    Case BFFM_INITIALIZED
        Call SendMessage(hwnd, BFFM_SETSELECTIONA, False, ByVal lpData)
    Case Else
    End Select
End Function
Private Function FARPROC(pfn As Long) As Long
      FARPROC = pfn
End Function

Private Function GetPIDLFromPath(ByVal sPath As String) As Long
        GetPIDLFromPath = SHSimpleIDListFromPath(StrConv(sPath, vbUnicode))
    End Function

Public Function BrowseDirectory(Optional ByVal strInitialDir As String, Optional ByVal _
        hwnd As Long) As String
    Dim lpIDList As Long
    Dim sBuffer As String
    Dim szTitle As String
    Dim tBrowseInfo As BROWSEINFO
    szTitle = "Please select a directory"
    With tBrowseInfo
        .hwndOwner = hwnd
        .pidlRoot = 0
        .lpszTitle = szTitle
        .lpfnCallback = FARPROC(AddressOf BrowseCallBackProc)
        .lParam = GetPIDLFromPath(strInitialDir)
    End With
    lpIDList = SHBrowseForFolder(tBrowseInfo)
    If (lpIDList) Then
        sBuffer = Space(MAX_PATH)
        SHGetPathFromIDList lpIDList, sBuffer
        sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
        BrowseDirectory = sBuffer
        CoTaskMemFree lpIDList
    Else
        BrowseDirectory = strInitialDir
    End If
    ' Ressourcen freigeben
    CoTaskMemFree tBrowseInfo.lParam
End Function

Sub OrdnerAuswahl()
    Dim strInitialDir As String, strPath As String
        strPath = BrowseDirectory()

End Sub

gruss
ivan

hi FRITZ
versuch das mal ist einfacher

'Verzeichniss einlesen als Hyperlink
Private Sub Refresh_Click()
  Application.ScreenUpdating = False

    Dim strInitialDir As String, strPath As String
    Dim sFile As String, sPattern As String, sPath As String
    Dim iRow As Integer
    Columns(1).ClearContents

    sPath = BrowseDirectory()
    If sPath = "" Then Exit Sub
'einlesen
    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
    sPattern = "*.*"
    sFile = Dir(sPath & sPattern)
    Do Until sFile = ""
        iRow = iRow + 1
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(iRow, 1), _
        Address:=sPath & sFile, TextToDisplay:=sFile
        sFile = Dir()
    Loop
Application.ScreenUpdating = True
End Sub

gruss
ivan

Beliebteste Forumthreads (12 Monate)

Dateien im Verzeichnisbaum anzeigen und auswählen

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread