ich habe aus diesem Forum soviel Nutzen gezogen, so dasz ich mich mit nachfolgendem Macro
bedanken möchte.
Code: Alles auswählen
REM ***** BASIC *****
'*************************************************************
'**** Katalog eines Ablageortes mit Unterverzeichnissen ******
'**** sortiert nach Verzeichnissen und Dateiendungen ******
'**** Anregungen stammen aus dem Openoffice- und ******
'**** LibreOffice-Forum. ******
'**** Die Programmsequenzen stammen ebenso von dort. ******
'**** Somit möchte ich mich mit diesem Macro bei ******
'**** allen aktiven Anwendern, deren Können und Wissen ******
'**** ich begierig aufgegriffen habe, bedanken. ******
'**** Mit Grusz Werner Gatzweiler ******
'*************************************************************
'*
Sub Verzeichnis_und_Unterverzeichnisse
Dim Liste(10000) as string
Dim Desktop as object
Dim Mappe as object
Dim Tabelle as object
Dim oColumn As Object
Dim oFolderPicker as object
Dim TeilStrings() as string
Dim TeilString as String
Dim sNamen As String
Dim sPath as String
Dim i as long
Dim j as Integer
Dim Zahl as Integer
Dim dummy()
Dim SortProps(2) As new com.sun.star.beans.PropertyValue
Dim SortFeld(1) As new com.sun.star.table.TableSortField
oFolderPicker = createUnoService("com.sun.star.ui.dialogs.FolderPicker")
oFolderPicker.execute
sPath = ConvertFromUrl(oFolderPicker.directory & "/") 'das Hauptverzeichnis
erg=getDirs(liste(),0,sPath) 'Anzahl der Ergebnisse
Desktop = CreateUnoService ("com.sun.star.frame.Desktop")
Mappe = Desktop.loadComponentFromURL("private:factory/scalc", "_blank", 0, dummy())
Tabelle = Mappe.getSheets().getbyIndex(0)
' Kopfzeile der Tabelle beschreiben
Tabelle.getCellbyPosition(0,0).string = sPath 'Der Hauptpfad
Tabelle.getCellbyPosition(1,0).string = "Dateipfad"
Tabelle.getCellbyPosition(2,0).string = "Dateiname"
Tabelle.getCellbyPosition(3,0).string = "Dateityp"
'Tabelle.getCellbyPosition(4,0).string = "Hyperlink"
i = 1
Do While i<erg
Teilstrings() = Split(liste(i),"/")
'nachfolgend der Dateipfad
'MsgBox UBOUND(Teilstrings) + 1 ' ergibt die Größe des Array
'msgbox liste(i)
sName=""
j=0
Do While j < UBOUND(Teilstrings)
sName = Trim(sName + Teilstrings(j)+"/")
j=j+1
Loop
'msgbox sName
'Tabelle.getCellbyPosition(1,i).string = ConvertFromURL(sName)
'nachfolgend das Schreiben von Hyperlink
Tabelle.getCellbyPosition(1,i).formulaLocal = "=HYPERLINK("+chr(34)+ConvertFromURL(sName)+chr(34)+")"
'nachfolgend das Auslesen des Dateitypes
On Error Resume next 'Ist nötig, wenn kein Teilstring durch "." gefunden wird.
sName() = Split(liste(i),".",Zahl)
'Zahl abfragen funktioniert nicht
Tabelle.getCellbyPosition(3,i).string = Trim(sName(1)) 'Dateitype
'nachfolgend das Auslesen des Dateinamens
Teilstrings() = Split(sName(0),"/")
'msgbox sName(0)
j=UBOUND(Teilstrings)
Tabelle.getCellbyPosition(2,i).string = Trim(TeilStrings(j))
'nachfolgend das Schreiben von Hyperlink
'Tabelle.getCellbyPosition(4,i).formulaLocal = "=HYPERLINK("+Tabelle.getCellbyPosition(1,i).AbsoluteName+")"
'msgbox chr(34)
'Tabelle.getCellbyPosition(1,i).formulaLocal = "=HYPERLINK("+chr(34)+Tabelle.getCellbyPosition(1,i).string+chr(34)+")"
i = i + 1
Zahl = i
Loop
msgbox "Verzeichnis mit Unterordner wurde ausgelesen !"
msgbox "Tabelle wird formatiert"
'Jetzt wirden die Spalten der Tabelle auf optimale Breite gesetzt
i=0
Do while i<4
oColumn = Tabelle.getColumns.getByIndex(i)
'Schriftwahl und Schriftgröße
oColumn.CharFontName="Comic Sans MS"
oColumn.CharHeight="10"
' optimal width
oColumn.setPropertyValue("OptimalWidth", True)
i = i+1
Loop
'Die Kopfzeile wird formatiert
Tabelle.getCellRangeByName("A1:E1").CharFontName="Comic Sans MS"
Tabelle.getCellRangeByName("A1:E1").CharHeight="12"
Tabelle.getCellRangeByName("A1:E1").CharWeight=com.sun.star.awt.FontWeight.BOLD
Tabelle.getCellRangeByName("A1:E1").horijustify=2 'Kopfzellen zentrieren
Antwort = Zahl-1 'Kopfzeile abgezogen
Print "Es gibt " + Antwort + " Dateien"
Print "Diese " + Antwort + " Dateien werden jetzt nach Ablageort und Dateiendung sortiert!"
'Beginn der Sortierung
SortierBereich = Tabelle.getCellRangeByName("B1:D"+Zahl)
SortFeld(0).Field = 0
SortFeld(0).IsAscending = True
SortFeld(0).FieldType = com.sun.star.util.SortFieldType.ALPHANUMERIC
SortFeld(1).Field = 2
SortFeld(1).IsAscending = True
SortFeld(1).FieldType = com.sun.star.util.SortFieldType.ALPHANUMERIC
SortProps(0).Name = "SortFields"
SortProps(0).Value = SortFeld()
SortProps(1).Name = "SortColumns"
SortProps(1).Value = False
SortProps(2).Name = "ContainsHeader"
SortProps(2).Value = true 'Die erste Zeile (Überschrift) wird nicht mit sortiert!
SortierBereich.Sort(SortProps())
Print "Die Sortierung ist beendet"
End Sub
'********** FUNKTIONEN *********************
FUNCTION CUTTER(LongText as string, Part as integer, optional Sign as string )
On Error Goto ErrorHandler
If IsMissing (Sign) Then
Sign = "/"
end if
TextParts = Split(LongText, sign)
CUTTER = TextParts (part)
exit Function
ErrorHandler:
CUTTER = "#NV"
End FUNCTION
function getdirs( liste(),z, folder) as integer
sFolderUrl = ConvertToUrl( Folder )
oSimpleFileAccess = createUnoService( "com.sun.star.ucb.SimpleFileAccess" )
aFolders = oSimpleFileAccess.getFolderContents( sFolderUrl,true )
For i = LBound( aFolders ) To UBound( aFolders )
sFile = aFolders( i )
If oSimpleFileAccess.isFolder( sFile ) Then
getdirs( liste(),z, sFile)
Else
liste(z)=sfile
z=z+1
end if
next i
getdirs=z
end function
Mit Grusz
Werner
(Gibt aber manchmal Programme, die sowas kreieren)