Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema CommandButton
BildScreenshot zu CommandButton CommandButton-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema Userform
BildScreenshot zu Userform Userform-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema ListBox
BildScreenshot zu ListBox ListBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema TextBox
BildScreenshot zu TextBox TextBox-Seite mit Beispielarbeitsmappe aufrufen

Dateiliste mit Dateieigenschaften Category

Betrifft: Dateiliste mit Dateieigenschaften Category von: Thomas Mayer
Geschrieben am: 04.10.2020 15:22:18

Hallo, ich möchte mir eine Dateiliste aller XLSM erstellen und dazu die Dateieigenschaften (Category,Keywords, Comments, ect.) einlesen. Also nicht die Standard Sachen wie Erstelldatum Filename.

Ich kann nur das ActiveWorkbook abfragen, oder? Da werden die Infos auch ausgegeben. Aber ich greife ja von außten auf den Ordner zu ohne die Datei zu öffnen.

Die Liste funktioniert ja schon

Dim FileInfoCategory As String

FileInfoCategory = ActiveWorkbook.BuiltinDocumentProperties("Keywords")

Betrifft: keine Frage nur Aufruf zur Teilnahme oT
von: Hajo_Zi
Geschrieben am: 04.10.2020 15:37:31



Betrifft: Falscher Beitrag OT
von: Hajo_Zi
Geschrieben am: 04.10.2020 15:56:29



Betrifft: noch offen
von: Hajo_Zi
Geschrieben am: 04.10.2020 15:57:48

Beitrag an fascher Stelle

Betrifft: AW: Dateiliste mit Dateieigenschaften Category
von: Nepumuk
Geschrieben am: 04.10.2020 16:39:43

Hallo Thomas,

lade dir hier:

https://www.microsoft.com/en-us/download/details.aspx?id=8422

den DSO Property Reader herunter und installiere ihn. Dann teste mal mit der Mappe im Anhang (Du musst im Code nur den Pfad einer Datei eintragen).

https://www.herber.de/bbs/user/140641.xlsm

Wenn das die gewünschten Informationen sind dann zeig ich die wie du einen ganzen Ordner auslesen kannst.

Gruß
Nepumuk

Betrifft: AW: Dateiliste mit Dateieigenschaften Category
von: Thomas Mayer
Geschrieben am: 04.10.2020 17:50:49

Danke, schau ich mir an. Andernfalls schreibe ich meine Codezeile in das Feld des Erstellers.

Betrifft: AW: Dateiliste mit Dateieigenschaften Category
von: Thomas Mayer
Geschrieben am: 04.10.2020 23:31:38

also das mit DSO fällt flach, da wir zu 10 arbeiten und ich in der Firma keine DSO dll installieren darf/kann.
Jetzt habe ich allerdings von dir in einem anderem Forum:
http://www.office-loesung.de/ftopic52412_0_0_asc.php
deine Beitrag gefunden. Und siehe da: ich kann die Infos auch so durch die Shell Abfrage bekommen.

Aber: wie der Kollege schon erwähnt hat, ist bei deinem Script als Pfad eine Constante eingegeben. Ich benötige aber einen variablen Pfad, da ich davor eine Filterung nach Jahrgang mache. Bei Dim bricht bekomme ich Fehler.
Außerdem benötige ich noch die Möglichekeit, Subfolders zu integrieren. Diese möchte ich mit einem Schalter true/false setzen um zu entscheiden mit oder ohne Subfolders.
Geht das irgendwie?

Gruß, Thomas
kannst mir auch gerne direkt per Mail schreiben tom (at) sickculture .de

Betrifft: AW: Dateiliste mit Dateieigenschaften Category
von: Nepumuk
Geschrieben am: 05.10.2020 10:42:21

Hallo Thomas,

teste mal:

Option Explicit

Public Sub SelectFolder()
    Dim objFileDialog As FileDialog
    Dim strFolder As String
    Dim blnSubFolder As Boolean
    Set objFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    With objFileDialog
        .AllowMultiSelect = False
        .InitialFileName = "G:\Eigene Dateien\" ' Anpassen !!!
        If .Show Then
            strFolder = .SelectedItems(1) & "\"
            If MsgBox("Mit Unterordnern?", vbQuestion Or vbYesNo, "Abfrage") = vbYes Then
                blnSubFolder = True
            Else
                blnSubFolder = False
            End If
            Call GetFileProperties(strFolder, blnSubFolder)
        End If
    End With
    Set objFileDialog = Nothing
End Sub

Private Sub GetFileProperties(ByVal pvstrFolder As String, ByVal pvblnSubFolders As Boolean)
    Const PROPERTIES_COUNT As Long = 360
    Dim astrFolders() As String
    Dim ialngFolders As Long
    Dim objShell As Object, objFolder As Object
    Dim lngIndex As Long, lngColumn As Long, lngRow As Long
    Dim vntFileName As Variant
    Application.ScreenUpdating = False
    If pvblnSubFolders Then
        astrFolders = GetFolders(pvstrFolder)
    Else
        Redim astrFolders(0)
        astrFolders(0) = pvstrFolder
    End If
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(CVar(pvstrFolder))
    Call Cells.Clear
    lngColumn = 1
    For lngIndex = 0 To PROPERTIES_COUNT
        Cells(1, lngColumn + lngIndex).Value = objFolder.GetDetailsOf(Empty, lngIndex)
    Next
    Rows(1).Font.Bold = True
    lngRow = 2
    For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
        Set objFolder = objShell.Namespace(CVar(astrFolders(ialngFolders)))
        For Each vntFileName In objFolder.Items
            For lngIndex = 0 To PROPERTIES_COUNT
                Cells(lngRow, lngColumn + lngIndex) = objFolder.GetDetailsOf(vntFileName, lngIndex)
            Next
            lngRow = lngRow + 1
        Next
    Next
    Columns.AutoFit
    Set objShell = Nothing
    Set objFolder = Nothing
    Application.ScreenUpdating = True
End Sub

Private Function GetFolders(ByVal pvstrPath As String) As String()
    Dim astrFolders() As String
    Dim strFolder As String, strPath As String
    Dim ialngIndex1 As Long, ialngIndex2 As Long
    Redim Preserve astrFolders(ialngIndex1)
    astrFolders(ialngIndex1) = pvstrPath
    ialngIndex1 = 1
    ialngIndex2 = 1
    strPath = pvstrPath
    Do
        strFolder = Dir$(PathName:=strPath & "*", Attributes:=vbDirectory)
        Do Until strFolder = vbNullString
            If strFolder <> "." And strFolder <> ".." Then
                If GetAttr(PathName:=strPath & strFolder) And vbDirectory Then
                    Redim Preserve astrFolders(0 To ialngIndex1)
                    astrFolders(ialngIndex1) = strPath & strFolder & "\"
                    ialngIndex1 = ialngIndex1 + 1
                End If
            End If
            strFolder = Dir$
        Loop
        If ialngIndex1 = ialngIndex2 Then Exit Do
        strPath = astrFolders(ialngIndex2)
        ialngIndex2 = ialngIndex2 + 1
    Loop
    GetFolders = astrFolders
End Function

Die Ausgabe erfolgt in der aktiven Tabelle.

Gruß
Nepumuk

Betrifft: AW: Dateiliste mit Dateieigenschaften Category
von: Thomas
Geschrieben am: 05.10.2020 13:07:19

du bist der Wahnsinn... also es funktioniert schon mal. Ich bekomme eine komplette List aller Dateien.



Rechnet aber eine Zeit.

Frage:

1. wo kann ich das Script abändern, wenn ich nur einige Infos benötige. Es wird ja pro File alle "360" Properties eingelesen und pro Spalte ausgegeben. Das ist to much und resourcenvernichtend.

2. Wenn ich nur XLSM Dokumente anzeigen möchte? Und Subfolders (also leere Ordner) als Pfad nicht ausgegeben werden sollen?

3. Kann ich den Dialog am Anfang durch eine Variable ersetzen? Also Info kommt von einem vorhergehendem Script der Startpfad und Subfolder true)

4. Wenn ich die Headline anschaue, ist das dieses Script
    For lngIndex = 0 To PROPERTIES_COUNT
        Cells(1, lngColumn + lngIndex).Value = objFolder.GetDetailsOf(Empty, lngIndex)
    Next
    Rows(1).Font.Bold = True
D.h. wenn ich die benötigend Infos abfragen möchte, ist der Wert der Zelle in Row1 in _ deutscher Sprache der Wert, den ich weiter unten vntFileName eintragen kann
For Each vntFileName In objFolder.Items
            For lngIndex = 0 To PROPERTIES_COUNT
                Cells(lngRow, lngColumn + lngIndex) = objFolder.GetDetailsOf(vntFileName,  _
lngIndex)
            Next
            lngRow = lngRow + 1
        Next
Aber schon mal rießen Respekt. Hätte ich so nicht hinbekommen.

Betrifft: AW: Dateiliste mit Dateieigenschaften Category
von: Nepumuk
Geschrieben am: 05.10.2020 13:49:30

Hallo Thomas,

ich habe es jetzt so abgeändert, dass

1. Nur .xlsm-Dateien ausgegeben werden.
2. Nur bestimmte Eigenschaften gelistet werden. Dazu musst du in dieser Zeile:

avntProperyIndex = Array(0, 3, 4, 5, 20) ' Anpassen !!!

Die laufende Nummer der Eigenschaft eintragen. Beachte, die Nummerierung beginnt mit 0. Gib einfach in Zelle A2 eine 0 ein und in Zelle B2 eine 1. Beide Zellen markieren und nach rechts ziehen. Dann kannst du die Nummer der Eigenschaft einfach ablesen.

3. Du musst die Prozedur GetFileProperties aus dem anderen Makro so aufrufen:

Call GetFileProperties(Ordnerpfad mit abschließenden \, True)

True für Subfolders.

Deine Nummer 4 verstehe ich nicht.

Private Sub GetFileProperties(ByVal pvstrFolder As String, ByVal pvblnSubFolders As Boolean)
    Dim astrFolders() As String
    Dim ialngFolders As Long
    Dim objShell As Object, objFolder As Object
    Dim ialngIndex As Long, lngColumn As Long, lngRow As Long
    Dim vntFileName As Variant, avntProperyIndex As Variant
    Application.ScreenUpdating = False
    avntProperyIndex = Array(0, 3, 4, 5, 20) ' Anpassen !!!
    If pvblnSubFolders Then
        astrFolders = GetFolders(pvstrFolder)
    Else
        Redim astrFolders(0)
        astrFolders(0) = pvstrFolder
    End If
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(CVar(pvstrFolder))
    Call Cells.Clear
    lngColumn = 1
    For ialngIndex = LBound(avntProperyIndex) To UBound(avntProperyIndex)
        Cells(1, lngColumn + ialngIndex).Value = _
            objFolder.GetDetailsOf(Empty, avntProperyIndex(ialngIndex))
    Next
    Rows(1).Font.Bold = True
    lngRow = 2
    For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
        Set objFolder = objShell.Namespace(CVar(astrFolders(ialngFolders)))
        For Each vntFileName In objFolder.Items
            If LCase$(Right$(vntFileName.Path, 5)) = ".xlsm" Then
                For ialngIndex = LBound(avntProperyIndex) To UBound(avntProperyIndex)
                    Cells(lngRow, lngColumn + ialngIndex) = _
                        objFolder.GetDetailsOf(vntFileName, avntProperyIndex(ialngIndex))
                Next
                lngRow = lngRow + 1
            End If
        Next
    Next
    Columns.AutoFit
    Set objShell = Nothing
    Set objFolder = Nothing
    Application.ScreenUpdating = True
End Sub

Gruß
Nepumuk

Betrifft: AW: Dateiliste mit Dateieigenschaften Category
von: Thomas
Geschrieben am: 05.10.2020 14:29:35

ich glaube Punkt vier hat sich erledigt durch das Array.

Ich danke dir recht herzlich. Werde es ausprobieren.

Betrifft: AW: Dateiliste mit Dateieigenschaften Category
von: Thomas
Geschrieben am: 05.10.2020 15:19:07

Funktioniert!
Habe deine Codes zusammengefügt/aktualisiert und die Liste funktioniert. Habe beide Scripte gespeichert. Einmal um alle Infos auszulesen und eine mit bestimmten Werten, die ich weiterverarbeite. Werde dies mal in meinen bestehenden Workflow einbauen.
Danke nochmals

https://www.herber.de/bbs/user/140664.zip

Betrifft: AW: Dateiliste mit Dateieigenschaften Category
von: Thomas
Geschrieben am: 06.10.2020 12:59:58

So, ich habe deinen Code mal in meine Tabelle eingefügt. Ich beginne eigentlich mit dieser Zeile:
Private Sub GetFileProperties(pvstrFolder As String, pvblnSubFolders As Boolean)

ByVal kenn ich nicht (kommt anscheinend von der Auswahl)
Meine Info ist der Path aus einem Script zuvor, der variabel übergeben wird als String ohne "\" am Ende. Subfolder ist immer true.
Das Script läuft durch und bei der Function bricht er ab.
If GetAttr(PathName:=strPath & strFolder) And vbDirectory Then

Kannst mir weiterhelfen?


'Private Sub GetFileProperties(ByVal pvstrFolder As String, ByVal pvblnSubFolders As Boolean)
Private Sub GetFileProperties(pvstrFolder As String, pvblnSubFolders As Boolean)
    Dim astrFolders() As String
    Dim ialngFolders As Long
    Dim objShell As Object, objFolder As Object
    Dim ialngIndex As Long, lngColumn As Long, lngRow As Long
    Dim vntFileName As Variant, avntProperyIndex As Variant
    'Application.ScreenUpdating = False
        Application.ScreenUpdating = True
    avntProperyIndex = Array(180, 0, 18, 22, 23, 143, 145, 177) ' Anpassen !!!
    If pvblnSubFolders Then
        astrFolders = GetFolders(pvstrFolder)
    Else
        ReDim astrFolders(0)
        astrFolders(0) = pvstrFolder
    End If
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(CVar(pvstrFolder))
    'Call Cells.Clear
    lngColumn = 2
    For ialngIndex = LBound(avntProperyIndex) To UBound(avntProperyIndex)
        Cells(5, lngColumn + ialngIndex).Value = _
            objFolder.GetDetailsOf(Empty, avntProperyIndex(ialngIndex))
    Next
    Rows(1).Font.Bold = True
    lngRow = 6
    For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
        Set objFolder = objShell.Namespace(CVar(astrFolders(ialngFolders)))
        For Each vntFileName In objFolder.Items
            If LCase$(Right$(vntFileName.Path, 5)) = ".xlsm" Then
                For ialngIndex = LBound(avntProperyIndex) To UBound(avntProperyIndex)
                    Cells(lngRow, lngColumn + ialngIndex) = _
                        objFolder.GetDetailsOf(vntFileName, avntProperyIndex(ialngIndex))
                Next
                lngRow = lngRow + 1
            End If
        Next
    Next
    Columns.AutoFit
    Set objShell = Nothing
    Set objFolder = Nothing
    Application.ScreenUpdating = True
End Sub


Private Function GetFolders(pvstrPath As String)
'Private Function GetFolders(pvstrPath As String) As String()
    Dim astrFolders() As String
    Dim strFolder As String, strPath As String
    Dim ialngIndex1 As Long, ialngIndex2 As Long
    ReDim Preserve astrFolders(ialngIndex1)
    astrFolders(ialngIndex1) = pvstrPath
    ialngIndex1 = 1
    ialngIndex2 = 1
    strPath = pvstrPath '& "\"
    Do
        strFolder = Dir$(PathName:=strPath & "*", Attributes:=vbDirectory)
        Do Until strFolder = vbNullString
            If strFolder <> "." And strFolder <> ".." Then
                If GetAttr(PathName:=strPath & strFolder) And vbDirectory Then
                    ReDim Preserve astrFolders(0 To ialngIndex1)
                    astrFolders(ialngIndex1) = strPath & strFolder & "\"
                    ialngIndex1 = ialngIndex1 + 1
                End If
            End If
            strFolder = Dir$
        Loop
        If ialngIndex1 = ialngIndex2 Then Exit Do
        strPath = astrFolders(ialngIndex2)
        ialngIndex2 = ialngIndex2 + 1
    Loop
    GetFolders = astrFolders
End Function


Betrifft: AW: Dateiliste mit Dateieigenschaften Category
von: Nepumuk
Geschrieben am: 06.10.2020 13:06:34

Hallo Thomas,

füge nach dieser Zeile:

avntProperyIndex = Array(180, 0, 18, 22, 23, 143, 145, 177) ' Anpassen !!!

folgende Zeile ein:

If Right$(pvstrFolder,1) <> "\" Then pvstrFolder = pvstrFolder & "\"

Gruß
Nepumuk

Betrifft: AW: Dateiliste mit Dateieigenschaften Category
von: Thomas
Geschrieben am: 06.10.2020 14:02:47

Funzt... danke dir. Mal schauen, was das nächste Problem wird ;-)

Betrifft: AW: Dateiliste mit Dateieigenschaften Category
von: Thomas Mayer
Geschrieben am: 07.10.2020 07:05:49

jetzt habe ich in der Tat noch was gefunden:
in der Arbeit sitze ich an einem Win7 Rechner. Dort funktioniert alles. Das Feld des Pfad (also Ordner mit *.xslm) ist in ArrayNr. 180.
Zuhause am Win10 Rechner und File auf Desktop liegend, ist das Feld Pfad plötzlich in Array 195.

Das ist blöd, weil ich aus diesem Feld einen Hyperlink erstelle um direkt Zugriff zu haben. Das scheint tatsächlich ein Problem zu sein, ob Win10 oder Win7. Liegt das an der Operation Shell.Application ?

Betrifft: AW: Dateiliste mit Dateieigenschaften Category
von: Nepumuk
Geschrieben am: 07.10.2020 09:51:56

Hallo Thomas,

das liegt vor allen Dingen daran, in welcher Reihenfolge Programme installiert wurden. Denn bei der Installation werden die Eigenschaften angelegt. Das hätte ich gleich schreiben sollen. Du könntest, je nach Anmeldenamen in Windows unterscheiden:

Private Sub GetFileProperties(ByVal pvstrFolder As String, ByVal pvblnSubFolders As Boolean)
    Dim astrFolders() As String
    Dim ialngFolders As Long
    Dim objShell As Object, objFolder As Object
    Dim ialngIndex As Long, lngColumn As Long, lngRow As Long
    Dim vntFileName As Variant, avntProperyIndex As Variant
    Application.ScreenUpdating = False
    Select Case Environ$("USERNAME")
        Case "Nepumuk"
            avntProperyIndex = Array(195, 0, 18, 22, 23, 143, 145, 177)
        Case "Thomas"
            avntProperyIndex = Array(180, 0, 18, 22, 23, 143, 145, 177)
        Case Else
            Call MsgBox("Unbekannter Benutzer.", vbCritical, "Programmabbruch")
            Exit Sub
    End Select
    If pvblnSubFolders Then
        astrFolders = GetFolders(pvstrFolder)
    Else
        Redim astrFolders(0)
        astrFolders(0) = pvstrFolder
    End If
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(CVar(pvstrFolder))
    Call Cells.Clear
    lngColumn = 1
    For ialngIndex = LBound(avntProperyIndex) To UBound(avntProperyIndex)
        Cells(1, lngColumn + ialngIndex).Value = _
            objFolder.GetDetailsOf(Empty, avntProperyIndex(ialngIndex))
    Next
    Rows(1).Font.Bold = True
    lngRow = 2
    For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
        Set objFolder = objShell.Namespace(CVar(astrFolders(ialngFolders)))
        For Each vntFileName In objFolder.Items
            If LCase$(Right$(vntFileName.Path, 5)) = ".xlsm" Then
                For ialngIndex = LBound(avntProperyIndex) To UBound(avntProperyIndex)
                    Cells(lngRow, lngColumn + ialngIndex) = _
                        objFolder.GetDetailsOf(vntFileName, avntProperyIndex(ialngIndex))
                Next
                lngRow = lngRow + 1
            End If
        Next
    Next
    Columns.AutoFit
    Set objShell = Nothing
    Set objFolder = Nothing
    Application.ScreenUpdating = True
End Sub

Gruß
Nepumuk

Betrifft: AW: Dateiliste mit Dateieigenschaften Category
von: Thomas
Geschrieben am: 07.10.2020 10:27:35

danke, das ist zu umständlich. Wir sind mindestens 10 Personen mit 10 versch. PCs.
gibts im objShell nicht nicht die function .Self.Path? Also eine Variable, die mir den Dateinamen mit Pfad ausgibt und eine Variable, mit deren Dateinamen.xlsm (.Self.name)?
Die Keywords, Erstelldatum, letzter Zugriff und 0 Filename wird übernommen, aber ob das dann in Zukunft bei den anderen PCs auch der Fall ist, weiß ich nicht. Getestet hab ich es jetzt in der Arbeit am Arbeitsplatz und zuhause. Zuhause ist Excel 2013 auf Win10, in der Arbeit Excel 2010 auf Win7. Die Makros laufen alle. Nur eben die Array Ausgabe zerhaut es mir.

Betrifft: AW: Dateiliste mit Dateieigenschaften Category
von: Nepumuk
Geschrieben am: 07.10.2020 10:39:47

Hallo Thomas,

ja das geht. Ich kann den Pfad und den Namen aus vntFile holen:

Private Sub GetFileProperties(ByVal pvstrFolder As String, ByVal pvblnSubFolders As Boolean)
    Dim astrFolders() As String
    Dim ialngFolders As Long
    Dim objShell As Object, objFolder As Object
    Dim ialngIndex As Long, lngColumn As Long, lngRow As Long
    Dim vntFile As Variant, avntProperyIndex As Variant
    Application.ScreenUpdating = False
    avntProperyIndex = Array(18, 22, 23, 143, 145, 177)
    If pvblnSubFolders Then
        astrFolders = GetFolders(pvstrFolder)
    Else
        Redim astrFolders(0)
        astrFolders(0) = pvstrFolder
    End If
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(CVar(pvstrFolder))
    Call Cells.Clear
    lngColumn = 3
    Cells(1, 1).Value = "Pfad"
    Cells(1, 2).Value = "Name"
    For ialngIndex = LBound(avntProperyIndex) To UBound(avntProperyIndex)
        Cells(1, lngColumn + ialngIndex).Value = _
            objFolder.GetDetailsOf(Empty, avntProperyIndex(ialngIndex))
    Next
    Rows(1).Font.Bold = True
    lngRow = 2
    For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
        Set objFolder = objShell.Namespace(CVar(astrFolders(ialngFolders)))
        For Each vntFile In objFolder.Items
            If LCase$(Right$(vntFile.Path, 5)) = ".xlsm" Then
                Cells(lngRow, 1).Value = vntFile.Path
                Cells(lngRow, 2).Value = vntFile.Name
                For ialngIndex = LBound(avntProperyIndex) To UBound(avntProperyIndex)
                    Cells(lngRow, lngColumn + ialngIndex).Value = _
                        objFolder.GetDetailsOf(vntFile, avntProperyIndex(ialngIndex))
                Next
                lngRow = lngRow + 1
            End If
        Next
    Next
    Columns.AutoFit
    Set objShell = Nothing
    Set objFolder = Nothing
    Application.ScreenUpdating = True
End Sub

Gruß
Nepumuk

Betrifft: AW: Dateiliste mit Dateieigenschaften Category
von: Thomas
Geschrieben am: 07.10.2020 11:30:50

danke, schau ich mir an.
du hast diese Zeilen eingefügt
lngColumn = 3
Cells(1, 1).Value = "Pfad"
Cells(1, 2).Value = "Name"

Cells(lngRow, 1).Value = vntFile.Path
Cells(lngRow, 2).Value = vntFile.Name


Betrifft: AW: Dateiliste mit Dateieigenschaften Category
von: Thomas
Geschrieben am: 07.10.2020 11:52:28

Dass
Dim vntFileName As Variant
nun
Dim vntFile As Variant
heißt, ist doch egal?

Betrifft: AW: Dateiliste mit Dateieigenschaften Category
von: max.kaffl@gmx.de
Geschrieben am: 07.10.2020 12:00:54

Hallo Thomas,

na ja, vntFile ist ein Objekt und kein Name. Daher die Änderung.

Gruß
Nepumuk

Betrifft: AW: Dateiliste mit Dateieigenschaften Category
von: Thomas
Geschrieben am: 07.10.2020 12:05:35

OK? D.h. der Rest funktioniert aber trotzdem, dass ich z.B. Author, Keywords, ect. abfragen kann? Dann baue ich das mal um und teste. Vielen herzlichen Dank.
Kann man das ganze Script performancemässig noch schneller machen? das Einlesen dauert schon eine Zeit. Wenn nicht, auch kein Problem... Hast mir schon sehr weit weitergeholfen.

Betrifft: AW: Dateiliste mit Dateieigenschaften Category
von: Nepumuk
Geschrieben am: 07.10.2020 12:11:29

Hallo Thomas,

ich könnte mit einem Array arbeiten, das würde aber nur ein paar Millisekunden sparen. Da lohnt sich der Aufwand nicht. Die meiste Zeit benötigt das Shell-Objekt und daran kann ich nichts ändern.

Gruß
Nepumuk

Betrifft: AW: Dateiliste mit Dateieigenschaften Category
von: Thomas
Geschrieben am: 07.10.2020 13:37:11

Ok... also ich habe das Script eingebaut und was soll ich sagen: es tut, was es tuen soll. Danke

Betrifft: AW: Dateiliste mit Dateieigenschaften Category
von: Thomas
Geschrieben am: 08.10.2020 11:10:42

also ich habe die Tabelle nun nach meinen Wünschen hinbekommen und konnte meine Ordner einlesen. Super - funktioniert.



Jetzt soll nach dem Einlesen eine Userform mit Suchfunktion aufpoppen. Ich habe diese bereits soweit in Griff und möchte diese nun pimpen. Im Anhand mal eine Beispieldatei.



Ich stoße aber auf folgendes Problem:



Ich kann im Suchfeld nach allem Möglichen suchen. Es wird in der Listbox auch danach über alle Zeilen/Spalten gesucht. Das Script fand ich bei herber.de. Super! Daneben habe ich eine Combobox die Anfangs leer ist und mir alle Einträge in der Listbox anzeigtt. Soweit so gut. Nun habe ich zwei "Filter" in der Combobox, die mir nach AUFTRAG und OHNE ABNR sucht und dabei einen Autofilter auf der SEARCH Tabelle setzt. Macht sie auch, aber die Filelist zeigt bei OHNE ABNR noch die erste Zeile von AUFTRAG an und unter AUFTRAG taucht OHNE ABNR auf? Obwohl ich nach der Filtersetzung nochmals die Liste initialisiere. Also neu einlese.



Desweiteren hätte ich gerne noch die Möglichkeit, dass beim Anklicken der SingleSelect Listbox die Zeile im Tabellenblatt Search angezeigt wird. Also ein GoTo Row Befehl und ggf. diese in einer andere Farbe markiert. Wenn ich allerdings wieder einen anderen anklicke, soll der zuvor ausgewählte wieder ohne Füllung sein.



Und last but not least: bei Übernehmen, nur die Einträge aus der Listbox auf Search Result anzeigen, wobei dann die komplette Zeile aus dem Tabellenblatt Search kopiert werden soll und nicht nur der Bereich der Listbox mit den 8 Feldern.



Ich werde später noch bei anklicken der Werte in der Listbox diese in der Userform in Textboxen anzeigen lassen.



Ich weiß, das ist einiges, aber ich bin halt nur ein Copy and modify Mensch was den VBA Code angeht. Bin ja schon froh, diese komplexe Funktionen verstanden zu haben und zum Laufen bekam.



https://www.herber.de/bbs/user/140725.xlsm

Betrifft: AW: Dateiliste mit Dateieigenschaften Category
von: Thomas
Geschrieben am: 09.10.2020 12:22:58

also ich komme nicht ganz weiter. Mein Suchfeld tut, was es tun soll. Aber die Option mit der ComboBox bekomme ich nicht hin. Es soll quasi im Listenfeld nur die Einträge aus der Tabelle Search angezeigt werden, die AUFTRAG oder OHNE ABNR haben. Wenn leer alle Einträge aus der Tabelle.

Irgendwo habe ich da einen Denkfehler. Ich habe die Scripte aus zwei Beispielen zusammengefügt.

Die Suche im Textfeld zeigt auf der gesamten Liste nur den Wert an, der irgendwo auf der Liste vorkommt. Das ist richtig.

Später würde ich ggf. noch zusätzliche Testboxen Suchfelder einbauen, um z.B. nur nach Spalte B und C zu suchen. Also nach den Auftragsnummern.



Und wie müsste ich mein Script erweitern, dass er mir nach einem OK Button direkt zur Zeile X auf Search springt?



Anbei meine ersten Versuche.

https://www.herber.de/bbs/user/140762.xlsm

Betrifft: AW: Dateiliste mit Dateieigenschaften Category
von: Thomas
Geschrieben am: 09.10.2020 13:37:32

ich habe es hinbekommen.
Private Sub ComboBox1_Change()
  Application.EnableEvents = False
  ListBox1.Clear
  With Sheets("Search")
    zeile = 5
    Do
      Zeichenkette = ""
      If Me.ComboBox1 = .Cells(zeile, 5) Or Me.ComboBox1 = "" Then
        For i = 1 To 9
          Zeichenkette = Zeichenkette & .Cells(zeile, i) & "#"
        Next i
        If InStr(1, UCase(Zeichenkette), UCase(Me.TextBox1)) > 0 Then
          ListBox1.AddItem .Cells(zeile, 9)
          lngAnzahl = ListBox1.ListCount
          ListBox1.List(lngAnzahl - 1, 1) = .Cells(zeile, 10)
          ListBox1.List(lngAnzahl - 1, 2) = .Cells(zeile, 11)
          ListBox1.List(lngAnzahl - 1, 3) = .Cells(zeile, 12)
          ListBox1.List(lngAnzahl - 1, 4) = .Cells(zeile, 4)
          ListBox1.List(lngAnzahl - 1, 5) = .Cells(zeile, 5)
          ListBox1.List(lngAnzahl - 1, 6) = .Cells(zeile, 17)
          ListBox1.List(lngAnzahl - 1, 7) = .Cells(zeile, 16)
          ListBox1.List(lngAnzahl - 1, 8) = .Cells(zeile, 2)
          ListBox1.List(lngAnzahl - 1, 9) = zeile
        End If
      End If
      zeile = zeile + 1
    Loop Until IsEmpty(.Cells(zeile, 2))
  End With
  
  Application.EnableEvents = True
End Sub


Private Sub CommandButton2_Click()
  
  Application.EnableEvents = False
  'Speichern in Listbox
   ListBox1.List(ListBox1.ListIndex, 1) = TextBox2
   ListBox1.List(ListBox1.ListIndex, 1) = TextBox3
   ListBox1.List(ListBox1.ListIndex, 2) = TextBox4
   ListBox1.List(ListBox1.ListIndex, 3) = TextBox5
   
  'Speichern in Tabell
  With Sheets("Search")
    zeile = ListBox1.List(ListBox1.ListIndex, 9)
    .Cells(zeile, 1) = Me.TextBox2
    .Cells(zeile, 2) = Me.TextBox3
    .Cells(zeile, 3) = Me.TextBox4
    .Cells(zeile, 4) = Me.TextBox5
  
  End With
  Application.EnableEvents = True
End Sub

Private Sub ListBox1_Click() 'Übergabe in Textboxen
TextBox2 = ListBox1.List(ListBox1.ListIndex, 0)
TextBox3 = ListBox1.List(ListBox1.ListIndex, 1)
TextBox4 = ListBox1.List(ListBox1.ListIndex, 2)
TextBox5 = ListBox1.List(ListBox1.ListIndex, 3)

End Sub


Private Sub TextBox1_Change()
Application.EnableEvents = False
  ListBox1.Clear
  With Sheets("Search")
    zeile = 5
    Do
      Zeichenkette = ""
      If Me.ComboBox1 = .Cells(zeile, 5) Or Me.ComboBox1 = "" Then
        For i = 1 To 9
          Zeichenkette = Zeichenkette & .Cells(zeile, i) & "#"
        Next i
        If InStr(1, UCase(Zeichenkette), UCase(Me.TextBox1)) > 0 Then
          ListBox1.AddItem .Cells(zeile, 9)
          lngAnzahl = ListBox1.ListCount
          ListBox1.List(lngAnzahl - 1, 1) = .Cells(zeile, 10)
          ListBox1.List(lngAnzahl - 1, 2) = .Cells(zeile, 11)
          ListBox1.List(lngAnzahl - 1, 3) = .Cells(zeile, 12)
          ListBox1.List(lngAnzahl - 1, 4) = .Cells(zeile, 4)
          ListBox1.List(lngAnzahl - 1, 5) = .Cells(zeile, 5)
          ListBox1.List(lngAnzahl - 1, 6) = .Cells(zeile, 17)
          ListBox1.List(lngAnzahl - 1, 7) = .Cells(zeile, 16)
          ListBox1.List(lngAnzahl - 1, 8) = .Cells(zeile, 2)
          ListBox1.List(lngAnzahl - 1, 9) = zeile
        End If
      End If
      zeile = zeile + 1
    Loop Until IsEmpty(.Cells(zeile, 2))
  End With
  
  Application.EnableEvents = True
End Sub

Private Sub UserForm_Initialize()
  
     
    With Me.ListBox1
     .ColumnCount = 10
     .ColumnWidths = "50;60;150;250;60;50;40;40;50;50"
     .Font.Size = 8
'     .BackColor = Sheets("Search").Range("A1").Interior.Color
'     .MultiSelect = fmMultiSelectSingle 'fmMultiSelectMulti
    End With

  
  
  With Sheets("Search")
    zeile = 5
    Do
      ListBox1.AddItem .Cells(zeile, 9)
      lngAnzahl = ListBox1.ListCount
      ListBox1.List(lngAnzahl - 1, 1) = .Cells(zeile, 10)
      ListBox1.List(lngAnzahl - 1, 2) = .Cells(zeile, 11)
      ListBox1.List(lngAnzahl - 1, 3) = .Cells(zeile, 12)
      ListBox1.List(lngAnzahl - 1, 4) = .Cells(zeile, 4)
      ListBox1.List(lngAnzahl - 1, 5) = .Cells(zeile, 5)
      ListBox1.List(lngAnzahl - 1, 6) = .Cells(zeile, 17)
      ListBox1.List(lngAnzahl - 1, 7) = .Cells(zeile, 16)
      ListBox1.List(lngAnzahl - 1, 8) = .Cells(zeile, 2)
      ListBox1.List(lngAnzahl - 1, 9) = zeile
      zeile = zeile + 1
    Loop Until IsEmpty(.Cells(zeile, 2))
  End With
  
  Me.ComboBox1.AddItem "AUFTRAG"
  Me.ComboBox1.AddItem "OHNE ABNR"
  
End Sub

Selektion funktioniert schon mal nach der ComboBox