Thema Datum  Von Nutzer Rating
Antwort
16.05.2014 11:24:34 Gast88897
NotSolved
16.05.2014 11:55:26 Gast98199
NotSolved
16.05.2014 13:01:18 Gast27298
NotSolved
17.05.2014 14:25:43 Gast13686
NotSolved
19.05.2014 07:58:21 Gast65908
NotSolved
20.05.2014 11:56:56 Gast59861
NotSolved
Rot Ordner mit Bilder über userform wählen und in excel-mappe ausgeben
20.05.2014 19:36:48 Gast43910
NotSolved

Ansicht des Beitrags:
Von:
Gast43910
Datum:
20.05.2014 19:36:48
Views:
1418
Rating: Antwort:
  Ja
Thema:
Ordner mit Bilder über userform wählen und in excel-mappe ausgeben

Dann eben so,

Hier der code der Userforrm:

Private Pfade As Variant

Private Sub CommandButton1_Click()
    Dim i As Integer, z As Integer
    
    Application.ScreenUpdating = False
    z = 2
    For i = 0 To Me.LB_bilder.ListCount - 1
        If Me.LB_bilder.Selected(i) = True Then
            Cells(z - 1, 2) = Me.LB_bilder.List(i)
            Call Bild_laden(ActiveSheet, Cells(z, 2), Pfade(i))
            z = z + 20
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

Private Sub TB_ordnerpfad_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Dim Pfad As String, Pfad_zuvor As String, x As Integer
    Dim objFileSearch As clsFileSearch, lngIndex As Long
    
    Pfad_zuvor = Me.TB_ordnerpfad
    Pfad = ordner("Bitte ordner mit bilder auswählen.", , &H200)
    If Trim(Pfad) = "" And Trim(Pfad_zuvor) <> "" Then Pfad = Pfad_zuvor
    Me.TB_ordnerpfad = Pfad
    
    Set objFileSearch = New clsFileSearch
    With objFileSearch
        .CaseSenstiv = True
        .Extension = "*.jpg"
        .FolderPath = Pfad
        .SearchLike = "*"
        .SubFolders = False
        If .Execute(Sort_by_Date_Create, Sort_Order_Ascending) > 0 Then
            Me.LB_bilder.Clear: ReDim Pfade(x)
            For lngIndex = 1 To .FileCount
                With .Files(lngIndex)
                    Me.LB_bilder.AddItem Left(.strFilename, InStrRev(.strFilename, ".") - 1)
                    ReDim Preserve Pfade(x)
                    Pfade(x) = .strPath
                    x = x + 1
                End With
            Next
        End If
    End With
    Set objFileSearch = Nothing
    
    Me.LB_bilder.SetFocus
End Sub

in dieser brauchst du eine Listbox mit dem Namen (LB_bilder) einen Commandbutton mit dem Namen (CommandButton1) und eine Textbox mit dem Name (TB_ordnerpfad).

 

Dann der code in einem modul:

Public Enum SORT_BY
    Sort_by_None
    Sort_by_Name
    Sort_by_Path
    Sort_by_Size
    Sort_by_Last_Access
    Sort_by_Last_Modyfy
    Sort_by_Date_Create
End Enum

Public Enum SORT_ORDER
    Sort_Order_Ascending
    Sort_Order_Descending
End Enum

Public Type FILEINFO
    strFilename As String
    strPath As String
    lngSize As Long
    dmtLastAccess As Date
    dmtLastModify As Date
    dmtDateCreate As Date
End Type

Public Sub Bild_laden(WS As Worksheet, rng As Range, Pfad As Variant)
    Dim Picture As Object
    
    Set Picture = WS.Pictures.Insert(Pfad)
    
    With Picture
        .Name = rng.Address & "_" & .Name
        .Left = rng.Left
        .Top = rng.Top
        Call Maß(Picture, 200)
    End With
End Sub

Sub Maß(SH As Object, Optional Höhe As Double, Optional Breite As Double)
    Dim V As Double
    
    With SH
        If .Height > .Width Then
            V = .Height / .Width
            
            If Höhe = 0 Then
                .Width = Breite
                .Height = Breite * V
            Else
                .Height = Höhe
                .Width = Höhe / V
            End If
        Else
            V = .Width / .Height
            
            If Höhe = 0 Then
                .Width = Breite
                .Height = Breite / V
            Else
                .Height = Höhe
                .Width = Höhe * V
            End If
        End If
    End With
End Sub

Public Function ordner(Optional Capt, Optional StartVerzeichniss, Optional Art)
    ' &H400 ist mit ordner neu erstellen button
    ' &H200 ist ohne ordner neu erstellen button
    Dim objShell As Object
    Set objShell = CreateObject("Shell.Application").BrowseForFolder(0&, Capt, Art, StartVerzeichniss)
    If Not objShell Is Nothing Then ordner = objShell.Self.Path
End Function

Dann noch ein Klassenmodul mit dem Namen (clsFileSearch) und dem code:

Private Declare Function FindFirstFile Lib "kernel32.dll" Alias "FindFirstFileA" ( _
    ByVal lpFileName As String, _
    ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32.dll" Alias "FindNextFileA" ( _
    ByVal hFindFile As Long, _
    ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32.dll" ( _
    ByVal hFindFile As Long) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32.dll" ( _
    ByRef lpFileTime As FILETIME, _
    ByRef lpLocalFileTime As FILETIME) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32.dll" ( _
    ByRef lpFileTime As FILETIME, _
    ByRef lpSystemTime As SYSTEMTIME) As Long

Private Enum FILE_ATTRIBUTE
    FILE_ATTRIBUTE_READONLY = &H1
    FILE_ATTRIBUTE_HIDDEN = &H2
    FILE_ATTRIBUTE_SYSTEM = &H4
    FILE_ATTRIBUTE_DIRECTORY = &H10
    FILE_ATTRIBUTE_ARCHIVE = &H20
    FILE_ATTRIBUTE_NORMAL = &H80
    FILE_ATTRIBUTE_TEMPORARY = &H100
End Enum

Private Const MAX_PATH = 260&
Private Const INVALID_HANDLE_VALUE = -1&

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type

Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type

Private mlngFileCount As Long
Private mudtFiles() As FILEINFO
Private mstrFolderPath As String
Private mstrExtension As String
Private mstrSearchLike As String
Private mblnSubFolders As Boolean
Private mblnCaseSenstiv As Boolean

Friend Property Get Files(lngIndex As Long) As FILEINFO
    Files = mudtFiles(lngIndex)
End Property

Friend Property Get FileCount() As Long
    FileCount = mlngFileCount
End Property

Friend Property Let FolderPath(strFolderPath As String)
    mstrFolderPath = strFolderPath
End Property

Friend Property Let Extension(strExtension As String)
    mstrExtension = strExtension
End Property

Friend Property Let SearchLike(strSearchLike As String)
    mstrSearchLike = strSearchLike
End Property

Friend Property Let SubFolders(blnSubFolders As Boolean)
    mblnSubFolders = blnSubFolders
End Property

Friend Property Let CaseSenstiv(blnCaseSenstiv As Boolean)
    mblnCaseSenstiv = blnCaseSenstiv
End Property

Friend Function Execute(Optional enmSortBy As SORT_BY = Sort_by_None, _
    Optional enmSortOrder As SORT_ORDER = Sort_Order_Ascending) As Long
    Call FindFiles(mstrFolderPath)
    If mlngFileCount > 1 And enmSortBy <> Sort_by_None Then _
        Call prcSort(1, mlngFileCount, enmSortBy, enmSortOrder)
    Execute = mlngFileCount
End Function

Private Sub FindFiles(ByVal strFolderPath As String)
    Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strDirName As String
    On Error GoTo ErrorHandling
    If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
    lngSearch = FindFirstFile(strFolderPath & "*.*", WFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        Call GetFilesInFolder(strFolderPath)
        If mblnSubFolders Then
            Do
                If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
                    strDirName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr$(0)) - 1)
                    If (strDirName <> ".") And (strDirName <> "..") Then _
                        Call FindFiles(strFolderPath & strDirName)
                End If
            Loop While FindNextFile(lngSearch, WFD)
        End If
        FindClose lngSearch
    End If
    Exit Sub
ErrorHandling:
    MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
        Err.Description, vbCritical, "Fehler"
End Sub

Private Sub GetFilesInFolder(ByVal strFolderPath As String)
    Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strFilename As String
    Dim udtFiletime As FILETIME, udtSystemtime As SYSTEMTIME
    On Error GoTo ErrorHandling
    If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
    lngSearch = FindFirstFile(strFolderPath & mstrExtension, WFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        Do
            If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY Then
                strFilename = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr$(0)) - 1)
                If IIf(mblnCaseSenstiv, strFilename, LCase$(strFilename)) Like _
                    IIf(mblnCaseSenstiv, mstrSearchLike, LCase$(mstrSearchLike)) Then
                    mlngFileCount = mlngFileCount + 1
                    ReDim Preserve mudtFiles(1 To mlngFileCount)
                    With mudtFiles(mlngFileCount)
                        .strPath = strFolderPath & strFilename
                        .strFilename = strFilename
                        .lngSize = WFD.nFileSizeLow
                        FileTimeToLocalFileTime WFD.ftCreationTime, udtFiletime
                        FileTimeToSystemTime udtFiletime, udtSystemtime
                        .dmtDateCreate = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime.wMonth, udtSystemtime.wDay) + _
                            TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute, udtSystemtime.wSecond))
                        FileTimeToLocalFileTime WFD.ftLastAccessTime, udtFiletime
                        FileTimeToSystemTime udtFiletime, udtSystemtime
                        .dmtLastAccess = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime.wMonth, udtSystemtime.wDay) + _
                            TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute, udtSystemtime.wSecond))
                        FileTimeToLocalFileTime WFD.ftLastWriteTime, udtFiletime
                        FileTimeToSystemTime udtFiletime, udtSystemtime
                        .dmtLastModify = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime.wMonth, udtSystemtime.wDay) + _
                            TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute, udtSystemtime.wSecond))
                    End With
                End If
            End If
        Loop While FindNextFile(lngSearch, WFD)
        FindClose lngSearch
    End If
    Exit Sub
ErrorHandling:
    MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
        Err.Description, vbCritical, "Fehler"
End Sub

Private Sub prcSort(lngLBorder As Long, lngUBorder As Long, enmSortBy As SORT_BY, enmSortOrder As SORT_ORDER)
    Dim lngIndex1 As Long, lngIndex2 As Long
    Dim udtBuffer As FILEINFO, vntTemp As Variant
   
    lngIndex1 = lngLBorder
    lngIndex2 = lngUBorder
    Select Case enmSortBy
      Case Sort_by_Name: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).strFilename
      Case Sort_by_Path: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).strPath
      Case Sort_by_Size: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).lngSize
      Case Sort_by_Last_Access: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).dmtLastAccess
      Case Sort_by_Last_Modyfy: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).dmtLastModify
      Case Sort_by_Date_Create: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).dmtDateCreate
    End Select
    Do
        Select Case enmSortBy
          Case Sort_by_Name
            If enmSortOrder = Sort_Order_Ascending Then
                Do While mudtFiles(lngIndex1).strFilename < vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp < mudtFiles(lngIndex2).strFilename
                    lngIndex2 = lngIndex2 - 1
                Loop
              Else
                Do While mudtFiles(lngIndex1).strFilename > vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp > mudtFiles(lngIndex2).strFilename
                    lngIndex2 = lngIndex2 - 1
                Loop
            End If
          Case Sort_by_Path
            If enmSortOrder = Sort_Order_Ascending Then
                Do While mudtFiles(lngIndex1).strPath < vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp < mudtFiles(lngIndex2).strPath
                    lngIndex2 = lngIndex2 - 1
                Loop
              Else
                Do While mudtFiles(lngIndex1).strPath > vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp > mudtFiles(lngIndex2).strPath
                    lngIndex2 = lngIndex2 - 1
                Loop
            End If
          Case Sort_by_Size
            If enmSortOrder = Sort_Order_Ascending Then
                Do While mudtFiles(lngIndex1).lngSize < vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp < mudtFiles(lngIndex2).lngSize
                    lngIndex2 = lngIndex2 - 1
                Loop
              Else
                Do While mudtFiles(lngIndex1).lngSize > vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp > mudtFiles(lngIndex2).lngSize
                    lngIndex2 = lngIndex2 - 1
                Loop
            End If
          Case Sort_by_Last_Access
            If enmSortOrder = Sort_Order_Ascending Then
                Do While mudtFiles(lngIndex1).dmtLastAccess < vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp < mudtFiles(lngIndex2).dmtLastAccess
                    lngIndex2 = lngIndex2 - 1
                Loop
              Else
                Do While mudtFiles(lngIndex1).dmtLastAccess > vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp > mudtFiles(lngIndex2).dmtLastAccess
                    lngIndex2 = lngIndex2 - 1
                Loop
            End If
          Case Sort_by_Last_Modyfy
            If enmSortOrder = Sort_Order_Ascending Then
                Do While mudtFiles(lngIndex1).dmtLastModify < vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp < mudtFiles(lngIndex2).dmtLastModify
                    lngIndex2 = lngIndex2 - 1
                Loop
              Else
                Do While mudtFiles(lngIndex1).dmtLastModify > vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp > mudtFiles(lngIndex2).dmtLastModify
                    lngIndex2 = lngIndex2 - 1
                Loop
            End If
          Case Sort_by_Date_Create
            If enmSortOrder = Sort_Order_Ascending Then
                Do While mudtFiles(lngIndex1).dmtDateCreate < vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp < mudtFiles(lngIndex2).dmtDateCreate
                    lngIndex2 = lngIndex2 - 1
                Loop
              Else
                Do While mudtFiles(lngIndex1).dmtDateCreate > vntTemp
                    lngIndex1 = lngIndex1 + 1
                Loop
                Do While vntTemp > mudtFiles(lngIndex2).dmtDateCreate
                    lngIndex2 = lngIndex2 - 1
                Loop
            End If
        End Select
        If lngIndex1 <= lngIndex2 Then
            udtBuffer = mudtFiles(lngIndex1)
            mudtFiles(lngIndex1) = mudtFiles(lngIndex2)
            mudtFiles(lngIndex2) = udtBuffer
            lngIndex1 = lngIndex1 + 1
            lngIndex2 = lngIndex2 - 1
        End If
    Loop Until lngIndex1 > lngIndex2
    If lngLBorder < lngIndex2 Then Call prcSort(lngLBorder, lngIndex2, enmSortBy, enmSortOrder)
    If lngIndex1 < lngUBorder Then Call prcSort(lngIndex1, lngUBorder, enmSortBy, enmSortOrder)
End Sub

Der code des Klassenmoduls ist um Dateien aus Ordner auszulesen, in diesem fall jpg Dateien.

Der code des Klassenmoduls ist aber aus der Internet, ist ein ersatz für das alte Filesearch.


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
16.05.2014 11:24:34 Gast88897
NotSolved
16.05.2014 11:55:26 Gast98199
NotSolved
16.05.2014 13:01:18 Gast27298
NotSolved
17.05.2014 14:25:43 Gast13686
NotSolved
19.05.2014 07:58:21 Gast65908
NotSolved
20.05.2014 11:56:56 Gast59861
NotSolved
Rot Ordner mit Bilder über userform wählen und in excel-mappe ausgeben
20.05.2014 19:36:48 Gast43910
NotSolved