'Option explicit Public oDocument Dim oDocInfo as object Const SBMAXDIRCOUNT = 10 Dim CurDirMaxCount as Integer Dim sDirArray(SBMAXDIRCOUNT-1) as String Dim DirIndex As Integer Dim iDirCount as Integer Sub Main() Dim LocsfileContent(0) as String LocsfileContent(0) = "*" ReadDirectories("file:///space", LocsfileContent(), True, False, false) End Sub Function ReadDirectories(ByVal AnchorDir As String, bRecursive as Boolean, bcheckFileType as Boolean, bGetByTitle as Boolean, Optional sFileContent(), Optional sExtension as String) Dim i as integer Dim Status as Object Dim FileCountinDir as Integer Dim RealFileContent as String Dim FileName as string Dim oUcbObject as Object Dim DirContent() Dim CurIndex as Integer Dim MaxIndex as Integer Dim StartUbound as Integer Dim FileExtension as String StartUbound = 5 MaxIndex = StartUBound CurDirMaxCount = SBMAXDIRCOUNT Dim sFileArray(StartUbound,1) as String CurIndex = -1 ' Todo: Is the last separator valid? DirIndex = 0 sDirArray(iDirIndex) = AnchorDir iDirCount = 1 oDocInfo = CreateUnoService("com.sun.star.document.DocumentProperties") oUcbObject = createUnoService("com.sun.star.ucb.SimpleFileAccess") If oUcbObject.Exists(AnchorDir) Then Do AnchorDir = sDirArray(DirIndex) DirContent() = oUcbObject.GetFolderContents(AnchorDir,True) DirIndex = DirIndex + 1 If Ubound(DirContent()) <> -1 Then FileCountinDir = Ubound(DirContent())+ 1 For i = 0 to FilecountinDir -1 Filename = DirContent(i) If oUcbObject.IsFolder(FileName) Then If brecursive Then AddFoldertoList(FileName, DirIndex) End If Else If bcheckFileType Then RealFileContent = GetRealFileContent(oDocInfo, FileName) Else RealFileContent = GetFileNameExtension(FileName) End If If RealFileContent <> "" Then ' Retrieve the Index in the Array, where a Filename is positioned If Not IsMissing(sFileContent()) Then If (FieldinArray(sFileContent(), Ubound(sFileContent), RealFileContent)) Then ' The extension of the current file passes the filter and is therefor admitted to the ' fileList If Not IsMissing(sExtension) Then If sExtension <> "" Then ' Consider that some Formats like old StarOffice Templates with the extension ".vor" can only be ' precisely identified by their mimetype and their extension FileExtension = GetFileNameExtension(FileName) If FileExtension = sExtension Then AddFileNameToList(sFileArray(), FileName, RealFileContent, bGetByTitle, CurIndex) End If Else AddFileNameToList(sFileArray(), FileName, RealFileContent, bGetByTitle, CurIndex) End If Else AddFileNameToList(sFileArray(), FileName, RealFileContent, bGetByTitle, CurIndex) End If End If Else AddFileNameToList(sFileArray(), FileName, RealFileContent, bGetByTitle, CurIndex) End If If CurIndex = MaxIndex Then MaxIndex = MaxIndex + StartUbound ReDim Preserve sFileArray(MaxIndex,1) as String End If End If End If Next i End If Loop Until DirIndex >= iDirCount If CurIndex > -1 Then ReDim Preserve sFileArray(CurIndex,1) as String Else ReDim sFileArray() as String End If Else Msgbox("Directory '" & ConvertFromUrl(AnchorDir) & "' does not exist!", 16, GetProductName()) End If ReadDirectories() = sFileArray() End Function Sub AddFoldertoList(sDirURL as String, iDirIndex) iDirCount = iDirCount + 1 If iDirCount = CurDirMaxCount Then CurDirMaxCount = CurDirMaxCount + SBMAXDIRCOUNT ReDim Preserve sDirArray(CurDirMaxCount) as String End If sDirArray(iDirCount-1) = sDirURL End Sub Sub AddFileNameToList(sFileArray(), FileName as String, FileContent as String, bGetByTitle as Boolean, CurIndex) Dim FileCount As Integer CurIndex = CurIndex + 1 sFileArray(CurIndex,0) = FileName If bGetByTitle Then sFileArray(CurIndex,1) = RetrieveDocTitle(oDocInfo, FileName) ' Add the documenttitles to the Filearray Else sFileArray(CurIndex,1) = FileContent End If End Sub Function RetrieveDocTitle(oDocInfo as Object, sFileName as String) As String Dim sDocTitle as String On Local Error Goto NOFILE oDocInfo.Read(sFileName) sDocTitle = oDocInfo.Title NOFILE: If Err <> 0 Then GetRealFileContent = "" RESUME CLR_ERROR End If CLR_ERROR: If sDocTitle = "" Then sDocTitle = GetFileNameWithoutExtension(sFilename, "/") End If RetrieveDocTitle = sDocTitle End Function ' Retrieves The Filecontent of a Document by extracting the content ' from the Header of the document Function GetRealFileContent(oDocInfo as Object, FileName as String) As String On Local Error Goto NOFILE oDocInfo.Read(FileName) GetRealFileContent = oDocInfo.MIMEType NOFILE: If Err <> 0 Then GetRealFileContent = "" resume CLR_ERROR End If CLR_ERROR: End Function Function CopyRecursively(SourceFilePath as String, SourceStemDir as String, TargetStemDir as String) Dim TargetDir as String Dim TargetFile as String TargetFile= ReplaceString(SourceFilePath, TargetStemDir, SourceStemDir) TargetFileName = FileNameoutofPath(TargetFile,"/") TargetDir = DeleteStr(TargetFile, TargetFileName) CreateFolder(TargetDir) CopyRecursively() = TargetFile End Function ' Opens a help url referenced by a Help ID that is retrieved from the calling button tag Sub ShowHelperDialog(aEvent) Dim oSystemNode as Object Dim sSystem as String Dim oLanguageNode as Object Dim sLocale as String Dim sLocaleList() as String Dim sLanguage as String Dim sHelpUrl as String Dim sDocType as String HelpID = aEvent.Source.Model.Tag oLocDocument = StarDesktop.ActiveFrame.Controller.Model sDocType = GetDocumentType(oLocDocument) oSystemNode = GetRegistryKeyContent("org.openoffice.Office.Common/Help") sSystem = oSystemNode.GetByName("System") oLanguageNode = GetRegistryKeyContent("org.openoffice.Setup/L10N/") sLocale = oLanguageNode.getByName("ooLocale") sLocaleList() = ArrayoutofString(sLocale, "-") sLanguage = sLocaleList(0) sHelpUrl = "vnd.sun.star.help://" & sDocType & "/" & HelpID & "?Language=" & sLanguage & "&System=" & sSystem StarDesktop.LoadComponentfromUrl(sHelpUrl, "OFFICE_HELP", 63, NoArgs()) End Sub Sub SaveDataToFile(FilePath as String, DataList()) Dim FileChannel as Integer Dim i as Integer Dim oFile as Object Dim oOutputStream as Object Dim oStreamString as Object Dim oUcb as Object Dim sCRLF as String sCRLF = CHR(13) & CHR(10) oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess") oOutputStream = createUnoService("com.sun.star.io.TextOutputStream") If oUcb.Exists(FilePath) Then oUcb.Kill(FilePath) End If oFile = oUcb.OpenFileReadWrite(FilePath) oOutputStream.SetOutputStream(oFile.GetOutputStream) For i = 0 To Ubound(DataList()) oOutputStream.WriteString(DataList(i) & sCRLF) Next i oOutputStream.CloseOutput() End Sub Function LoadDataFromFile(FilePath as String, DataList()) as Boolean Dim oInputStream as Object Dim i as Integer Dim oUcb as Object Dim oFile as Object Dim MaxIndex as Integer oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess") If oUcb.Exists(FilePath) Then MaxIndex = 10 oInputStream = createUnoService("com.sun.star.io.TextInputStream") oFile = oUcb.OpenFileReadWrite(FilePath) oInputStream.SetInputStream(oFile.GetInputStream) i = -1 Redim Preserve DataList(MaxIndex) While Not oInputStream.IsEOF i = i + 1 If i > MaxIndex Then MaxIndex = MaxIndex + 10 Redim Preserve DataList(MaxIndex) End If DataList(i) = oInputStream.ReadLine Wend If i > -1 And i <> MaxIndex Then Redim Preserve DataList(i) End If LoadDataFromFile() = True oInputStream.CloseInput() Else LoadDataFromFile() = False End If End Function Function CreateFolder(sNewFolder) as Boolean Dim oUcb as Object oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess") On Local Error Goto NOSPACEONDRIVE If Not oUcb.Exists(sNewFolder) Then oUcb.CreateFolder(sNewFolder) End If CreateFolder = True NOSPACEONDRIVE: If Err <> 0 Then If InitResources("", "com") Then ErrMsg = GetResText(1000) ErrMsg = ReplaceString(ErrMsg, chr(13), "<BR>") ErrMsg = ReplaceString(ErrMsg, sNewFolder, "%1") Msgbox(ErrMsg, 48, GetProductName()) End If CreateFolder = False Resume GOON End If GOON: End Function