Kompuutteri Kaikille K-CD 2002 #3/K-CD_2002-03.iso/OpenOffice/f_0180/UCB.xba

Extensible Markup Language | 2001-10-12 | 9KB | 255 lines

<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Recursive" script:language="StarBasic">'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


' Prozedur, die die rekursive Auslesefunktion anwirft
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")
    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
    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 oUcb as Object
Dim TargetDir as String
Dim TargetFile as String

    oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess")
    TargetFile= ReplaceString(SourceFilePath, TargetStemDir, SourceStemDir)
    TargetFileName = FileNameoutofPath(TargetFile,"/")
    TargetDir = DeleteStr(TargetFile, TargetFileName)
    If Not oUcb.Exists(TargetDir) Then
        oUcb.CreateFolder(TargetDir)
    End If
    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(10) & CHR(13)
    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
        oOutputStream.CloseInput()
    Else
        LoadDataFromFile() = False
    End If
End Function
</script:module>