ToolTech/tool-tech
6
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

update

Browse Source
This commit is contained in:
Jane
2024-07-16 15:55:31 +08:00
parent 8f4ec86367
commit 29bc31ade5
12411 changed files with 8139339 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

253
tool-tech-file-view/LibreOfficePortable/App/libreoffice/share/basic/Tools/Debug.xba Normal file
View File

@@ -0,0 +1,253 @@
<?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="Debug" script:language="StarBasic">REM ***** BASIC *****
Sub ActivateReadOnlyFlag()
SetBasicReadOnlyFlag(True)
End Sub
Sub DeactivateReadOnlyFlag()
SetBasicReadOnlyFlag(False)
End Sub
Sub SetBasicReadOnlyFlag(bReadOnly as Boolean)
Dim i as Integer
Dim LibName as String
Dim BasicLibNames() as String
BasicLibNames() = BasicLibraries.ElementNames()
For i = 0 To Ubound(BasicLibNames())
LibName = BasicLibNames(i)
If LibName &lt;&gt; &quot;Standard&quot; Then
BasicLibraries.SetLibraryReadOnly(LibName, bReadOnly)
End If
Next i
End Sub
Sub WritedbgInfo(LocObject as Object)
Dim locUrl as String
Dim oLocDocument as Object
Dim oLocText as Object
Dim oLocCursor as Object
Dim NoArgs()
Dim sObjectStrings(2) as String
Dim sProperties() as String
Dim n as Integer
Dim m as Integer
Dim MaxIndex as Integer
sObjectStrings(0) = LocObject.dbg_Properties
sObjectStrings(1) = LocObject.dbg_Methods
sObjectStrings(2) = LocObject.dbg_SupportedInterfaces
LocUrl = &quot;private:factory/swriter&quot;
oLocDocument = StarDesktop.LoadComponentFromURL(LocUrl,&quot;_default&quot;,0,NoArgs)
oLocText = oLocDocument.text
oLocCursor = oLocText.createTextCursor()
oLocCursor.gotoStart(False)
If Vartype(LocObject) = 9 then &apos; an Object Variable
For n = 0 To 2
sProperties() = ArrayoutofString(sObjectStrings(n),&quot;;&quot;, MaxIndex)
For m = 0 To MaxIndex
oLocText.insertString(oLocCursor,sProperties(m),False)
oLocText.insertControlCharacter(oLocCursor,com.sun.star.text.ControlCharacter.PARAGRAPH_BREAK,False)
Next m
Next n
Elseif Vartype(LocObject) = 8 Then &apos; a String Variable
oLocText.insertString(oLocCursor,LocObject,False)
ElseIf Vartype(LocObject) = 1 Then
Msgbox(&quot;Variable is Null!&quot;, 16, GetProductName())
End If
End Sub
Sub WriteDbgString(LocString as string)
Dim oLocDesktop as object
Dim LocUrl as String
Dim oLocDocument as Object
Dim oLocCursor as Object
Dim oLocText as Object
LocUrl = &quot;private:factory/swriter&quot;
oLocDocument = StarDesktop.LoadComponentFromURL(LocUrl,&quot;_default&quot;,0,NoArgs)
oLocText = oLocDocument.text
oLocCursor = oLocText.createTextCursor()
oLocCursor.gotoStart(False)
oLocText.insertString(oLocCursor,LocString,False)
End Sub
Sub printdbgInfo(LocObject)
If Vartype(LocObject) = 9 then
Msgbox LocObject.dbg_properties
Msgbox LocObject.dbg_methods
Msgbox LocObject.dbg_supportedinterfaces
Elseif Vartype(LocObject) = 8 Then &apos; a String Variable
Msgbox LocObject
ElseIf Vartype(LocObject) = 0 Then
Msgbox(&quot;Variable is Null!&quot;, 16, GetProductName())
Else
Msgbox(&quot;Type of Variable: &quot; &amp; Typename(LocObject), 48, GetProductName())
End If
End Sub
Sub ShowArray(LocArray())
Dim i as integer
Dim msgstring
msgstring = &quot;&quot;
For i = Lbound(LocArray()) to Ubound(LocArray())
msgstring = msgstring + LocArray(i) + chr(13)
Next
Msgbox msgstring
End Sub
Sub ShowPropertyValues(oLocObject as Object)
Dim PropName as String
Dim sValues as String
On Local Error Goto NOPROPERTYSETINFO:
sValues = &quot;&quot;
For i = 0 To Ubound(oLocObject.PropertySetInfo.Properties)
Propname = oLocObject.PropertySetInfo.Properties(i).Name
sValues = sValues &amp; PropName &amp; chr(13) &amp; &quot; = &quot; &amp; oLocObject.GetPropertyValue(PropName) &amp; chr(13)
Next i
Msgbox(sValues , 64, GetProductName())
Exit Sub
NOPROPERTYSETINFO:
Msgbox(&quot;Sorry, No PropertySetInfo attached to the object&quot;, 16, GetProductName())
Resume LEAVEPROC
LEAVEPROC:
End Sub
Sub ShowNameValuePair(Pair())
Dim i as Integer
Dim ShowString as String
ShowString = &quot;&quot;
On Local Error Resume Next
For i = 0 To Ubound(Pair())
ShowString = ShowString &amp; Pair(i).Name &amp; &quot; = &quot;
ShowString = ShowString &amp; Pair(i).Value &amp; chr(13)
Next i
Msgbox ShowString
End Sub
&apos; Retrieves all the Elements of aSequence of an object, with the
&apos; possibility to define a filter(sfilter &lt;&gt; &quot;&quot;)
Sub ShowElementNames(oLocElements() as Object, Optional sFiltername as String)
Dim i as Integer
Dim NameString as String
NameString = &quot;&quot;
For i = 0 To Ubound(oLocElements())
If Not IsMissIng(sFilterName) Then
If Instr(1, oLocElements(i), sFilterName) Then
NameString = NameString &amp; oLocElements(i) &amp; chr(13)
End If
Else
NameString = NameString &amp; oLocElements(i) &amp; chr(13)
End If
Next i
Msgbox(NameString, 64, GetProductName())
End Sub
&apos; Retrieves all the supported servicenames of an object, with the
&apos; possibility to define a filter(sfilter &lt;&gt; &quot;&quot;)
Sub ShowSupportedServiceNames(oLocObject as Object, Optional sFilterName as String)
On Local Error Goto NOSERVICENAMES
If IsMissing(sFilterName) Then
ShowElementNames(oLocobject.SupportedServiceNames())
Else
ShowElementNames(oLocobject.SupportedServiceNames(), sFilterName)
End If
Exit Sub
NOSERVICENAMES:
Msgbox(&quot;Sorry, No &apos;SupportedServiceNames&apos; - Property attached to the object&quot;, 16, GetProductName())
Resume LEAVEPROC
LEAVEPROC:
End Sub
&apos; Retrieves all the available Servicenames of an object, with the
&apos; possibility to define a filter(sfilter &lt;&gt; &quot;&quot;)
Sub ShowAvailableServiceNames(oLocObject as Object, Optional sFilterName as String)
On Local Error Goto NOSERVICENAMES
If IsMissing(sFilterName) Then
ShowElementNames(oLocobject.AvailableServiceNames)
Else
ShowElementNames(oLocobject.AvailableServiceNames, sFilterName)
End If
Exit Sub
NOSERVICENAMES:
Msgbox(&quot;Sorry, No &apos;AvailableServiceNames&apos; - Property attached to the object&quot;, 16, GetProductName())
Resume LEAVEPROC
LEAVEPROC:
End Sub
Sub ShowCommands(oLocObject as Object)
On Local Error Goto NOCOMMANDS
ShowElementNames(oLocObject.QueryCommands)
Exit Sub
NOCOMMANDS:
Msgbox(&quot;Sorry, No &apos;QueryCommands&apos; - Property attached to the object&quot;, 16, GetProductName())
Resume LEAVEPROC
LEAVEPROC:
End Sub
Sub ProtectCurrentSheets()
Dim oDocument as Object
Dim sDocType as String
Dim iResult as Integer
Dim oSheets as Object
Dim i as Integer
Dim bDoProtect as Boolean
oDocument = StarDesktop.ActiveFrame.Controller.Model
sDocType = GetDocumentType(oDocument)
If sDocType = &quot;scalc&quot; Then
oSheets = oDocument.Sheets
bDoProtect = False
For i = 0 To oSheets.Count-1
If Not oSheets(i).IsProtected Then
bDoProtect = True
End If
Next i
If bDoProtect Then
iResult = Msgbox( &quot;Do you want to protect all sheets of this document?&quot;,35, GetProductName())
If iResult = 6 Then
ProtectSheets(oDocument.Sheets)
End If
End If
End If
End Sub
Sub FillDocument()
oMyReport = createUNOService(&quot;com.sun.star.wizards.report.CallReportWizard&quot;)
oMyReport.trigger(&quot;fill&quot;)
End Sub
</script:module>

34
tool-tech-file-view/LibreOfficePortable/App/libreoffice/share/basic/Tools/DlgOverwriteAll.xdl Normal file
View File

@@ -0,0 +1,34 @@
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE dlg:window PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "dialog.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 .
-->
<dlg:window xmlns:dlg="http://openoffice.org/2000/dialog" xmlns:script="http://openoffice.org/2000/script" dlg:id="DlgOverwriteAll" dlg:left="138" dlg:top="75" dlg:width="230" dlg:height="64" dlg:closeable="true" dlg:moveable="true">
<dlg:bulletinboard>
<dlg:text dlg:id="lblQueryforSave" dlg:tab-index="0" dlg:left="6" dlg:top="6" dlg:width="218" dlg:height="36" dlg:value="lblQueryforSave" dlg:multiline="true"/>
<dlg:button dlg:id="cmdYes" dlg:tab-index="1" dlg:left="6" dlg:top="43" dlg:width="50" dlg:height="14" dlg:value="cmdYes">
<script:event script:event-name="on-performaction" script:macro-name="vnd.sun.star.script:Tools.ModuleControls.SetOVERWRITEToQuery?language=Basic&amp;location=application" script:language="Script"/>
</dlg:button>
<dlg:button dlg:id="cmdYesToAll" dlg:tab-index="2" dlg:left="62" dlg:top="43" dlg:width="50" dlg:height="14" dlg:value="cmdYesToAll">
<script:event script:event-name="on-performaction" script:macro-name="vnd.sun.star.script:Tools.ModuleControls.SetOVERWRITEToAlways?language=Basic&amp;location=application" script:language="Script"/>
</dlg:button>
<dlg:button dlg:id="cmdNo" dlg:tab-index="3" dlg:left="118" dlg:top="43" dlg:width="50" dlg:height="14" dlg:default="true" dlg:value="cmdNo">
<script:event script:event-name="on-performaction" script:macro-name="vnd.sun.star.script:Tools.ModuleControls.SetOVERWRITEToNever?language=Basic&amp;location=application" script:language="Script"/>
</dlg:button>
<dlg:button dlg:id="cmdCancel" dlg:tab-index="4" dlg:left="174" dlg:top="43" dlg:width="50" dlg:height="14" dlg:value="cmdCancel" dlg:button-type="cancel"/>
</dlg:bulletinboard>
</dlg:window>

370
tool-tech-file-view/LibreOfficePortable/App/libreoffice/share/basic/Tools/Listbox.xba Normal file
View File

@@ -0,0 +1,370 @@
<?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="Listbox" script:language="StarBasic">Option Explicit
Dim OriginalList()
Dim oDialogModel as Object
Sub MergeList(SourceListBox() as Object, SecondList() as String)
Dim i as Integer
Dim MaxIndex as Integer
MaxIndex = Ubound(SecondList())
OriginalList() = AddListToList(OriginalList(), SecondList())
For i = 0 To MaxIndex
SourceListbox = AddSingleItemToListbox(SourceListbox, SecondList(i))
Next i
Call FormSetMoveRights()
End Sub
Sub RemoveListItems(SourceListbox as Object, TargetListbox as Object, RemoveList() as String)
Dim i as Integer
Dim s as Integer
Dim MaxIndex as Integer
Dim CopyList()
MaxIndex = Ubound(RemoveList())
For i = 0 To MaxIndex
RemoveListboxItemByName(SourceListbox, RemoveList(i))
RemoveListboxItemByName(TargetListbox, RemoveList(i))
Next i
CopyList() = OriginalList()
s = 0
MaxIndex = Ubound(CopyList())
For i = 0 To MaxIndex
If IndexInArray(CopyList(i),RemoveList())= -1 Then
OriginalList(s) = CopyList(i)
s = s + 1
End If
Next i
ReDim Preserve OriginalList(s-1)
Call FormSetMoveRights()
End Sub
&apos; Note Boolean Parameter
Sub InitializeListboxProcedures(oModel as Object, SourceListbox as Object, TargetListbox as Object)
Dim EmptyList()
Set oDialogModel = oModel
OriginalList()= SourceListbox.StringItemList()
TargetListbox.StringItemList() = EmptyList()
End Sub
Sub CopyListboxItems(SourceListbox as Object, TargetListbox As Object)
Dim NullArray()
TargetListbox.StringItemList() = OriginalList()
SourceListbox.StringItemList() = NullArray()
End Sub
Sub FormMoveSelected()
Call MoveSelectedListBox(oDialogModel.lstFields, oDialogModel.lstSelFields)
Call FormSetMoveRights()
oDialogModel.lstSelFields.Tag = True
End Sub
Sub FormMoveAll()
Call CopyListboxItems(oDialogModel.lstFields, oDialogModel.lstSelFields)
Call FormSetMoveRights()
oDialogModel.lstSelFields.Tag = True
End Sub
Sub FormRemoveSelected()
Call MoveOrderedSelectedListbox(oDialogModel.lstFields, oDialogModel.lstSelFields, False)
Call FormSetMoveRights()
oDialogModel.lstSelFields.Tag = True
End Sub
Sub FormRemoveAll()
Call MoveOrderedSelectedListbox(oDialogModel.lstFields, oDialogModel.lstSelFields, True)
Call FormSetMoveRights()
oDialogModel.lstSelFields.Tag = 1
End Sub
Sub MoveSelectedListBox(SourceListbox as Object, TargetListbox as Object)
Dim MaxCurTarget as Integer
Dim MaxSourceSelected as Integer
Dim n as Integer
Dim m as Integer
Dim CurIndex
Dim iOldTargetSelect as Integer
Dim iOldSourceSelect as Integer
MaxCurTarget = Ubound(TargetListbox.StringItemList())
MaxSourceSelected = Ubound(SourceListbox.SelectedItems())
Dim TargetList(MaxCurTarget+MaxSourceSelected+1)
If MaxSourceSelected &gt; -1 Then
iOldSourceSelect = SourceListbox.SelectedItems(0)
If Ubound(TargetListbox.SelectedItems()) &gt; -1 Then
iOldTargetSelect = TargetListbox.SelectedItems(0)
Else
iOldTargetSelect = -1
End If
For n = 0 To MaxCurTarget
TargetList(n) = TargetListbox.StringItemList(n)
Next n
For m = 0 To MaxSourceSelected
CurIndex = SourceListbox.SelectedItems(m)
TargetList(n) = SourceListbox.StringItemList(CurIndex)
n = n + 1
Next m
TargetListBox.StringItemList() = TargetList()
SourceListbox.StringItemList() = RemoveSelected (SourceListbox)
SetNewSelection(SourceListbox, iOldSourceSelect)
SetNewSelection(TargetListbox, iOldTargetSelect)
End If
End Sub
Sub MoveOrderedSelectedListbox(lstSource as Object, lstTarget as Object, bMoveAll as Boolean)
Dim NullArray()
Dim MaxSelected as Integer
Dim MaxSourceIndex as Integer
Dim MaxOriginalIndex as Integer
Dim MaxNewIndex as Integer
Dim n as Integer
Dim m as Integer
Dim CurIndex as Integer
Dim SearchString as String
Dim SourceList() as String
Dim iOldTargetSelect as Integer
Dim iOldSourceSelect as Integer
If bMoveAll Then
lstSource.StringItemList() = OriginalList()
lstTarget.StringItemList() = NullArray()
Else
MaxOriginalIndex = Ubound(OriginalList())
MaxSelected = Ubound(lstTarget.SelectedItems())
iOldTargetSelect = lstTarget.SelectedItems(0)
If Ubound(lstSource.SelectedItems()) &gt; -1 Then
iOldSourceSelect = lstSource.SelectedItems(0)
End If
Dim SelList(MaxSelected)
For n = 0 To MaxSelected
CurIndex = lstTarget.SelectedItems(n)
SelList(n) = lstTarget.StringItemList(CurIndex)
Next n
SourceList() = lstSource.StringItemList()
MaxSourceIndex = Ubound(lstSource.StringItemList())
MaxNewIndex = MaxSelected + MaxSourceIndex + 1
Dim NewSourceList(MaxNewIndex)
m = 0
For n = 0 To MaxOriginalIndex
SearchString = OriginalList(n)
If IndexInArray(SearchString, SelList()) &lt;&gt; -1 Then
NewSourceList(m) = SearchString
m = m + 1
ElseIf IndexInArray(SearchString, SourceList()) &lt;&gt; -1 Then
NewSourceList(m) = SearchString
m = m + 1
End If
Next n
lstSource.StringItemList() = NewSourceList()
lstTarget.StringItemList() = RemoveSelected(lstTarget)
End If
SetNewSelection(lstSource, iOldSourceSelect)
SetNewSelection(lstTarget, iOldTargetSelect)
End Sub
Function RemoveSelected(oListbox as Object)
Dim MaxIndex as Integer
Dim MaxSelected as Integer
Dim n as Integer
Dim m as Integer
Dim CurIndex as Integer
Dim CurItem as String
Dim ResultArray()
MaxIndex = Ubound(oListbox.StringItemList())
MaxSelected = Ubound(oListbox.SelectedItems())
Dim LocItemList(MaxIndex)
LocItemList() = oListbox.StringItemList()
If MaxSelected &gt; -1 Then
For n = 0 To MaxSelected
CurIndex = oListbox.SelectedItems(n)
LocItemList(CurIndex) = &quot;&quot;
Next n
If MaxIndex &gt; 0 Then
ReDim ResultArray(MaxIndex - MaxSelected - 1)
m = 0
For n = 0 To MaxIndex
CurItem = LocItemList(n)
If CurItem &lt;&gt; &quot;&quot; Then
ResultArray(m) = CurItem
m = m + 1
End If
Next n
End If
RemoveSelected = ResultArray()
Else
RemoveSelected = oListbox.StringItemList()
End If
End Function
Sub SetNewSelection(oListBox as Object, iLastSelection as Integer)
Dim MaxIndex as Integer
Dim SelIndex as Integer
Dim SelList(0) as Integer
MaxIndex = Ubound(oListBox.StringItemList())
If MaxIndex &gt; -1 AND iLastSelection &gt; -1 Then
If iLastSelection &gt; MaxIndex Then
Selindex = MaxIndex
Else
SelIndex = iLastSelection
End If
Sellist(0) = SelIndex
oListBox.SelectedItems() = SelList()
End If
End Sub
Sub ToggleListboxControls(oDialogModel as Object, bDoEnable as Boolean)
With oDialogModel
.lblFields.Enabled = bDoEnable
.lblSelFields.Enabled = bDoEnable
&apos; .lstTables.Enabled = bDoEnable
.lstFields.Enabled = bDoEnable
.lstSelFields.Enabled = bDoEnable
.cmdRemoveAll.Enabled = bDoEnable
.cmdRemoveSelected.Enabled = bDoEnable
.cmdMoveAll.Enabled = bDoEnable
.cmdMoveSelected.Enabled = bDoEnable
End With
If bDoEnable Then
FormSetMoveRights()
End If
End Sub
&apos; Enable or disable the buttons used for moving the available
&apos; fields between the two list boxes.
Sub FormSetMoveRights()
Dim bIsFieldSelected as Boolean
Dim bSelectSelected as Boolean
Dim FieldCount as Integer
Dim SelectCount as Integer
bIsFieldSelected = Ubound(oDialogModel.lstFields.SelectedItems()) &lt;&gt; -1
FieldCount = Ubound(oDialogModel.lstFields.StringItemList()) + 1
bSelectSelected = Ubound(oDialogModel.lstSelFields.SelectedItems()) &gt; -1
SelectCount = Ubound(oDialogModel.lstSelFields.StringItemList()) + 1
oDialogModel.cmdRemoveAll.Enabled = SelectCount&gt;=1
oDialogModel.cmdRemoveSelected.Enabled = bSelectSelected
oDialogModel.cmdMoveAll.Enabled = FieldCount &gt;=1
oDialogModel.cmdMoveSelected.Enabled = bIsFieldSelected
oDialogModel.cmdGoOn.Enabled = SelectCount&gt;=1
&apos; This flag is set to &apos;1&apos; when the lstSelFields has been modified
End Sub
Function AddSingleItemToListbox(ByVal oListbox as Object, ListItem as String, Optional iSelIndex) as Object
Dim MaxIndex as Integer
Dim i as Integer
MaxIndex = Ubound(oListbox.StringItemList())
Dim LocList(MaxIndex + 1)
&apos; Todo: This goes faster with the Redim LocList(MaxIndex + 1) Preserve function
For i = 0 To MaxIndex
LocList(i) = oListbox.StringItemList(i)
Next i
LocList(MaxIndex + 1) = ListItem
oListbox.StringItemList() = LocList()
If Not IsMissing(iSelIndex) Then
SelectListboxItem(oListbox, iSelIndex)
End If
AddSingleItemToListbox() = oListbox
End Function
Sub EmptyListbox(oListbox as Object)
Dim NullList() as String
oListbox.StringItemList() = NullList()
End Sub
Sub SelectListboxItem(oListbox as Object, iSelIndex as Integer)
Dim LocSelList(0) as Integer
If iSelIndex &lt;&gt; -1 Then
LocSelList(0) = iSelIndex
oListbox.SelectedItems() = LocSelList()
End If
End Sub
Function GetSelectedListboxItems(oListbox as Object)
Dim SelList(Ubound(oListBox.SelectedItems())) as String
Dim i as Integer
Dim CurIndex as Integer
For i = 0 To Ubound(oListbox.SelectedItems())
CurIndex = oListbox.SelectedItems(i)
SelList(i) = oListbox.StringItemList(CurIndex)
Next i
GetSelectedListboxItems() = SelList()
End Function
&apos; Note: When using this Sub it must be ensured that the
&apos; &apos;RemoveItem&apos; appears only once in the Listbox
Sub RemoveListboxItemByName(oListbox as Object, RemoveItem as String)
Dim OldList() as String
Dim NullList() as String
Dim i as Integer
Dim a as Integer
Dim MaxIndex as Integer
OldList = oListbox.StringItemList()
MaxIndex = Ubound(OldList())
If IndexInArray(RemoveItem, OldList()) &lt;&gt; -1 Then
If MaxIndex &gt; 0 Then
a = 0
Dim NewList(MaxIndex -1)
For i = 0 To MaxIndex
If RemoveItem &lt;&gt; OldList(i) Then
NewList(a) = OldList(i)
a = a + 1
End If
Next i
oListbox.StringItemList() = NewList()
Else
oListBox.StringItemList() = NullList()
End If
End If
End Sub
Function GetItemPos(oListBox as Object, sItem as String)
Dim ItemList()
Dim MaxIndex as Integer
Dim i as Integer
ItemList() = oListBox.StringItemList()
MaxIndex = Ubound(ItemList())
For i = 0 To MaxIndex
If sItem = ItemList(i) Then
GetItemPos() = i
Exit Function
End If
Next i
GetItemPos() = -1
End Function
</script:module>

834
tool-tech-file-view/LibreOfficePortable/App/libreoffice/share/basic/Tools/Misc.xba Normal file
View File

@@ -0,0 +1,834 @@
<?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="Misc" script:language="StarBasic">REM ***** BASIC *****
Const SBSHARE = 0
Const SBUSER = 1
Dim Taskindex as Integer
Dim oResSrv as Object
Sub Main()
Dim PropList(3,1)&apos; as String
PropList(0,0) = &quot;URL&quot;
PropList(0,1) = &quot;sdbc:odbc:Erica_Test_Unicode&quot;
PropList(1,0) = &quot;User&quot;
PropList(1,1) = &quot;extra&quot;
PropList(2,0) = &quot;Password&quot;
PropList(2,1) = &quot;extra&quot;
PropList(3,0) = &quot;IsPasswordRequired&quot;
PropList(3,1) = True
End Sub
Function RegisterNewDataSource(DSName as String, PropertyList(), Optional DriverProperties() as New com.sun.star.beans.PropertyValue)
Dim oDataSource as Object
Dim oDBContext as Object
Dim oPropInfo as Object
Dim i as Integer
oDBContext = createUnoService(&quot;com.sun.star.sdb.DatabaseContext&quot;)
oDataSource = createUnoService(&quot;com.sun.star.sdb.DataSource&quot;)
For i = 0 To Ubound(PropertyList(), 1)
sPropName = PropertyList(i,0)
sPropValue = PropertyList(i,1)
oDataSource.SetPropertyValue(sPropName,sPropValue)
Next i
If Not IsMissing(DriverProperties()) Then
oDataSource.Info() = DriverProperties()
End If
oDBContext.RegisterObject(DSName, oDataSource)
RegisterNewDataSource () = oDataSource
End Function
&apos; Connects to a registered Database
Function ConnectToDatabase(DSName as String, UserID as String, Password as String, Optional Propertylist(), Optional DriverProperties() as New com.sun.star.beans.PropertyValue)
Dim oDBContext as Object
Dim oDBSource as Object
&apos; On Local Error Goto NOCONNECTION
oDBContext = CreateUnoService(&quot;com.sun.star.sdb.DatabaseContext&quot;)
If oDBContext.HasbyName(DSName) Then
oDBSource = oDBContext.GetByName(DSName)
ConnectToDatabase = oDBSource.GetConnection(UserID, Password)
Else
If Not IsMissing(Propertylist()) Then
RegisterNewDataSource(DSName, PropertyList(), DriverProperties())
oDBSource = oDBContext.GetByName(DSName)
ConnectToDatabase = oDBSource.GetConnection(UserID, Password)
Else
Msgbox(&quot;DataSource &quot; &amp; DSName &amp; &quot; is not registered&quot; , 16, GetProductname())
ConnectToDatabase() = NULL
End If
End If
NOCONNECTION:
If Err &lt;&gt; 0 Then
Msgbox(Error$, 16, GetProductName())
Resume LEAVESUB
LEAVESUB:
End If
End Function
Function GetStarOfficeLocale() as New com.sun.star.lang.Locale
Dim aLocLocale As New com.sun.star.lang.Locale
Dim sLocale as String
Dim sLocaleList(1)
Dim oMasterKey
oMasterKey = GetRegistryKeyContent(&quot;org.openoffice.Setup/L10N/&quot;)
sLocale = oMasterKey.getByName(&quot;ooLocale&quot;)
sLocaleList() = ArrayoutofString(sLocale, &quot;-&quot;)
aLocLocale.Language = sLocaleList(0)
If Ubound(sLocaleList()) &gt; 0 Then
aLocLocale.Country = sLocaleList(1)
End If
If Ubound(sLocaleList()) &gt; 1 Then
aLocLocale.Variant = sLocaleList(2)
End If
GetStarOfficeLocale() = aLocLocale
End Function
Function GetRegistryKeyContent(sKeyName as string, Optional bforUpdate as Boolean)
Dim oConfigProvider as Object
Dim aNodePath(0) as new com.sun.star.beans.PropertyValue
oConfigProvider = createUnoService(&quot;com.sun.star.configuration.ConfigurationProvider&quot;)
aNodePath(0).Name = &quot;nodepath&quot;
aNodePath(0).Value = sKeyName
If IsMissing(bForUpdate) Then bForUpdate = False
If bForUpdate Then
GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments(&quot;com.sun.star.configuration.ConfigurationUpdateAccess&quot;, aNodePath())
Else
GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments(&quot;com.sun.star.configuration.ConfigurationAccess&quot;, aNodePath())
End If
End Function
Function GetProductname() as String
Dim oProdNameAccess as Object
Dim sVersion as String
Dim sProdName as String
oProdNameAccess = GetRegistryKeyContent(&quot;org.openoffice.Setup/Product&quot;)
sProdName = oProdNameAccess.getByName(&quot;ooName&quot;)
sVersion = oProdNameAccess.getByName(&quot;ooSetupVersion&quot;)
GetProductName = sProdName &amp; sVersion
End Function
&apos; Opens a Document, checks beforehand, whether it has to be loaded
&apos; or whether it is already on the desktop.
&apos; If the parameter bDisposable is set to False then the returned document
&apos; should not be disposed afterwards, because it is already opened.
Function OpenDocument(DocPath as String, Args(), Optional bDisposable as Boolean)
Dim oComponents as Object
Dim oComponent as Object
&apos; Search if one of the active Components is the one that you search for
oComponents = StarDesktop.Components.CreateEnumeration
While oComponents.HasmoreElements
oComponent = oComponents.NextElement
If hasUnoInterfaces(oComponent,&quot;com.sun.star.frame.XModel&quot;) then
If UCase(oComponent.URL) = UCase(DocPath) then
OpenDocument() = oComponent
If Not IsMissing(bDisposable) Then
bDisposable = False
End If
Exit Function
End If
End If
Wend
If Not IsMissing(bDisposable) Then
bDisposable = True
End If
OpenDocument() = StarDesktop.LoadComponentFromURL(DocPath,&quot;_default&quot;,0,Args())
End Function
Function TaskonDesktop(DocPath as String) as Boolean
Dim oComponents as Object
Dim oComponent as Object
&apos; Search if one of the active Components is the one that you search for
oComponents = StarDesktop.Components.CreateEnumeration
While oComponents.HasmoreElements
oComponent = oComponents.NextElement
If hasUnoInterfaces(oComponent,&quot;com.sun.star.frame.XModel&quot;) then
If UCase(oComponent.URL) = UCase(DocPath) then
TaskonDesktop = True
Exit Function
End If
End If
Wend
TaskonDesktop = False
End Function
&apos; Retrieves a FileName out of a StarOffice-Document
Function RetrieveFileName(LocDoc as Object)
Dim LocURL as String
Dim LocURLArray() as String
Dim MaxArrIndex as integer
LocURL = LocDoc.Url
LocURLArray() = ArrayoutofString(LocURL,&quot;/&quot;,MaxArrIndex)
RetrieveFileName = LocURLArray(MaxArrIndex)
End Function
&apos; Gets a special configured PathSetting
Function GetPathSettings(sPathType as String, Optional bshowall as Boolean, Optional ListIndex as integer) as String
Dim oSettings, oPathSettings as Object
Dim sPath as String
Dim PathList() as String
Dim MaxIndex as Integer
Dim oPS as Object
oPS = createUnoService(&quot;com.sun.star.util.PathSettings&quot;)
If Not IsMissing(bShowall) Then
If bShowAll Then
ShowPropertyValues(oPS)
Exit Function
End If
End If
sPath = oPS.getPropertyValue(sPathType)
If Not IsMissing(ListIndex) Then
&apos; Share and User-Directory
If Instr(1,sPath,&quot;;&quot;) &lt;&gt; 0 Then
PathList = ArrayoutofString(sPath,&quot;;&quot;, MaxIndex)
If ListIndex &lt;= MaxIndex Then
sPath = PathList(ListIndex)
Else
Msgbox(&quot;String Cannot be analyzed!&quot; &amp; sPath , 16, GetProductName())
End If
End If
End If
If Instr(1, sPath, &quot;;&quot;) = 0 Then
GetPathSettings = ConvertToUrl(sPath)
Else
GetPathSettings = sPath
End If
End Function
&apos; Gets the fully qualified path to a subdirectory of the
&apos; Template Directory, e. g. with the parameter &quot;wizard/bitmap&quot;
&apos; The parameter must be passed in Url notation
&apos; The return-Value is in Url notation
Function GetOfficeSubPath(sOfficePath as String, ByVal sSubDir as String)
Dim sOfficeString as String
Dim sOfficeList() as String
Dim sOfficeDir as String
Dim sBigDir as String
Dim i as Integer
Dim MaxIndex as Integer
Dim oUcb as Object
oUcb = createUnoService(&quot;com.sun.star.ucb.SimpleFileAccess&quot;)
sOfficeString = GetPathSettings(sOfficePath)
If Right(sSubDir,1) &lt;&gt; &quot;/&quot; Then
sSubDir = sSubDir &amp; &quot;/&quot;
End If
sOfficeList() = ArrayoutofString(sOfficeString,&quot;;&quot;, MaxIndex)
For i = 0 To MaxIndex
sOfficeDir = ConvertToUrl(sOfficeList(i))
If Right(sOfficeDir,1) &lt;&gt; &quot;/&quot; Then
sOfficeDir = sOfficeDir &amp; &quot;/&quot;
End If
sBigDir = sOfficeDir &amp; sSubDir
If oUcb.Exists(sBigDir) Then
GetOfficeSubPath() = sBigDir
Exit Function
End If
Next i
ShowNoOfficePathError()
GetOfficeSubPath = &quot;&quot;
End Function
Sub ShowNoOfficePathError()
Dim ProductName as String
Dim sError as String
Dim bResObjectexists as Boolean
Dim oLocResSrv as Object
bResObjectexists = not IsNull(oResSrv)
If bResObjectexists Then
oLocResSrv = oResSrv
End If
If InitResources(&quot;Tools&quot;) Then
ProductName = GetProductName()
sError = GetResText(&quot;RID_COMMON_6&quot;)
sError = ReplaceString(sError, ProductName, &quot;%PRODUCTNAME&quot;)
sError = ReplaceString(sError, chr(13), &quot;&lt;BR&gt;&quot;)
MsgBox(sError, 16, ProductName)
End If
If bResObjectexists Then
oResSrv = oLocResSrv
End If
End Sub
Function InitResources(Description) as boolean
Dim xResource as Object
Dim sOfficeDir as String
Dim aArgs(5) as Any
On Error Goto ErrorOccurred
sOfficeDir = &quot;$BRAND_BASE_DIR/$BRAND_SHARE_SUBDIR/wizards/&quot;
sOfficeDir = GetDefaultContext.getByName(&quot;/singletons/com.sun.star.util.theMacroExpander&quot;).ExpandMacros(sOfficeDir)
aArgs(0) = sOfficeDir
aArgs(1) = true
aArgs(2) = GetStarOfficeLocale()
aArgs(3) = &quot;resources&quot;
aArgs(4) = &quot;&quot;
aArgs(5) = NULL
oResSrv = getProcessServiceManager().createInstanceWithArguments( &quot;com.sun.star.resource.StringResourceWithLocation&quot;, aArgs() )
If (IsNull(oResSrv)) then
InitResources = FALSE
MsgBox(&quot;could not initialize StringResourceWithLocation&quot;)
Else
InitResources = TRUE
End If
Exit Function
ErrorOccurred:
Dim nSolarVer
InitResources = FALSE
nSolarVer = GetSolarVersion()
MsgBox(&quot;Resource file missing&quot;, 16, GetProductName())
Resume CLERROR
CLERROR:
End Function
Function GetResText( sID as String ) As string
Dim sString as String
On Error Goto ErrorOccurred
If Not IsNull(oResSrv) Then
sString = oResSrv.resolveString(sID)
GetResText = ReplaceString(sString, GetProductname(), &quot;%PRODUCTNAME&quot;)
Else
GetResText = &quot;&quot;
End If
Exit Function
ErrorOccurred:
GetResText = &quot;&quot;
MsgBox(&quot;Resource with ID =&quot; + sID + &quot; not found!&quot;, 16, GetProductName())
Resume CLERROR
CLERROR:
End Function
Function CutPathView(sDocUrl as String, Optional PathLen as Integer)
Dim sViewPath as String
Dim FileName as String
Dim iFileLen as Integer
sViewPath = ConvertfromURL(sDocURL)
iViewPathLen = Len(sViewPath)
If iViewPathLen &gt; 60 Then
FileName = FileNameoutofPath(sViewPath, &quot;/&quot;)
iFileLen = Len(FileName)
If iFileLen &lt; 44 Then
sViewPath = Left(sViewPath,57-iFileLen-10) &amp; &quot;...&quot; &amp; Right(sViewPath,iFileLen + 10)
Else
sViewPath = Left(sViewPath,27) &amp; &quot; ... &quot; &amp; Right(sViewPath,28)
End If
End If
CutPathView = sViewPath
End Function
&apos; Deletes the content of all cells that are softformatted according
&apos; to the &apos;InputStyleName&apos;
Sub DeleteInputCells(oSheet as Object, InputStyleName as String)
Dim oRanges as Object
Dim oRange as Object
oRanges = oSheet.CellFormatRanges.createEnumeration
While oRanges.hasMoreElements
oRange = oRanges.NextElement
If Instr(1,oRange.CellStyle, InputStyleName) &lt;&gt; 0 Then
Call ReplaceRangeValues(oRange, &quot;&quot;)
End If
Wend
End Sub
&apos; Inserts a certain string to all cells of a range that is passed
&apos; either as an object or as the RangeName
Sub ChangeValueofRange(oSheet as Object, Range, ReplaceValue, Optional StyleName as String)
Dim oCellRange as Object
If Vartype(Range) = 8 Then
&apos; Get the Range out of the Rangename
oCellRange = oSheet.GetCellRangeByName(Range)
Else
&apos; The range is passed as an object
Set oCellRange = Range
End If
If IsMissing(StyleName) Then
ReplaceRangeValues(oCellRange, ReplaceValue)
Else
If Instr(1,oCellRange.CellStyle,StyleName) Then
ReplaceRangeValues(oCellRange, ReplaceValue)
End If
End If
End Sub
Sub ReplaceRangeValues(oRange as Object, ReplaceValue)
Dim oRangeAddress as Object
Dim ColCount as Integer
Dim RowCount as Integer
Dim i as Integer
oRangeAddress = oRange.RangeAddress
ColCount = oRangeAddress.EndColumn - oRangeAddress.StartColumn
RowCount = oRangeAddress.EndRow - oRangeAddress.StartRow
Dim FillArray(RowCount) as Variant
Dim sLine(ColCount) as Variant
For i = 0 To ColCount
sLine(i) = ReplaceValue
Next i
For i = 0 To RowCount
FillArray(i) = sLine()
Next i
oRange.DataArray = FillArray()
End Sub
&apos; Returns the Value of the first cell of a Range
Function GetValueofCellbyName(oSheet as Object, sCellName as String)
Dim oCell as Object
oCell = GetCellByName(oSheet, sCellName)
GetValueofCellbyName = oCell.Value
End Function
Function DuplicateRow(oSheet as Object, RangeName as String)
Dim oRange as Object
Dim oCell as Object
Dim oCellAddress as New com.sun.star.table.CellAddress
Dim oRangeAddress as New com.sun.star.table.CellRangeAddress
oRange = oSheet.GetCellRangeByName(RangeName)
oRangeAddress = oRange.RangeAddress
oCell = oSheet.GetCellByPosition(oRangeAddress.StartColumn,oRangeAddress.StartRow)
oCellAddress = oCell.CellAddress
oSheet.Rows.InsertByIndex(oCellAddress.Row,1)
oRangeAddress = oRange.RangeAddress
oSheet.CopyRange(oCellAddress, oRangeAddress)
DuplicateRow = oRangeAddress.StartRow-1
End Function
&apos; Returns the String of the first cell of a Range
Function GetStringofCellbyName(oSheet as Object, sCellName as String)
Dim oCell as Object
oCell = GetCellByName(oSheet, sCellName)
GetStringofCellbyName = oCell.String
End Function
&apos; Returns a named Cell
Function GetCellByName(oSheet as Object, sCellName as String) as Object
Dim oCellRange as Object
Dim oCellAddress as Object
oCellRange = oSheet.GetCellRangeByName(sCellName)
oCellAddress = oCellRange.RangeAddress
GetCellByName = oSheet.GetCellByPosition(oCellAddress.StartColumn,oCellAddress.StartRow)
End Function
&apos; Changes the numeric Value of a cell by transmitting the String of the numeric Value
Sub ChangeCellValue(oCell as Object, ValueString as String)
Dim CellValue
oCell.Formula = &quot;=Value(&quot; &amp; &quot;&quot;&quot;&quot; &amp; ValueString &amp; &quot;&quot;&quot;&quot; &amp; &quot;)&quot;
CellValue = oCell.Value
oCell.Formula = &quot;&quot;
oCell.Value = CellValue
End Sub
Function GetDocumentType(oDocument)
On Local Error GoTo NODOCUMENTTYPE
&apos; ShowSupportedServiceNames(oDocument)
If oDocument.SupportsService(&quot;com.sun.star.sheet.SpreadsheetDocument&quot;) Then
GetDocumentType() = &quot;scalc&quot;
ElseIf oDocument.SupportsService(&quot;com.sun.star.text.TextDocument&quot;) Then
GetDocumentType() = &quot;swriter&quot;
ElseIf oDocument.SupportsService(&quot;com.sun.star.drawing.DrawingDocument&quot;) Then
GetDocumentType() = &quot;sdraw&quot;
ElseIf oDocument.SupportsService(&quot;com.sun.star.presentation.PresentationDocument&quot;) Then
GetDocumentType() = &quot;simpress&quot;
ElseIf oDocument.SupportsService(&quot;com.sun.star.formula.FormulaProperties&quot;) Then
GetDocumentType() = &quot;smath&quot;
End If
NODOCUMENTTYPE:
If Err &lt;&gt; 0 Then
GetDocumentType = &quot;&quot;
Resume GOON
GOON:
End If
End Function
Function GetNumberFormatType(oDocFormats, oFormatObject as Object) as Integer
Dim ThisFormatKey as Long
Dim oObjectFormat as Object
On Local Error Goto NOFORMAT
ThisFormatKey = oFormatObject.NumberFormat
oObjectFormat = oDocFormats.GetByKey(ThisFormatKey)
GetNumberFormatType = oObjectFormat.Type
NOFORMAT:
If Err &lt;&gt; 0 Then
Msgbox(&quot;Numberformat of Object is not available!&quot;, 16, GetProductName())
GetNumberFormatType = 0
GOTO NOERROR
End If
NOERROR:
On Local Error Goto 0
End Function
Sub ProtectSheets(Optional oSheets as Object)
Dim i as Integer
Dim oDocSheets as Object
If IsMissing(oSheets) Then
oDocSheets = StarDesktop.CurrentFrame.Controller.Model.Sheets
Else
Set oDocSheets = oSheets
End If
For i = 0 To oDocSheets.Count-1
oDocSheets(i).Protect(&quot;&quot;)
Next i
End Sub
Sub UnprotectSheets(Optional oSheets as Object)
Dim i as Integer
Dim oDocSheets as Object
If IsMissing(oSheets) Then
oDocSheets = StarDesktop.CurrentFrame.Controller.Model.Sheets
Else
Set oDocSheets = oSheets
End If
For i = 0 To oDocSheets.Count-1
oDocSheets(i).Unprotect(&quot;&quot;)
Next i
End Sub
Function GetRowIndex(oSheet as Object, RowName as String)
Dim oRange as Object
oRange = oSheet.GetCellRangeByName(RowName)
GetRowIndex = oRange.RangeAddress.StartRow
End Function
Function GetColumnIndex(oSheet as Object, ColName as String)
Dim oRange as Object
oRange = oSheet.GetCellRangeByName(ColName)
GetColumnIndex = oRange.RangeAddress.StartColumn
End Function
Function CopySheetbyName(oSheets as Object, OldName as String, NewName as String, DestPos as Integer) as Object
Dim oSheet as Object
Dim Count as Integer
Dim BasicSheetName as String
BasicSheetName = NewName
&apos; Copy the last table. Assumption: The last table is the template
On Local Error Goto RENAMESHEET
oSheets.CopybyName(OldName, NewName, DestPos)
RENAMESHEET:
oSheet = oSheets(DestPos)
If Err &lt;&gt; 0 Then
&apos; Test if renaming failed
Count = 2
Do While oSheet.Name &lt;&gt; NewName
NewName = BasicSheetName &amp; &quot;_&quot; &amp; Count
oSheet.Name = NewName
Count = Count + 1
Loop
Resume CL_ERROR
CL_ERROR:
End If
CopySheetbyName = oSheet
End Function
&apos; Dis-or enables a Window and adjusts the mousepointer accordingly
Sub ToggleWindow(bDoEnable as Boolean)
Dim oWindow as Object
oWindow = StarDesktop.CurrentFrame.ComponentWindow
oWindow.Enable = bDoEnable
End Sub
Function CheckNewSheetname(oSheets as Object, Sheetname as String, Optional oLocale) as String
Dim nStartFlags as Long
Dim nContFlags as Long
Dim oCharService as Object
Dim iSheetNameLength as Integer
Dim iResultPos as Integer
Dim WrongChar as String
Dim oResult as Object
nStartFlags = com.sun.star.i18n.KParseTokens.ANY_LETTER_OR_NUMBER + com.sun.star.i18n.KParseTokens.ASC_UNDERSCORE
nContFlags = nStartFlags
oCharService = CreateUnoService(&quot;com.sun.star.i18n.CharacterClassification&quot;)
iSheetNameLength = Len(SheetName)
If IsMissing(oLocale) Then
oLocale = ThisComponent.CharLocale
End If
Do
oResult =oCharService.parsePredefinedToken(com.sun.star.i18n.KParseType.IDENTNAME, SheetName, 0, oLocale, nStartFlags, &quot;&quot;, nContFlags, &quot; &quot;)
iResultPos = oResult.EndPos
If iResultPos &lt; iSheetNameLength Then
WrongChar = Mid(SheetName, iResultPos+1,1)
SheetName = ReplaceString(SheetName,&quot;_&quot;, WrongChar)
End If
Loop Until iResultPos = iSheetNameLength
CheckNewSheetname = SheetName
End Function
Sub AddNewSheetName(oSheets as Object, ByVal SheetName as String)
Dim Count as Integer
Dim bSheetIsThere as Boolean
Dim iSheetNameLength as Integer
iSheetNameLength = Len(SheetName)
Count = 2
Do
bSheetIsThere = oSheets.HasByName(SheetName)
If bSheetIsThere Then
SheetName = Right(SheetName,iSheetNameLength) &amp; &quot;_&quot; &amp; Count
Count = Count + 1
End If
Loop Until Not bSheetIsThere
AddNewSheetname = SheetName
End Sub
Function GetSheetIndex(oSheets, sName) as Integer
Dim i as Integer
For i = 0 To oSheets.Count-1
If oSheets(i).Name = sName Then
GetSheetIndex = i
exit Function
End If
Next i
GetSheetIndex = -1
End Function
Function GetLastUsedRow(oSheet as Object) as Long
Dim oCell As Object
Dim oCursor As Object
Dim aAddress As Variant
oCell = oSheet.GetCellbyPosition(0, 0)
oCursor = oSheet.createCursorByRange(oCell)
oCursor.GotoEndOfUsedArea(True)
aAddress = oCursor.RangeAddress
GetLastUsedRow = aAddress.EndRow
End Function
&apos; Note To set a one lined frame you have to set the inner width to 0
&apos; In the API all Units that refer to pt-Heights are &quot;1/100mm&quot;
&apos; The convert factor from 1pt to 1/100 mm is approximately 35
Function ModifyBorderLineWidth(ByVal oStyleBorder, iInnerLineWidth as Integer, iOuterLineWidth as Integer)
Dim aBorder as New com.sun.star.table.BorderLine
aBorder = oStyleBorder
aBorder.InnerLineWidth = iInnerLineWidth
aBorder.OuterLineWidth = iOuterLineWidth
ModifyBorderLineWidth = aBorder
End Function
Sub AttachBasicMacroToEvent(oDocument as Object, EventName as String, SubPath as String)
Dim PropValue(1) as new com.sun.star.beans.PropertyValue
PropValue(0).Name = &quot;EventType&quot;
PropValue(0).Value = &quot;StarBasic&quot;
PropValue(1).Name = &quot;Script&quot;
PropValue(1).Value = &quot;macro:///&quot; &amp; SubPath
oDocument.Events.ReplaceByName(EventName, PropValue())
End Sub
Function ModifyPropertyValue(oContent() as New com.sun.star.beans.PropertyValue, TargetProperties() as New com.sun.star.beans.PropertyValue)
Dim MaxIndex as Integer
Dim i as Integer
Dim a as Integer
MaxIndex = Ubound(oContent())
bDoReplace = False
For i = 0 To MaxIndex
a = GetPropertyValueIndex(oContent(i).Name, TargetProperties())
If a &lt;&gt; -1 Then
If Vartype(TargetProperties(a).Value) &lt;&gt; 9 Then
If TargetProperties(a).Value &lt;&gt; oContent(i).Value Then
oContent(i).Value = TargetProperties(a).Value
bDoReplace = True
End If
Else
If Not EqualUnoObjects(TargetProperties(a).Value, oContent(i).Value) Then
oContent(i).Value = TargetProperties(a).Value
bDoReplace = True
End If
End If
End If
Next i
ModifyPropertyValue() = bDoReplace
End Function
Function GetPropertyValueIndex(SearchName as String, TargetProperties() as New com.sun.star.beans.PropertyValue ) as Integer
Dim i as Integer
For i = 0 To Ubound(TargetProperties())
If Searchname = TargetProperties(i).Name Then
GetPropertyValueIndex = i
Exit Function
End If
Next i
GetPropertyValueIndex() = -1
End Function
Sub DispatchSlot(SlotID as Integer)
Dim oArg() as new com.sun.star.beans.PropertyValue
Dim oUrl as new com.sun.star.util.URL
Dim oTrans as Object
Dim oDisp as Object
oTrans = createUNOService(&quot;com.sun.star.util.URLTransformer&quot;)
oUrl.Complete = &quot;slot:&quot; &amp; CStr(SlotID)
oTrans.parsestrict(oUrl)
oDisp = StarDesktop.ActiveFrame.queryDispatch(oUrl, &quot;_self&quot;, 0)
oDisp.dispatch(oUrl, oArg())
End Sub
&apos;returns the type of the office application
&apos;FatOffice = 0, WebTop = 1
&apos;This routine has to be changed if the Product Name is being changed!
Function IsFatOffice() As Boolean
If sProductname = &quot;&quot; Then
sProductname = GetProductname()
End If
IsFatOffice = TRUE
&apos;The following line has to include the current productname
If Instr(1,sProductname,&quot;WebTop&quot;,1) &lt;&gt; 0 Then
IsFatOffice = FALSE
End If
End Function
Sub ToggleDesignMode(oDocument as Object)
Dim aSwitchMode as new com.sun.star.util.URL
aSwitchMode.Complete = &quot;.uno:SwitchControlDesignMode&quot;
aTransformer = createUnoService(&quot;com.sun.star.util.URLTransformer&quot;)
aTransformer.parseStrict(aSwitchMode)
oFrame = oDocument.currentController.Frame
oDispatch = oFrame.queryDispatch(aSwitchMode, oFrame.Name, 63)
Dim aEmptyArgs() as New com.sun.star.bean.PropertyValue
oDispatch.dispatch(aSwitchMode, aEmptyArgs())
Erase aSwitchMode
End Sub
Function isHighContrast(oPeer as Object)
Dim UIColor as Long
Dim myRed as Integer
Dim myGreen as Integer
Dim myBlue as Integer
Dim myLuminance as Double
UIColor = oPeer.getProperty( &quot;DisplayBackgroundColor&quot; )
myRed = Red (UIColor)
myGreen = Green (UIColor)
myBlue = Blue (UIColor)
myLuminance = (( myBlue*28 + myGreen*151 + myRed*77 ) / 256 )
isHighContrast = false
If myLuminance &lt;= 25 Then isHighContrast = true
End Function
Function CreateNewDocument(sType as String, Optional sAddMsg as String) as Object
Dim NoArgs() as new com.sun.star.beans.PropertyValue
Dim oDocument as Object
Dim sUrl as String
Dim ErrMsg as String
On Local Error Goto NOMODULEINSTALLED
sUrl = &quot;private:factory/&quot; &amp; sType
oDocument = StarDesktop.LoadComponentFromURL(sUrl,&quot;_default&quot;,0, NoArgs())
NOMODULEINSTALLED:
If (Err &lt;&gt; 0) OR IsNull(oDocument) Then
If InitResources(&quot;&quot;) Then
Select Case sType
Case &quot;swriter&quot;
ErrMsg = GetResText(&quot;RID_COMMON_1&quot;)
Case &quot;scalc&quot;
ErrMsg = GetResText(&quot;RID_COMMON_2&quot;)
Case &quot;simpress&quot;
ErrMsg = GetResText(&quot;RID_COMMON_3&quot;)
Case &quot;sdraw&quot;
ErrMsg = GetResText(&quot;RID_COMMON_4&quot;)
Case &quot;smath&quot;
ErrMsg = GetResText(&quot;RID_COMMON_5&quot;)
Case Else
ErrMsg = &quot;Invalid Document Type!&quot;
End Select
ErrMsg = ReplaceString(ErrMsg, chr(13), &quot;&lt;BR&gt;&quot;)
If Not IsMissing(sAddMsg) Then
ErrMsg = ErrMsg &amp; chr(13) &amp; sAddMsg
End If
Msgbox(ErrMsg, 48, GetProductName())
End If
If Err &lt;&gt; 0 Then
Resume GOON
End If
End If
GOON:
CreateNewDocument = oDocument
End Function
&apos; This Sub has been used in order to ensure that after disposing a document
&apos; from the backing window it is returned to the backing window, so the
&apos; office won&apos;t be closed
Sub DisposeDocument(oDocument as Object)
Dim dispatcher as Object
Dim parser as Object
Dim disp as Object
Dim url as new com.sun.star.util.URL
Dim NoArgs() as New com.sun.star.beans.PropertyValue
Dim oFrame as Object
If Not IsNull(oDocument) Then
oDocument.setModified(false)
parser = createUnoService(&quot;com.sun.star.util.URLTransformer&quot;)
url.Complete = &quot;.uno:CloseDoc&quot;
parser.parseStrict(url)
oFrame = oDocument.CurrentController.Frame
disp = oFrame.queryDispatch(url,&quot;_self&quot;, com.sun.star.util.SearchFlags.NORM_WORD_ONLY)
disp.dispatch(url, NoArgs())
End If
End Sub
&apos;Function to calculate if the year is a leap year
Function CalIsLeapYear(ByVal iYear as Integer) as Boolean
CalIsLeapYear = ((iYear Mod 4 = 0) And ((iYear Mod 100 &lt;&gt; 0) Or (iYear Mod 400 = 0)))
End Function
</script:module>

387
tool-tech-file-view/LibreOfficePortable/App/libreoffice/share/basic/Tools/ModuleControls.xba Normal file
View File

@@ -0,0 +1,387 @@
<?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="ModuleControls" script:language="StarBasic">Option Explicit
Public DlgOverwrite as Object
Public Const SBOVERWRITEUNDEFINED as Integer = 0
Public Const SBOVERWRITECANCEL as Integer = 2
Public Const SBOVERWRITEQUERY as Integer = 7
Public Const SBOVERWRITEALWAYS as Integer = 6
Public Const SBOVERWRITENEVER as Integer = 8
Public iGeneralOverwrite as Integer
&apos; Accepts the name of a control and returns the respective control model as object
&apos; The Container can either be a whole document or a specific sheet of a Calc-Document
&apos; &apos;CName&apos; is the name of the Control
Function getControlModel(oContainer as Object, CName as String)
Dim aForm, oForms as Object
Dim i as Integer
oForms = oContainer.Drawpage.GetForms
For i = 0 To oForms.Count-1
aForm = oForms.GetbyIndex(i)
If aForm.HasByName(CName) Then
GetControlModel = aForm.GetbyName(CName)
Exit Function
End If
Next i
Msgbox(&quot;No Control with the name &apos;&quot; &amp; CName &amp; &quot;&apos; found&quot; , 16, GetProductName())
End Function
&apos; Gets the Shape of a Control( e. g. to reset the size or Position of the control
&apos; Parameters:
&apos; The &apos;oContainer&apos; is the Document or a specific sheet of a Calc - Document
&apos; &apos;CName&apos; is the Name of the Control
Function GetControlShape(oContainer as Object,CName as String)
Dim i as integer
Dim aShape as Object
For i = 0 to oContainer.DrawPage.Count-1
aShape = oContainer.DrawPage(i)
If HasUnoInterfaces(aShape, &quot;com.sun.star.drawing.XControlShape&quot;) then
If ashape.Control.Name = CName then
GetControlShape = aShape
exit Function
End If
End If
Next
End Function
&apos; Returns the View of a Control
&apos; Parameters:
&apos; The &apos;oContainer&apos; is the Document or a specific sheet of a Calc - Document
&apos; The &apos;oController&apos; is always directly attached to the Document
&apos; &apos;CName&apos; is the Name of the Control
Function getControlView(oContainer , oController as Object, CName as String) as Object
Dim aForm, oForms, oControlModel as Object
Dim i as Integer
oForms = oContainer.DrawPage.Forms
For i = 0 To oForms.Count-1
aForm = oforms.GetbyIndex(i)
If aForm.HasByName(CName) Then
oControlModel = aForm.GetbyName(CName)
GetControlView = oController.GetControl(oControlModel)
Exit Function
End If
Next i
Msgbox(&quot;No Control with the name &apos;&quot; &amp; CName &amp; &quot;&apos; found&quot; , 16, GetProductName())
End Function
&apos; Parameters:
&apos; The &apos;oContainer&apos; is the Document or a specific sheet of a Calc - Document
&apos; &apos;CName&apos; is the Name of the Control
Function DisposeControl(oContainer as Object, CName as String) as Boolean
Dim aControl as Object
aControl = GetControlModel(oContainer,CName)
If not IsNull(aControl) Then
aControl.Dispose()
DisposeControl = True
Else
DisposeControl = False
End If
End Function
&apos; Returns a sequence of a group of controls like option buttons or checkboxes
&apos; The &apos;oContainer&apos; is the Document or a specific sheet of a Calc - Document
&apos; &apos;sGroupName&apos; is the Name of the Controlgroup
Function GetControlGroupModel(oContainer as Object, sGroupName as String )
Dim aForm, oForms As Object
Dim aControlModel() As Object
Dim i as integer
oForms = oContainer.DrawPage.Forms
For i = 0 To oForms.Count-1
aForm = oForms(i)
If aForm.HasbyName(sGroupName) Then
aForm.GetGroupbyName(sGroupName,aControlModel)
GetControlGroupModel = aControlModel
Exit Function
End If
Next i
Msgbox(&quot;No Controlgroup with the name &apos;&quot; &amp; sGroupName &amp; &quot;&apos; found&quot; , 16, GetProductName())
End Function
&apos; Returns the Referencevalue of a group of e.g. option buttons or check boxes
&apos; &apos;oControlGroup&apos; is a sequence of the Control objects
Function GetRefValue(oControlGroup() as Object)
Dim i as Integer
For i = 0 To Ubound(oControlGroup())
&apos; oControlGroup(i).DefaultState = oControlGroup(i).State
If oControlGroup(i).State Then
GetRefValue = oControlGroup(i).RefValue
exit Function
End If
Next
GetRefValue() = -1
End Function
Function GetRefValueOfControlGroup(oContainer as Object, GroupName as String)
Dim oOptGroup() as Object
Dim iRef as Integer
oOptGroup() = GetControlGroupModel(oContainer, GroupName)
iRef = GetRefValue(oOptGroup())
GetRefValueofControlGroup = iRef
End Function
Function GetOptionGroupValue(oContainer as Object, OptGroupName as String) as Boolean
Dim oRulesOptions() as Object
oRulesOptions() = GetControlGroupModel(oContainer, OptGroupName)
GetOptionGroupValue = oRulesOptions(0).State
End Function
Function WriteOptValueToCell(oSheet as Object, OptGroupName as String, iCol as Integer, iRow as Integer) as Boolean
Dim bOptValue as Boolean
Dim oCell as Object
bOptValue = GetOptionGroupValue(oSheet, OptGroupName)
oCell = oSheet.GetCellByPosition(iCol, iRow)
oCell.SetValue(ABS(CInt(bOptValue)))
WriteOptValueToCell() = bOptValue
End Function
Function LoadDialog(Libname as String, DialogName as String, Optional oLibContainer)
Dim oLib as Object
Dim oLibDialog as Object
Dim oRuntimeDialog as Object
If IsMissing(oLibContainer ) then
oLibContainer = DialogLibraries
End If
oLibContainer.LoadLibrary(LibName)
oLib = oLibContainer.GetByName(Libname)
oLibDialog = oLib.GetByName(DialogName)
oRuntimeDialog = CreateUnoDialog(oLibDialog)
LoadDialog() = oRuntimeDialog
End Function
Sub GetFolderName(oRefModel as Object)
Dim oFolderDialog as Object
Dim iAccept as Integer
Dim sPath as String
Dim InitPath as String
Dim RefControlName as String
Dim oUcb as object
&apos;Note: The following services have to be called in the following order
&apos; because otherwise Basic does not remove the FileDialog Service
oFolderDialog = CreateUnoService(&quot;com.sun.star.ui.dialogs.FolderPicker&quot;)
oUcb = createUnoService(&quot;com.sun.star.ucb.SimpleFileAccess&quot;)
InitPath = ConvertToUrl(oRefModel.Text)
If InitPath = &quot;&quot; Then
InitPath = GetPathSettings(&quot;Work&quot;)
End If
If oUcb.Exists(InitPath) Then
oFolderDialog.SetDisplayDirectory(InitPath)
End If
iAccept = oFolderDialog.Execute()
If iAccept = 1 Then
sPath = oFolderDialog.GetDirectory()
If oUcb.Exists(sPath) Then
oRefModel.Text = ConvertFromUrl(sPath)
End If
End If
End Sub
Sub GetFileName(oRefModel as Object, Filternames())
Dim oFileDialog as Object
Dim iAccept as Integer
Dim sPath as String
Dim InitPath as String
Dim RefControlName as String
Dim oUcb as object
&apos;Dim ListAny(0)
&apos;Note: The following services have to be called in the following order
&apos; because otherwise Basic does not remove the FileDialog Service
oFileDialog = CreateUnoService(&quot;com.sun.star.ui.dialogs.FilePicker&quot;)
oUcb = createUnoService(&quot;com.sun.star.ucb.SimpleFileAccess&quot;)
&apos;ListAny(0) = com.sun.star.ui.dialogs.TemplateDescription.FILEOPEN_SIMPLE
&apos;oFileDialog.initialize(ListAny())
AddFiltersToDialog(FilterNames(), oFileDialog)
InitPath = ConvertToUrl(oRefModel.Text)
If InitPath = &quot;&quot; Then
InitPath = GetPathSettings(&quot;Work&quot;)
End If
If oUcb.Exists(InitPath) Then
oFileDialog.SetDisplayDirectory(InitPath)
End If
iAccept = oFileDialog.Execute()
If iAccept = 1 Then
sPath = oFileDialog.Files(0)
If oUcb.Exists(sPath) Then
oRefModel.Text = ConvertFromUrl(sPath)
End If
End If
oFileDialog.Dispose()
End Sub
Function StoreDocument(oDocument as Object, FilterNames() as String, DefaultName as String, DisplayDirectory as String, Optional iAddProcedure as Integer) as String
Dim NoArgs() as New com.sun.star.beans.PropertyValue
Dim oStoreProperties(0) as New com.sun.star.beans.PropertyValue
Dim oStoreDialog as Object
Dim iAccept as Integer
Dim sPath as String
Dim ListAny(0) as Long
Dim UIFilterName as String
Dim FilterName as String
Dim FilterIndex as Integer
ListAny(0) = com.sun.star.ui.dialogs.TemplateDescription.FILESAVE_AUTOEXTENSION_PASSWORD
oStoreDialog = CreateUnoService(&quot;com.sun.star.ui.dialogs.FilePicker&quot;)
oStoreDialog.Initialize(ListAny())
AddFiltersToDialog(FilterNames(), oStoreDialog)
oStoreDialog.SetDisplayDirectory(DisplayDirectory)
oStoreDialog.SetDefaultName(DefaultName)
oStoreDialog.setValue(com.sun.star.ui.dialogs.ExtendedFilePickerElementIds.CHECKBOX_AUTOEXTENSION,0, true)
iAccept = oStoreDialog.Execute()
If iAccept = 1 Then
sPath = oStoreDialog.Files(0)
UIFilterName = oStoreDialog.GetCurrentFilter()
FilterIndex = IndexInArray(UIFilterName, FilterNames())
FilterName = FilterNames(FilterIndex,2)
If Not IsMissing(iAddProcedure) Then
Select Case iAddProcedure
Case 1
CommitLastDocumentChanges(sPath)
End Select
End If
On Local Error Goto NOSAVING
If FilterName = &quot;&quot; Then
&apos; Todo: Catch the case that a document that has to be overwritten is writeprotected (e.g. it is open)
oDocument.StoreAsUrl(sPath, NoArgs())
Else
oStoreProperties(0).Name = &quot;FilterName&quot;
oStoreProperties(0).Value = FilterName
oDocument.StoreAsUrl(sPath, oStoreProperties())
End If
End If
oStoreDialog.dispose()
StoreDocument() = sPath
Exit Function
NOSAVING:
If Err &lt;&gt; 0 Then
&apos; Msgbox(&quot;Document cannot be saved under &apos;&quot; &amp; ConvertFromUrl(sPath) &amp; &quot;&apos;&quot;, 48, GetProductName())
sPath = &quot;&quot;
oStoreDialog.dispose()
Resume NOERROR
NOERROR:
End If
End Function
Sub AddFiltersToDialog(FilterNames() as String, oDialog as Object)
Dim i as Integer
Dim MaxIndex as Integer
Dim ViewFiltername as String
Dim oProdNameAccess as Object
Dim sProdName as String
oProdNameAccess = GetRegistryKeyContent(&quot;org.openoffice.Setup/Product&quot;)
sProdName = oProdNameAccess.getByName(&quot;ooName&quot;)
MaxIndex = Ubound(FilterNames(), 1)
For i = 0 To MaxIndex
Filternames(i,0) = ReplaceString(Filternames(i,0), sProdName,&quot;%productname%&quot;)
oDialog.AppendFilter(FilterNames(i,0), FilterNames(i,1))
Next i
oDialog.SetCurrentFilter(FilterNames(0,0))
End Sub
Sub SwitchMousePointer(oWindowPeer as Object, bDoEnable as Boolean)
Dim oWindowPointer as Object
oWindowPointer = CreateUnoService(&quot;com.sun.star.awt.Pointer&quot;)
If bDoEnable Then
oWindowPointer.SetType(com.sun.star.awt.SystemPointer.ARROW)
Else
oWindowPointer.SetType(com.sun.star.awt.SystemPointer.WAIT)
End If
oWindowPeer.SetPointer(oWindowPointer)
End Sub
Sub ShowOverwriteAllDialog(FilePath as String, sTitle as String)
Dim QueryString as String
Dim LocRetValue as Integer
Dim lblYes as String
Dim lblNo as String
Dim lblYesToAll as String
Dim lblCancel as String
Dim OverwriteModel as Object
If InitResources(GetProductName()) Then
QueryString = GetResText(&quot;RID_COMMON_7&quot;)
QueryString = ReplaceString(QueryString, ConvertFromUrl(FilePath), &quot;&lt;PATH&gt;&quot;)
If Len(QueryString) &gt; 190 Then
QueryString = DeleteStr(QueryString, &quot;.&lt;BR&gt;&quot;)
End If
QueryString = ReplaceString(QueryString, chr(13), &quot;&lt;BR&gt;&quot;)
lblYes = GetResText(&quot;RID_COMMON_8&quot;)
lblYesToAll = GetResText(&quot;RID_COMMON_9&quot;)
lblNo = GetResText(&quot;RID_COMMON_10&quot;)
lblCancel = GetResText(&quot;RID_COMMON_11&quot;)
DlgOverwrite = LoadDialog(&quot;Tools&quot;, &quot;DlgOverwriteAll&quot;)
DlgOverwrite.Title = sTitle
OverwriteModel = DlgOverwrite.Model
OverwriteModel.cmdYes.Label = lblYes
OverwriteModel.cmdYesToAll.Label = lblYesToAll
OverwriteModel.cmdNo.Label = lblNo
OverwriteModel.cmdCancel.Label = lblCancel
OverwriteModel.lblQueryforSave.Label = QueryString
OverwriteModel.cmdNo.DefaultButton = True
DlgOverwrite.GetControl(&quot;cmdNo&quot;).SetFocus()
iGeneralOverwrite = 999
LocRetValue = DlgOverwrite.execute()
If iGeneralOverwrite = 999 Then
iGeneralOverwrite = SBOVERWRITECANCEL
End If
DlgOverwrite.dispose()
Else
iGeneralOverwrite = SBOVERWRITECANCEL
End If
End Sub
Sub SetOVERWRITEToQuery()
iGeneralOverwrite = SBOVERWRITEQUERY
DlgOverwrite.EndExecute()
End Sub
Sub SetOVERWRITEToAlways()
iGeneralOverwrite = SBOVERWRITEALWAYS
DlgOverwrite.EndExecute()
End Sub
Sub SetOVERWRITEToNever()
iGeneralOverwrite = SBOVERWRITENEVER
DlgOverwrite.EndExecute()
End Sub
</script:module>

469
tool-tech-file-view/LibreOfficePortable/App/libreoffice/share/basic/Tools/Strings.xba Normal file
View File

@@ -0,0 +1,469 @@
<?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="Strings" script:language="StarBasic">Option Explicit
Public sProductname as String
&apos; Deletes out of a String &apos;BigString&apos; all possible PartStrings, that are summed up
&apos; in the Array &apos;ElimArray&apos;
Function ElimChar(ByVal BigString as String, ElimArray() as String)
Dim i% ,n%
For i = 0 to Ubound(ElimArray)
BigString = DeleteStr(BigString,ElimArray(i))
Next
ElimChar = BigString
End Function
&apos; Deletes out of a String &apos;BigString&apos; a possible Partstring &apos;CompString&apos;
Function DeleteStr(ByVal BigString,CompString as String) as String
Dim i%, CompLen%, BigLen%
CompLen = Len(CompString)
i = 1
While i &lt;&gt; 0
i = Instr(i, BigString,CompString)
If i &lt;&gt; 0 then
BigLen = Len(BigString)
BigString = Mid(BigString,1,i-1) + Mid(BigString,i+CompLen,BigLen-i+1-CompLen)
End If
Wend
DeleteStr = BigString
End Function
&apos; Finds a PartString, that is framed by the Strings &apos;Prestring&apos; and &apos;PostString&apos;
Function FindPartString(BigString, PreString, PostString as String, SearchPos as Integer) as String
Dim StartPos%, EndPos%
Dim BigLen%, PreLen%, PostLen%
StartPos = Instr(SearchPos,BigString,PreString)
If StartPos &lt;&gt; 0 Then
PreLen = Len(PreString)
EndPos = Instr(StartPos + PreLen,BigString,PostString)
If EndPos &lt;&gt; 0 Then
BigLen = Len(BigString)
PostLen = Len(PostString)
FindPartString = Mid(BigString,StartPos + PreLen, EndPos - (StartPos + PreLen))
SearchPos = EndPos + PostLen
Else
Msgbox(&quot;No final tag for &apos;&quot; &amp; PreString &amp; &quot;&apos; existing&quot;, 16, GetProductName())
FindPartString = &quot;&quot;
End If
Else
FindPartString = &quot;&quot;
End If
End Function
&apos; Note iCompare = 0 (Binary comparison)
&apos; iCompare = 1 (Text comparison)
Function PartStringInArray(BigArray(), SearchString as String, iCompare as Integer) as Integer
Dim MaxIndex as Integer
Dim i as Integer
MaxIndex = Ubound(BigArray())
For i = 0 To MaxIndex
If Instr(1, BigArray(i), SearchString, iCompare) &lt;&gt; 0 Then
PartStringInArray() = i
Exit Function
End If
Next i
PartStringInArray() = -1
End Function
&apos; Deletes the String &apos;SmallString&apos; out of the String &apos;BigString&apos;
&apos; in case SmallString&apos;s Position in BigString is right at the end
Function RTrimStr(ByVal BigString, SmallString as String) as String
Dim SmallLen as Integer
Dim BigLen as Integer
SmallLen = Len(SmallString)
BigLen = Len(BigString)
If Instr(1,BigString, SmallString) &lt;&gt; 0 Then
If Mid(BigString,BigLen + 1 - SmallLen, SmallLen) = SmallString Then
RTrimStr = Mid(BigString,1,BigLen - SmallLen)
Else
RTrimStr = BigString
End If
Else
RTrimStr = BigString
End If
End Function
&apos; Deletes the Char &apos;CompChar&apos; out of the String &apos;BigString&apos;
&apos; in case CompChar&apos;s Position in BigString is right at the beginning
Function LTRimChar(ByVal BigString as String,CompChar as String) as String
Dim BigLen as integer
BigLen = Len(BigString)
If BigLen &gt; 1 Then
If Left(BigString,1) = CompChar then
BigString = Mid(BigString,2,BigLen-1)
End If
ElseIf BigLen = 1 Then
BigString = &quot;&quot;
End If
LTrimChar = BigString
End Function
&apos; Retrieves an Array out of a String.
&apos; The fields of the Array are separated by the parameter &apos;Separator&apos;, that is contained
&apos; in the Array
&apos; The Array MaxIndex delivers the highest Index of this Array
Function ArrayOutOfString(BigString, Separator as String, Optional MaxIndex as Integer)
Dim LocList() as String
LocList=Split(BigString,Separator)
If not isMissing(MaxIndex) then maxIndex=ubound(LocList())
ArrayOutOfString=LocList
End Function
&apos; Deletes all fieldvalues in one-dimensional Array
Sub ClearArray(BigArray)
Dim i as integer
For i = Lbound(BigArray()) to Ubound(BigArray())
BigArray(i) = &quot;&quot;
Next
End Sub
&apos; Deletes all fieldvalues in a multidimensional Array
Sub ClearMultiDimArray(BigArray,DimCount as integer)
Dim n%, m%
For n = Lbound(BigArray(),1) to Ubound(BigArray(),1)
For m = 0 to Dimcount - 1
BigArray(n,m) = &quot;&quot;
Next m
Next n
End Sub
&apos; Checks if a Field (LocField) is already defined in an Array
&apos; Returns &apos;True&apos; or &apos;False&apos;
Function FieldInArray(LocArray(), MaxIndex as integer, LocField as String) As Boolean
Dim i as integer
For i = Lbound(LocArray()) to MaxIndex
If UCase(LocArray(i)) = UCase(LocField) Then
FieldInArray = True
Exit Function
End if
Next
FieldInArray = False
End Function
&apos; Checks if a Field (LocField) is already defined in an Array
&apos; Returns &apos;True&apos; or &apos;False&apos;
Function FieldInList(LocField, BigList()) As Boolean
Dim i as integer
For i = Lbound(BigList()) to Ubound(BigList())
If LocField = BigList(i) Then
FieldInList = True
Exit Function
End if
Next
FieldInList = False
End Function
&apos; Retrieves the Index of the delivered String &apos;SearchString&apos; in
&apos; the Array LocList()&apos;
Function IndexInArray(SearchString as String, LocList()) as Integer
Dim i as integer
For i = Lbound(LocList(),1) to Ubound(LocList(),1)
If UCase(LocList(i,0)) = UCase(SearchString) Then
IndexInArray = i
Exit Function
End if
Next
IndexInArray = -1
End Function
Sub MultiArrayInListbox(oDialog as Object, ListboxName as String, ValList(), iDim as Integer)
Dim oListbox as Object
Dim i as integer
Dim a as Integer
a = 0
oListbox = oDialog.GetControl(ListboxName)
oListbox.RemoveItems(0, oListbox.GetItemCount)
For i = 0 to Ubound(ValList(), 1)
If ValList(i) &lt;&gt; &quot;&quot; Then
oListbox.AddItem(ValList(i, iDim-1), a)
a = a + 1
End If
Next
End Sub
&apos; Searches for a String in a two-dimensional Array by querying all Searchindexes of the second dimension
&apos; and delivers the specific String of the ReturnIndex in the second dimension of the Searchlist()
Function StringInMultiArray(SearchList(), SearchString as String, SearchIndex as Integer, ReturnIndex as Integer, Optional MaxIndex as Integer) as String
Dim i as integer
Dim CurFieldString as String
If IsMissing(MaxIndex) Then
MaxIndex = Ubound(SearchList(),1)
End If
For i = Lbound(SearchList()) to MaxIndex
CurFieldString = SearchList(i,SearchIndex)
If UCase(CurFieldString) = UCase(SearchString) Then
StringInMultiArray() = SearchList(i,ReturnIndex)
Exit Function
End if
Next
StringInMultiArray() = &quot;&quot;
End Function
&apos; Searches for a Value in multidimensial Array by querying all Searchindices of the passed dimension
&apos; and delivers the Index where it is found.
Function GetIndexInMultiArray(SearchList(), SearchValue, SearchIndex as Integer) as Integer
Dim i as integer
Dim MaxIndex as Integer
Dim CurFieldValue
MaxIndex = Ubound(SearchList(),1)
For i = Lbound(SearchList()) to MaxIndex
CurFieldValue = SearchList(i,SearchIndex)
If CurFieldValue = SearchValue Then
GetIndexInMultiArray() = i
Exit Function
End if
Next
GetIndexInMultiArray() = -1
End Function
&apos; Searches for a Value in multidimensial Array by querying all Searchindices of the passed dimension
&apos; and delivers the Index where the Searchvalue is found as a part string
Function GetIndexForPartStringinMultiArray(SearchList(), SearchValue, SearchIndex as Integer) as Integer
Dim i as integer
Dim MaxIndex as Integer
Dim CurFieldValue
MaxIndex = Ubound(SearchList(),1)
For i = Lbound(SearchList()) to MaxIndex
CurFieldValue = SearchList(i,SearchIndex)
If Instr(CurFieldValue, SearchValue) &gt; 0 Then
GetIndexForPartStringinMultiArray() = i
Exit Function
End if
Next
GetIndexForPartStringinMultiArray = -1
End Function
Function ArrayfromMultiArray(MultiArray as String, iDim as Integer)
Dim MaxIndex as Integer
Dim i as Integer
MaxIndex = Ubound(MultiArray())
Dim ResultArray(MaxIndex) as String
For i = 0 To MaxIndex
ResultArray(i) = MultiArray(i,iDim)
Next i
ArrayfromMultiArray() = ResultArray()
End Function
&apos; Replaces the string &quot;OldReplace&quot; through the String &quot;NewReplace&quot; in the String
&apos; &apos;BigString&apos;
Function ReplaceString(ByVal Bigstring, NewReplace, OldReplace as String) as String
ReplaceString=join(split(BigString,OldReplace),NewReplace)
End Function
&apos; Retrieves the second value for a next to &apos;SearchString&apos; in
&apos; a two-dimensional string-Array
Function FindSecondValue(SearchString as String, TwoDimList() as String ) as String
Dim i as Integer
For i = 0 To Ubound(TwoDimList,1)
If UCase(SearchString) = UCase(TwoDimList(i,0)) Then
FindSecondValue = TwoDimList(i,1)
Exit For
End If
Next
End Function
&apos; raises a base to a certain power
Function Power(Basis as Double, Exponent as Double) as Double
Power = Exp(Exponent*Log(Basis))
End Function
&apos; rounds a Real to a given Number of Decimals
Function Round(BaseValue as Double, Decimals as Integer) as Double
Dim Multiplicator as Long
Dim DblValue#, RoundValue#
Multiplicator = Power(10,Decimals)
RoundValue = Int(BaseValue * Multiplicator)
Round = RoundValue/Multiplicator
End Function
&apos;Retrieves the mere filename out of a whole path
Function FileNameoutofPath(ByVal Path as String, Optional Separator as String) as String
Dim i as Integer
Dim SepList() as String
If IsMissing(Separator) Then
Path = ConvertFromUrl(Path)
Separator = GetPathSeparator()
End If
SepList() = ArrayoutofString(Path, Separator,i)
FileNameoutofPath = SepList(i)
End Function
Function GetFileNameExtension(ByVal FileName as String)
Dim MaxIndex as Integer
Dim SepList() as String
SepList() = ArrayoutofString(FileName,&quot;.&quot;, MaxIndex)
GetFileNameExtension = SepList(MaxIndex)
End Function
Function GetFileNameWithoutExtension(ByVal FileName as String, Optional Separator as String)
Dim MaxIndex as Integer
Dim SepList() as String
If not IsMissing(Separator) Then
FileName = FileNameoutofPath(FileName, Separator)
End If
SepList() = ArrayoutofString(FileName,&quot;.&quot;, MaxIndex)
GetFileNameWithoutExtension = RTrimStr(FileName, &quot;.&quot; &amp; SepList(MaxIndex))
End Function
Function DirectoryNameoutofPath(sPath as String, Separator as String) as String
Dim LocFileName as String
LocFileName = FileNameoutofPath(sPath, Separator)
DirectoryNameoutofPath = RTrimStr(sPath, Separator &amp; LocFileName)
End Function
Function CountCharsInString(BigString, LocChar as String, ByVal StartPos as Integer) as Integer
Dim LocCount%, LocPos%
LocCount = 0
Do
LocPos = Instr(StartPos,BigString,LocChar)
If LocPos &lt;&gt; 0 Then
LocCount = LocCount + 1
StartPos = LocPos+1
End If
Loop until LocPos = 0
CountCharsInString = LocCount
End Function
Function BubbleSortList(ByVal SortList(),optional sort2ndValue as Boolean)
&apos;This function bubble sorts an array of maximum 2 dimensions.
&apos;The default sorting order is the first dimension
&apos;Only if sort2ndValue is True the second dimension is the relevant for the sorting order
Dim s as Integer
Dim t as Integer
Dim i as Integer
Dim k as Integer
Dim dimensions as Integer
Dim sortvalue as Integer
Dim DisplayDummy
dimensions = 2
On Local Error Goto No2ndDim
k = Ubound(SortList(),2)
No2ndDim:
If Err &lt;&gt; 0 Then dimensions = 1
i = Ubound(SortList(),1)
If ismissing(sort2ndValue) then
sortvalue = 0
else
sortvalue = 1
end if
For s = 1 to i - 1
For t = 0 to i-s
Select Case dimensions
Case 1
If SortList(t) &gt; SortList(t+1) Then
DisplayDummy = SortList(t)
SortList(t) = SortList(t+1)
SortList(t+1) = DisplayDummy
End If
Case 2
If SortList(t,sortvalue) &gt; SortList(t+1,sortvalue) Then
For k = 0 to UBound(SortList(),2)
DisplayDummy = SortList(t,k)
SortList(t,k) = SortList(t+1,k)
SortList(t+1,k) = DisplayDummy
Next k
End If
End Select
Next t
Next s
BubbleSortList = SortList()
End Function
Function GetValueoutofList(SearchValue, BigList(), iDim as Integer, Optional ValueIndex)
Dim i as Integer
Dim MaxIndex as Integer
MaxIndex = Ubound(BigList(),1)
For i = 0 To MaxIndex
If BigList(i,0) = SearchValue Then
If Not IsMissing(ValueIndex) Then
ValueIndex = i
End If
GetValueOutOfList() = BigList(i,iDim)
End If
Next i
End Function
Function AddListtoList(ByVal FirstArray(), ByVal SecondArray(), Optional StartIndex)
Dim n as Integer
Dim m as Integer
Dim MaxIndex as Integer
MaxIndex = Ubound(FirstArray()) + Ubound(SecondArray()) + 1
If MaxIndex &gt; -1 Then
Dim ResultArray(MaxIndex)
For m = 0 To Ubound(FirstArray())
ResultArray(m) = FirstArray(m)
Next m
For n = 0 To Ubound(SecondArray())
ResultArray(m) = SecondArray(n)
m = m + 1
Next n
AddListToList() = ResultArray()
Else
Dim NullArray()
AddListToList() = NullArray()
End If
End Function
Function CheckDouble(DoubleString as String)
On Local Error Goto WRONGDATATYPE
CheckDouble() = CDbl(DoubleString)
WRONGDATATYPE:
If Err &lt;&gt; 0 Then
CheckDouble() = 0
Resume NoErr:
End If
NOERR:
End Function
</script:module>

311
tool-tech-file-view/LibreOfficePortable/App/libreoffice/share/basic/Tools/UCB.xba Normal file
View File

@@ -0,0 +1,311 @@
<?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">&apos;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) = &quot;*&quot;
ReadDirectories(&quot;file:///space&quot;, LocsfileContent(), True, False, false)
End Sub
&apos; 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
&apos; Todo: Is the last separator valid?
DirIndex = 0
sDirArray(iDirIndex) = AnchorDir
iDirCount = 1
oDocInfo = CreateUnoService(&quot;com.sun.star.document.DocumentProperties&quot;)
oUcbObject = createUnoService(&quot;com.sun.star.ucb.SimpleFileAccess&quot;)
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()) &lt;&gt; -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 &lt;&gt; &quot;&quot; Then
&apos; Retrieve the Index in the Array, where a Filename is positioned
If Not IsMissing(sFileContent()) Then
If (FieldInArray(sFileContent(), Ubound(sFileContent), RealFileContent)) Then
&apos; The extension of the current file passes the filter and is therefore admitted to the
&apos; fileList
If Not IsMissing(sExtension) Then
If sExtension &lt;&gt; &quot;&quot; Then
&apos; Consider that some Formats like old StarOffice Templates with the extension &quot;.vor&quot; can only be
&apos; 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 &gt;= iDirCount
If CurIndex &gt; -1 Then
ReDim Preserve sFileArray(CurIndex,1) as String
Else
ReDim sFileArray() as String
End If
Else
Msgbox(&quot;Directory &apos;&quot; &amp; ConvertFromUrl(AnchorDir) &amp; &quot;&apos; does not exist!&quot;, 16, GetProductName())
End If
ReadDirectories() = sFileArray()
Exit Function
FILESYSTEMPROBLEM:
Msgbox(&quot;Sorry, Filesystem Problem&quot;)
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)
&apos; 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 &lt;&gt; 0 Then
RetrieveDocTitle = &quot;&quot;
RESUME CLR_ERROR
End If
CLR_ERROR:
If sDocTitle = &quot;&quot; Then
sDocTitle = GetFileNameWithoutExtension(sFilename, &quot;/&quot;)
End If
RetrieveDocTitle = sDocTitle
End Function
&apos; Retrieves The Filecontent of a Document by extracting the content
&apos; from the Header of the document
Function GetRealFileContent(FileName as String) As String
On Local Error Goto NOFILE
oTypeDetect = createUnoService(&quot;com.sun.star.document.TypeDetection&quot;)
GetRealFileContent = oTypeDetect.queryTypeByURL(FileName)
NOFILE:
If Err &lt;&gt; 0 Then
GetRealFileContent = &quot;&quot;
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,&quot;/&quot;)
TargetDir = DeleteStr(TargetFile, TargetFileName)
CreateFolder(TargetDir)
CopyRecursively() = TargetFile
End Function
&apos; 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(&quot;org.openoffice.Office.Common/Help&quot;)
sSystem = oSystemNode.GetByName(&quot;System&quot;)
oLanguageNode = GetRegistryKeyContent(&quot;org.openoffice.Setup/L10N/&quot;)
sLocale = oLanguageNode.getByName(&quot;ooLocale&quot;)
sLocaleList() = ArrayoutofString(sLocale, &quot;-&quot;)
sLanguage = sLocaleList(0)
sHelpUrl = &quot;vnd.sun.star.help://&quot; &amp; sDocType &amp; &quot;/&quot; &amp; HelpID &amp; &quot;?Language=&quot; &amp; sLanguage &amp; &quot;&amp;System=&quot; &amp; sSystem
StarDesktop.LoadComponentfromUrl(sHelpUrl, &quot;OFFICE_HELP&quot;, 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) &amp; CHR(10)
oUcb = createUnoService(&quot;com.sun.star.ucb.SimpleFileAccess&quot;)
oOutputStream = createUnoService(&quot;com.sun.star.io.TextOutputStream&quot;)
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) &amp; 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(&quot;com.sun.star.ucb.SimpleFileAccess&quot;)
If oUcb.Exists(FilePath) Then
MaxIndex = 10
oInputStream = createUnoService(&quot;com.sun.star.io.TextInputStream&quot;)
oFile = oUcb.OpenFileReadWrite(FilePath)
oInputStream.SetInputStream(oFile.GetInputStream)
i = -1
Redim Preserve DataList(MaxIndex)
While Not oInputStream.IsEOF
i = i + 1
If i &gt; MaxIndex Then
MaxIndex = MaxIndex + 10
Redim Preserve DataList(MaxIndex)
End If
DataList(i) = oInputStream.ReadLine
Wend
If i &gt; -1 And i &lt;&gt; 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(&quot;com.sun.star.ucb.SimpleFileAccess&quot;)
On Local Error Goto NOSPACEONDRIVE
If Not oUcb.Exists(sNewFolder) Then
oUcb.CreateFolder(sNewFolder)
End If
CreateFolder = True
NOSPACEONDRIVE:
If Err &lt;&gt; 0 Then
If InitResources(&quot;&quot;) Then
ErrMsg = GetResText(&quot;RID_COMMON_0&quot;)
ErrMsg = ReplaceString(ErrMsg, chr(13), &quot;&lt;BR&gt;&quot;)
ErrMsg = ReplaceString(ErrMsg, sNewFolder, &quot;%1&quot;)
Msgbox(ErrMsg, 48, GetProductName())
End If
CreateFolder = False
Resume GOON
End If
GOON:
End Function
</script:module>

5
tool-tech-file-view/LibreOfficePortable/App/libreoffice/share/basic/Tools/dialog.xlb Normal file
View File

@@ -0,0 +1,5 @@
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE library:library PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "library.dtd">
<library:library xmlns:library="http://openoffice.org/2000/library" library:name="Tools" library:readonly="true" library:passwordprotected="false">
<library:element library:name="DlgOverwriteAll"/>
</library:library>

10
tool-tech-file-view/LibreOfficePortable/App/libreoffice/share/basic/Tools/script.xlb Normal file
View File

@@ -0,0 +1,10 @@
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE library:library PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "library.dtd">
<library:library xmlns:library="http://openoffice.org/2000/library" library:name="Tools" library:readonly="true" library:passwordprotected="false">
<library:element library:name="ModuleControls"/>
<library:element library:name="Strings"/>
<library:element library:name="Misc"/>
<library:element library:name="UCB"/>
<library:element library:name="Listbox"/>
<library:element library:name="Debug"/>
</library:library>