home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
DOS/V Power Report 2004 June
/
VPR0406.ISO
/
STARSUITE7
/
EVALUATION
/
windows
/
office7
/
f_0256
/
UCB.xba
< prev
Wrap
Extensible Markup Language
|
2003-03-27
|
9KB
|
281 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="UCB" 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
Dim bInterruptSearch as Boolean
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
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
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(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</script:module>