Quelle  UCB.xba   Sprache: unbekannt

<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
<!--
 * This file is part of the LibreOffice project.
 *
 * This Source Code Form is subject to the terms of the Mozilla Public
 * License, v. 2.0. If a copy of the MPL was not distributed with this
 * file, You can obtain one at http://mozilla.org/MPL/2.0/.
 *
 * This file incorporates work covered by the following license notice:
 *
 *   Licensed to the Apache Software Foundation (ASF) under one or more
 *   contributor license agreements. See the NOTICE file distributed
 *   with this work for additional information regarding copyright
 *   ownership. The ASF licenses this file to you under the Apache
 *   License, Version 2.0 (the "License"); you may not use this file
 *   except in compliance with the License. You may obtain a copy of
 *   the License at http://www.apache.org/licenses/LICENSE-2.0 .
-->
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="UCB" script:language="StarBasic">'Option explicit
Public oDocument
Public oDocInfo as object
Const SBMAXDIRCOUNT = 10
Dim CurDirMaxCount as Integer
Dim sDirArray(SBMAXDIRCOUNT-1) as String
Dim DirIndex As Integer
Dim iDirCount as Integer
Public bInterruptSearch as Boolean
Public NoArgs()as New com.sun.star.beans.PropertyValue

Sub Main()
Dim LocsfileContent(0) as String
 LocsfileContent(0) = "*"
 ReadDirectories("file:///space", LocsfileContent(), True, False, false)
End Sub

'        ReadDirectories(      sSourceDir,          bRecursive,          bCheckRealType, False, sFileContent(), sLocExtension)

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
 On Local Error Goto FILESYSTEMPROBLEM:
 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)
   On Local Error Resume Next
   DirContent() = oUcbObject.GetFolderContents(AnchorDir,True)
   DirIndex = DirIndex + 1
   On Local Error Goto 0
   On Local Error Goto FILESYSTEMPROBLEM:
   If Ubound(DirContent()) <> -1 Then
    FileCountinDir = Ubound(DirContent())+ 1
    For i = 0 to FilecountinDir -1
     If bInterruptSearch = True Then
      Exit Do
     End If
     
     Filename = DirContent(i)
     If oUcbObject.IsFolder(FileName) Then
      If brecursive Then
       AddFoldertoList(FileName, DirIndex)
      End If
     Else
      If bcheckFileType Then
       RealFileContent = GetRealFileContent(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 therefore 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()
 Exit Function

 FILESYSTEMPROBLEM:
 Msgbox("Sorry, Filesystem Problem")
 ReadDirectories() = sFileArray()
 Resume LEAVEPROC
 LEAVEPROC:
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(oDocProps as Object, sFileName as String) As String
Dim sDocTitle as String
 On Local Error Goto NOFILE
 oDocProps.loadFromMedium(sFileName, NoArgs())
 sDocTitle = oDocProps.Title
 NOFILE:
 If Err <> 0 Then
  RetrieveDocTitle = ""
  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(FileName as String) As String
 On Local Error Goto NOFILE
 oTypeDetect = createUnoService("com.sun.star.document.TypeDetection")
 GetRealFileContent = oTypeDetect.queryTypeByURL(FileName)
 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("") Then
   ErrMsg = GetResText("RID_COMMON_0")
   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
</script:module>