http://user.services.openoffice.org/en/ ... =9&t=41211
There is plenty of room for errors here but I've tried to trap the obvious ones. If the macro does not report "Done" within a second or two then an error has occurred and you should kill the macro.
You decide:
the directory,
sub-directories or files,
if files, what type,
where the list starts and
whether it is in rows or columns.
Code: Select all
Sub ListSubDirectoriesOrFiles
Dim url,sAns,iAns,a,DorF,oDoc,oSheet,Dname,Col,Row
url = "C:\users\cat\" 'Enter your basic path here. You can not list anything from these named directories.
oDoc = ThisComponent
oSheet = oDoc.Sheets(0) 'Sheet1
Directory:
sAns = InputBox("Enter directory name." & Chr(13) & Chr(13) & "Examples: documents or documents\embroidery designs"
If sAns = "" then MsgBox "Cancel pressed. Quitting." : End
url = ConvertToURL(url & sAns)
If Not FileExists(url) then MsgBox "No such directory. Try again." : Goto Directory
a = "List the names of what?" & Chr(13) & "Yes = sub-directories" & Chr(13) & "No = files"
iAns = MsgBox(a,4,"List what?")
If iAns = 7 then
DorF = 0
Else DorF = 16
EndIf
ext = "*"
If DorF = 0 then
ext1 = InputBox("Enter the desired file type extention. Examples: odt for Writer files or * for all files."
If ext1 = "" then MsgBox("Cancel pressed. Quitting.") : End
ext = ext & "." & ext1
EndIf
InitialCell:
Cname = InputBox("Enter the name of the cell that should recieve the initial name, e.g., A2.","Start list where?")
If Cname = "" then MsgBox("No entry made. Quitting.") : End
On Error goto E1
oCell = oSheet.getCellRangeByName(Cname)
a = "List should go in what direction?" & Chr(13) & "Yes = down" & Chr(13) & "No = across"
iAns = MsgBox(a,4,"List down or across?")
If iAns = 7 then
DA = "A"
Else DA = "D"
EndIf
url = url & "/" & ext
Col = oCell.CellAddress.Column
Row = oCell.CellAddress.Row
Dname = Dir(url,DorF)
Do While Dname <> ""
If Dname <> "." And Dname <> ".." then
oCell = oSheet.GetCellByPosition(Col,Row)
oCell.String = Dname
If DA = "D" then
Row = Row + 1
Else Col = Col +1
EndIf
EndIf
Dname = Dir
Loop
MsgBox "Done"
End
E1:
MsgBox "'" & Cname & "' is an illegal cell name. Try again." : Goto InitialCell
End Sub