1<?xml version="1.0" encoding="UTF-8"?> 2<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd"> 3<!--*********************************************************** 4 * 5 * Licensed to the Apache Software Foundation (ASF) under one 6 * or more contributor license agreements. See the NOTICE file 7 * distributed with this work for additional information 8 * regarding copyright ownership. The ASF licenses this file 9 * to you under the Apache License, Version 2.0 (the 10 * "License"); you may not use this file except in compliance 11 * with the License. You may obtain a copy of the License at 12 * 13 * http://www.apache.org/licenses/LICENSE-2.0 14 * 15 * Unless required by applicable law or agreed to in writing, 16 * software distributed under the License is distributed on an 17 * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 18 * KIND, either express or implied. See the License for the 19 * specific language governing permissions and limitations 20 * under the License. 21 * 22 ***********************************************************--> 23<script:module xmlns:script="http://openoffice.org/2000/script" script:name="UCB" script:language="StarBasic">'Option explicit 24Public oDocument 25Public oDocInfo as object 26Const SBMAXDIRCOUNT = 10 27Dim CurDirMaxCount as Integer 28Dim sDirArray(SBMAXDIRCOUNT-1) as String 29Dim DirIndex As Integer 30Dim iDirCount as Integer 31Public bInterruptSearch as Boolean 32Public NoArgs()as New com.sun.star.beans.PropertyValue 33 34Sub Main() 35Dim LocsfileContent(0) as String 36 LocsfileContent(0) = "*" 37 ReadDirectories("file:///space", LocsfileContent(), True, False, false) 38End Sub 39 40' ReadDirectories( sSourceDir, bRecursive, bCheckRealType, False, sFileContent(), sLocExtension) 41 42Function ReadDirectories(ByVal AnchorDir As String, bRecursive as Boolean, bcheckFileType as Boolean, bGetByTitle as Boolean, Optional sFileContent(), Optional sExtension as String) 43Dim i as integer 44Dim Status as Object 45Dim FileCountinDir as Integer 46Dim RealFileContent as String 47Dim FileName as string 48Dim oUcbObject as Object 49Dim DirContent() 50Dim CurIndex as Integer 51Dim MaxIndex as Integer 52Dim StartUbound as Integer 53Dim FileExtension as String 54 StartUbound = 5 55 MaxIndex = StartUBound 56 CurDirMaxCount = SBMAXDIRCOUNT 57Dim sFileArray(StartUbound,1) as String 58 On Local Error Goto FILESYSTEMPROBLEM: 59 CurIndex = -1 60 ' Todo: Is the last separator valid? 61 DirIndex = 0 62 sDirArray(iDirIndex) = AnchorDir 63 iDirCount = 1 64 oDocInfo = CreateUnoService("com.sun.star.document.DocumentProperties") 65 oUcbObject = createUnoService("com.sun.star.ucb.SimpleFileAccess") 66 If oUcbObject.Exists(AnchorDir) Then 67 Do 68 AnchorDir = sDirArray(DirIndex) 69 On Local Error Resume Next 70 DirContent() = oUcbObject.GetFolderContents(AnchorDir,True) 71 DirIndex = DirIndex + 1 72 On Local Error Goto 0 73 On Local Error Goto FILESYSTEMPROBLEM: 74 If Ubound(DirContent()) <> -1 Then 75 FileCountinDir = Ubound(DirContent())+ 1 76 For i = 0 to FilecountinDir -1 77 If bInterruptSearch = True Then 78 Exit Do 79 End If 80 81 Filename = DirContent(i) 82 If oUcbObject.IsFolder(FileName) Then 83 If brecursive Then 84 AddFoldertoList(FileName, DirIndex) 85 End If 86 Else 87 If bcheckFileType Then 88 RealFileContent = GetRealFileContent(FileName) 89 Else 90 RealFileContent = GetFileNameExtension(FileName) 91 End If 92 If RealFileContent <> "" Then 93 ' Retrieve the Index in the Array, where a Filename is positioned 94 If Not IsMissing(sFileContent()) Then 95 If (FieldinArray(sFileContent(), Ubound(sFileContent), RealFileContent)) Then 96 ' The extension of the current file passes the filter and is therefor admitted to the 97 ' fileList 98 If Not IsMissing(sExtension) Then 99 If sExtension <> "" Then 100 ' Consider that some Formats like old StarOffice Templates with the extension ".vor" can only be 101 ' precisely identified by their mimetype and their extension 102 FileExtension = GetFileNameExtension(FileName) 103 If FileExtension = sExtension Then 104 AddFileNameToList(sFileArray(), FileName, RealFileContent, bGetByTitle, CurIndex) 105 End If 106 Else 107 AddFileNameToList(sFileArray(), FileName, RealFileContent, bGetByTitle, CurIndex) 108 End If 109 Else 110 AddFileNameToList(sFileArray(), FileName, RealFileContent, bGetByTitle, CurIndex) 111 End If 112 End If 113 Else 114 AddFileNameToList(sFileArray(), FileName, RealFileContent, bGetByTitle, CurIndex) 115 End If 116 If CurIndex = MaxIndex Then 117 MaxIndex = MaxIndex + StartUbound 118 ReDim Preserve sFileArray(MaxIndex,1) as String 119 End If 120 End If 121 End If 122 Next i 123 End If 124 Loop Until DirIndex >= iDirCount 125 If CurIndex > -1 Then 126 ReDim Preserve sFileArray(CurIndex,1) as String 127 Else 128 ReDim sFileArray() as String 129 End If 130 Else 131 Msgbox("Directory '" & ConvertFromUrl(AnchorDir) & "' does not exist!", 16, GetProductName()) 132 End If 133 ReadDirectories() = sFileArray() 134 Exit Function 135 136 FILESYSTEMPROBLEM: 137 Msgbox("Sorry, Filesystem Problem") 138 ReadDirectories() = sFileArray() 139 Resume LEAVEPROC 140 LEAVEPROC: 141End Function 142 143 144Sub AddFoldertoList(sDirURL as String, iDirIndex) 145 iDirCount = iDirCount + 1 146 If iDirCount = CurDirMaxCount Then 147 CurDirMaxCount = CurDirMaxCount + SBMAXDIRCOUNT 148 ReDim Preserve sDirArray(CurDirMaxCount) as String 149 End If 150 sDirArray(iDirCount-1) = sDirURL 151End Sub 152 153 154Sub AddFileNameToList(sFileArray(), FileName as String, FileContent as String, bGetByTitle as Boolean, CurIndex) 155Dim FileCount As Integer 156 CurIndex = CurIndex + 1 157 sFileArray(CurIndex,0) = FileName 158 If bGetByTitle Then 159 sFileArray(CurIndex,1) = RetrieveDocTitle(oDocInfo, FileName) 160 ' Add the documenttitles to the Filearray 161 Else 162 sFileArray(CurIndex,1) = FileContent 163 End If 164End Sub 165 166 167Function RetrieveDocTitle(oDocProps as Object, sFileName as String) As String 168Dim sDocTitle as String 169 On Local Error Goto NOFILE 170 oDocProps.loadFromMedium(sFileName, NoArgs()) 171 sDocTitle = oDocProps.Title 172 NOFILE: 173 If Err <> 0 Then 174 RetrieveDocTitle = "" 175 RESUME CLR_ERROR 176 End If 177 CLR_ERROR: 178 If sDocTitle = "" Then 179 sDocTitle = GetFileNameWithoutExtension(sFilename, "/") 180 End If 181 RetrieveDocTitle = sDocTitle 182End Function 183 184 185' Retrieves The Filecontent of a Document by extracting the content 186' from the Header of the document 187Function GetRealFileContent(FileName as String) As String 188 On Local Error Goto NOFILE 189 oTypeDetect = createUnoService("com.sun.star.document.TypeDetection") 190 GetRealFileContent = oTypeDetect.queryTypeByURL(FileName) 191 NOFILE: 192 If Err <> 0 Then 193 GetRealFileContent = "" 194 resume CLR_ERROR 195 End If 196 CLR_ERROR: 197End Function 198 199 200Function CopyRecursively(SourceFilePath as String, SourceStemDir as String, TargetStemDir as String) 201Dim TargetDir as String 202Dim TargetFile as String 203 204 TargetFile= ReplaceString(SourceFilePath, TargetStemDir, SourceStemDir) 205 TargetFileName = FileNameoutofPath(TargetFile,"/") 206 TargetDir = DeleteStr(TargetFile, TargetFileName) 207 CreateFolder(TargetDir) 208 CopyRecursively() = TargetFile 209End Function 210 211 212' Opens a help url referenced by a Help ID that is retrieved from the calling button tag 213Sub ShowHelperDialog(aEvent) 214Dim oSystemNode as Object 215Dim sSystem as String 216Dim oLanguageNode as Object 217Dim sLocale as String 218Dim sLocaleList() as String 219Dim sLanguage as String 220Dim sHelpUrl as String 221Dim sDocType as String 222 HelpID = aEvent.Source.Model.Tag 223 oLocDocument = StarDesktop.ActiveFrame.Controller.Model 224 sDocType = GetDocumentType(oLocDocument) 225 oSystemNode = GetRegistryKeyContent("org.openoffice.Office.Common/Help") 226 sSystem = oSystemNode.GetByName("System") 227 oLanguageNode = GetRegistryKeyContent("org.openoffice.Setup/L10N/") 228 sLocale = oLanguageNode.getByName("ooLocale") 229 sLocaleList() = ArrayoutofString(sLocale, "-") 230 sLanguage = sLocaleList(0) 231 sHelpUrl = "vnd.sun.star.help://" & sDocType & "/" & HelpID & "?Language=" & sLanguage & "&System=" & sSystem 232 StarDesktop.LoadComponentfromUrl(sHelpUrl, "OFFICE_HELP", 63, NoArgs()) 233End Sub 234 235 236Sub SaveDataToFile(FilePath as String, DataList()) 237Dim FileChannel as Integer 238Dim i as Integer 239Dim oFile as Object 240Dim oOutputStream as Object 241Dim oStreamString as Object 242Dim oUcb as Object 243Dim sCRLF as String 244 245 sCRLF = CHR(13) & CHR(10) 246 oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess") 247 oOutputStream = createUnoService("com.sun.star.io.TextOutputStream") 248 If oUcb.Exists(FilePath) Then 249 oUcb.Kill(FilePath) 250 End If 251 oFile = oUcb.OpenFileReadWrite(FilePath) 252 oOutputStream.SetOutputStream(oFile.GetOutputStream) 253 For i = 0 To Ubound(DataList()) 254 oOutputStream.WriteString(DataList(i) & sCRLF) 255 Next i 256 oOutputStream.CloseOutput() 257End Sub 258 259 260Function LoadDataFromFile(FilePath as String, DataList()) as Boolean 261Dim oInputStream as Object 262Dim i as Integer 263Dim oUcb as Object 264Dim oFile as Object 265Dim MaxIndex as Integer 266 oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess") 267 If oUcb.Exists(FilePath) Then 268 MaxIndex = 10 269 oInputStream = createUnoService("com.sun.star.io.TextInputStream") 270 oFile = oUcb.OpenFileReadWrite(FilePath) 271 oInputStream.SetInputStream(oFile.GetInputStream) 272 i = -1 273 Redim Preserve DataList(MaxIndex) 274 While Not oInputStream.IsEOF 275 i = i + 1 276 If i > MaxIndex Then 277 MaxIndex = MaxIndex + 10 278 Redim Preserve DataList(MaxIndex) 279 End If 280 DataList(i) = oInputStream.ReadLine 281 Wend 282 If i > -1 And i <> MaxIndex Then 283 Redim Preserve DataList(i) 284 End If 285 LoadDataFromFile() = True 286 oInputStream.CloseInput() 287 Else 288 LoadDataFromFile() = False 289 End If 290End Function 291 292 293Function CreateFolder(sNewFolder) as Boolean 294Dim oUcb as Object 295 oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess") 296 On Local Error Goto NOSPACEONDRIVE 297 If Not oUcb.Exists(sNewFolder) Then 298 oUcb.CreateFolder(sNewFolder) 299 End If 300 CreateFolder = True 301NOSPACEONDRIVE: 302 If Err <> 0 Then 303 If InitResources("", "dbw") Then 304 ErrMsg = GetResText(500) 305 ErrMsg = ReplaceString(ErrMsg, chr(13), "<BR>") 306 ErrMsg = ReplaceString(ErrMsg, sNewFolder, "%1") 307 Msgbox(ErrMsg, 48, GetProductName()) 308 End If 309 CreateFolder = False 310 Resume GOON 311 End If 312GOON: 313End Function 314</script:module> 315