Dokumentation: Projekt Kundenverwaltung (2009 - ) Modul: UCB

Details
Kategorie: Archivierte Beiträge
'Kundenverwaltung.odb Modul UCB
'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("", "dbw") Then
            ErrMsg = GetResText(500)
            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
Zugriffe: 548