xref: /aoo41x/main/wizards/source/tools/Misc.xba (revision 3e02b54d)
1<?xml version="1.0" encoding="UTF-8"?>
2<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
3<!--***********************************************************
4 *
5 * Licensed to the Apache Software Foundation (ASF) under one
6 * or more contributor license agreements.  See the NOTICE file
7 * distributed with this work for additional information
8 * regarding copyright ownership.  The ASF licenses this file
9 * to you under the Apache License, Version 2.0 (the
10 * "License"); you may not use this file except in compliance
11 * with the License.  You may obtain a copy of the License at
12 *
13 *   http://www.apache.org/licenses/LICENSE-2.0
14 *
15 * Unless required by applicable law or agreed to in writing,
16 * software distributed under the License is distributed on an
17 * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
18 * KIND, either express or implied.  See the License for the
19 * specific language governing permissions and limitations
20 * under the License.
21 *
22 ***********************************************************-->
23<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Misc" script:language="StarBasic">REM  *****  BASIC  *****
24
25Const SBSHARE = 0
26Const SBUSER = 1
27Dim Taskindex as Integer
28Dim oResSrv as Object
29
30Sub Main()
31Dim PropList(3,1)&apos; as String
32	PropList(0,0) = &quot;URL&quot;
33	PropList(0,1) = &quot;sdbc:odbc:Erica_Test_Unicode&quot;
34	PropList(1,0) = &quot;User&quot;
35	PropList(1,1) = &quot;extra&quot;
36	PropList(2,0) = &quot;Password&quot;
37	PropList(2,1) = &quot;extra&quot;
38	PropList(3,0) = &quot;IsPasswordRequired&quot;
39	PropList(3,1) = True
40End Sub
41
42
43Function RegisterNewDataSource(DSName as  String, PropertyList(), Optional DriverProperties() as New com.sun.star.beans.PropertyValue)
44Dim oDataSource as Object
45Dim oDBContext as Object
46Dim oPropInfo as Object
47Dim i as Integer
48    oDBContext = createUnoService(&quot;com.sun.star.sdb.DatabaseContext&quot;)
49    oDataSource = createUnoService(&quot;com.sun.star.sdb.DataSource&quot;)
50	For i = 0 To Ubound(PropertyList(), 1)
51		sPropName = PropertyList(i,0)
52		sPropValue = PropertyList(i,1)
53		oDataSource.SetPropertyValue(sPropName,sPropValue)
54	Next i
55	If Not IsMissing(DriverProperties()) Then
56		oDataSource.Info() = DriverProperties()
57	End If
58    oDBContext.RegisterObject(DSName, oDataSource)
59	RegisterNewDataSource () = oDataSource
60End Function
61
62
63&apos; Connects to a registered Database
64Function ConnecttoDatabase(DSName as String, UserID as String, Password as String, Optional Propertylist(), Optional DriverProperties() as New com.sun.star.beans.PropertyValue)
65Dim oDBContext as Object
66Dim oDBSource as Object
67&apos;	On Local Error Goto NOCONNECTION
68	oDBContext = CreateUnoService(&quot;com.sun.star.sdb.DatabaseContext&quot;)
69	If oDBContext.HasbyName(DSName) Then
70		oDBSource = oDBContext.GetByName(DSName)
71		ConnectToDatabase = oDBSource.GetConnection(UserID, Password)
72	Else
73		If Not IsMissing(Namelist()) Then
74			If Not IsMissing(DriverProperties()) Then
75				RegisterNewDataSource(DSName, PropertyList(), DriverProperties())
76			Else
77				RegisterNewDataSource(DSName, PropertyList())
78			End If
79			oDBSource = oDBContext.GetByName(DSName)
80			ConnectToDatabase = oDBSource.GetConnection(UserID, Password)
81		Else
82			Msgbox(&quot;DataSource &quot; &amp; DSName &amp; &quot; is not registered&quot; , 16, GetProductname())
83			ConnectToDatabase() = NULL
84		End If
85	End If
86NOCONNECTION:
87	If Err &lt;&gt; 0 Then
88		Msgbox(Error$, 16, GetProductName())
89		Resume LEAVESUB
90		LEAVESUB:
91	End If
92End Function
93
94
95Function GetStarOfficeLocale() as New com.sun.star.lang.Locale
96Dim aLocLocale As New com.sun.star.lang.Locale
97Dim sLocale as String
98Dim sLocaleList(1)
99Dim oMasterKey
100	oMasterKey = GetRegistryKeyContent(&quot;org.openoffice.Setup/L10N/&quot;)
101	sLocale = oMasterKey.getByName(&quot;ooLocale&quot;)
102	sLocaleList() = ArrayoutofString(sLocale, &quot;-&quot;)
103	aLocLocale.Language = sLocaleList(0)
104	If Ubound(sLocaleList()) &gt; 0 Then
105		aLocLocale.Country = sLocaleList(1)
106	End If
107	GetStarOfficeLocale() = aLocLocale
108End Function
109
110
111Function GetRegistryKeyContent(sKeyName as string, Optional bforUpdate as Boolean)
112Dim oConfigProvider as Object
113Dim aNodePath(0) as new com.sun.star.beans.PropertyValue
114	oConfigProvider = createUnoService(&quot;com.sun.star.configuration.ConfigurationProvider&quot;)
115	aNodePath(0).Name = &quot;nodepath&quot;
116	aNodePath(0).Value = sKeyName
117	If IsMissing(bForUpdate) Then
118		GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments(&quot;com.sun.star.configuration.ConfigurationAccess&quot;, aNodePath())
119	Else
120		If bForUpdate Then
121			GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments(&quot;com.sun.star.configuration.ConfigurationUpdateAccess&quot;, aNodePath())
122		Else
123			GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments(&quot;com.sun.star.configuration.ConfigurationAccess&quot;, aNodePath())
124		End If
125	End If
126End Function
127
128
129Function GetProductname() as String
130Dim oProdNameAccess as Object
131Dim sVersion as String
132Dim sProdName as String
133	oProdNameAccess = GetRegistryKeyContent(&quot;org.openoffice.Setup/Product&quot;)
134	sProdName = oProdNameAccess.getByName(&quot;ooName&quot;)
135	sVersion = oProdNameAccess.getByName(&quot;ooSetupVersion&quot;)
136	GetProductName = sProdName &amp; sVersion
137End Function
138
139
140&apos; Opens a Document, checks beforehand, wether it has to be loaded
141&apos; or wether it is already on the desktop.
142&apos; If the parameter bDisposable is set to False then then returned document
143&apos; should not be disposed afterwards, because it is already opened.
144Function OpenDocument(DocPath as String, Args(), Optional bDisposable as Boolean)
145Dim oComponents as Object
146Dim oComponent as Object
147	&apos; Search if one of the active Components ist the one that you search for
148	oComponents = StarDesktop.Components.CreateEnumeration
149	While oComponents.HasmoreElements
150		oComponent = oComponents.NextElement
151		If hasUnoInterfaces(oComponent,&quot;com.sun.star.frame.XModel&quot;) then
152			If UCase(oComponent.URL) = UCase(DocPath) then
153				OpenDocument() = oComponent
154				If Not IsMissing(bDisposable) Then
155					bDisposable = False
156				End If
157				Exit Function
158			End If
159		End If
160	Wend
161	If Not IsMissing(bDisposable) Then
162		bDisposable = True
163	End If
164	OpenDocument() = StarDesktop.LoadComponentFromURL(DocPath,&quot;_default&quot;,0,Args())
165End Function
166
167
168Function TaskonDesktop(DocPath as String) as Boolean
169Dim oComponents as Object
170Dim oComponent as Object
171	&apos; Search if one of the active Components ist the one that you search for
172	oComponents = StarDesktop.Components.CreateEnumeration
173	While oComponents.HasmoreElements
174		oComponent = oComponents.NextElement
175  	  	If hasUnoInterfaces(oComponent,&quot;com.sun.star.frame.XModel&quot;) then
176			If UCase(oComponent.URL) = UCase(DocPath) then
177				TaskonDesktop = True
178				Exit Function
179			End If
180		End If
181	Wend
182	TaskonDesktop = False
183End Function
184
185
186&apos; Retrieves a FileName out of a StarOffice-Document
187Function RetrieveFileName(LocDoc as Object)
188Dim LocURL as String
189Dim LocURLArray() as String
190Dim MaxArrIndex as integer
191
192	LocURL = LocDoc.Url
193	LocURLArray() = ArrayoutofString(LocURL,&quot;/&quot;,MaxArrIndex)
194	RetrieveFileName = LocURLArray(MaxArrIndex)
195End Function
196
197
198&apos; Gets a special configured PathSetting
199Function GetPathSettings(sPathType as String,  Optional bshowall as Boolean, Optional ListIndex as integer) as String
200Dim oSettings, oPathSettings as Object
201Dim sPath as String
202Dim PathList() as String
203Dim MaxIndex as Integer
204Dim oPS as Object
205
206	oPS = createUnoService(&quot;com.sun.star.util.PathSettings&quot;)
207
208  	If Not IsMissing(bShowall) Then
209		If bShowAll Then
210			ShowPropertyValues(oPS)
211			Exit Function
212		End If
213	End If
214 	sPath = oPS.getPropertyValue(sPathType)
215	If Not IsMissing(ListIndex) Then
216		&apos; Share and User-Directory
217		If Instr(1,sPath,&quot;;&quot;) &lt;&gt; 0 Then
218			PathList = ArrayoutofString(sPath,&quot;;&quot;, MaxIndex)
219			If ListIndex &lt;= MaxIndex Then
220				sPath = PathList(ListIndex)
221			Else
222				Msgbox(&quot;String Cannot be analyzed!&quot; &amp; sPath , 16, GetProductName())
223			End If
224		End If
225	End If
226	If Instr(1, sPath, &quot;;&quot;) = 0 Then
227		GetPathSettings = ConvertToUrl(sPath)
228	Else
229		GetPathSettings = sPath
230	End If
231
232End Function
233
234
235
236&apos; Gets the fully qualified path to a subdirectory of the
237&apos; Template Directory, e. g. with the parameter &quot;wizard/bitmap&quot;
238&apos; The parameter must be passed over in Url-scription
239&apos; The return-Value is in Urlscription
240Function GetOfficeSubPath(sOfficePath as String, ByVal sSubDir as String)
241Dim sOfficeString as String
242Dim sOfficeList() as String
243Dim sOfficeDir as String
244Dim sBigDir as String
245Dim i as Integer
246Dim MaxIndex as Integer
247Dim oUcb as Object
248	oUcb = createUnoService(&quot;com.sun.star.ucb.SimpleFileAccess&quot;)
249	sOfficeString = GetPathSettings(sOfficePath)
250	If Right(sSubDir,1) &lt;&gt; &quot;/&quot; Then
251		sSubDir = sSubDir &amp; &quot;/&quot;
252	End If
253	sOfficeList() = ArrayoutofString(sOfficeString,&quot;;&quot;, MaxIndex)
254	For i = 0 To MaxIndex
255		sOfficeDir = ConvertToUrl(sOfficeList(i))
256		If Right(sOfficeDir,1) &lt;&gt; &quot;/&quot; Then
257			sOfficeDir = sOfficeDir &amp; &quot;/&quot;
258		End If
259		sBigDir = sOfficeDir &amp; sSubDir
260		If oUcb.Exists(sBigDir) Then
261			GetOfficeSubPath() = sBigDir
262			Exit Function
263		End If
264	Next i
265	ShowNoOfficePathError()
266	GetOfficeSubPath = &quot;&quot;
267End Function
268
269
270Sub ShowNoOfficePathError()
271Dim ProductName as String
272Dim sError as String
273Dim bResObjectexists as Boolean
274Dim oLocResSrv as Object
275	bResObjectexists = not IsNull(oResSrv)
276	If bResObjectexists Then
277		oLocResSrv = oResSrv
278	End If
279	If InitResources(&quot;Tools&quot;, &quot;com&quot;) Then
280		ProductName = GetProductName()
281		sError = GetResText(1006)
282		sError = ReplaceString(sError, ProductName, &quot;%PRODUCTNAME&quot;)
283		sError = ReplaceString(sError, chr(13), &quot;&lt;BR&gt;&quot;)
284		MsgBox(sError, 16, ProductName)
285	End If
286	If bResObjectexists Then
287		oResSrv = oLocResSrv
288	End If
289
290End Sub
291
292
293Function InitResources(Description, ShortDescription as String) as boolean
294	On Error Goto ErrorOcurred
295	oResSrv = createUnoService( &quot;com.sun.star.resource.VclStringResourceLoader&quot; )
296	If (IsNull(oResSrv)) then
297		InitResources = FALSE
298		MsgBox( Description &amp; &quot;: No resource loader found&quot;, 16, GetProductName())
299	Else
300		InitResources = TRUE
301		oResSrv.FileName = ShortDescription
302	End If
303	Exit Function
304ErrorOcurred:
305	Dim nSolarVer
306	InitResources = FALSE
307	nSolarVer = GetSolarVersion()
308	MsgBox(&quot;Resource file missing (&quot; &amp; ShortDescription  &amp; trim(str(nSolarVer)) + &quot;*.res)&quot;, 16, GetProductName())
309	Resume CLERROR
310	CLERROR:
311End Function
312
313
314Function GetResText( nID as integer ) As string
315	On Error Goto ErrorOcurred
316	If Not IsNull(oResSrv) Then
317		GetResText = oResSrv.getString( nID )
318	Else
319		GetResText = &quot;&quot;
320	End If
321	Exit Function
322ErrorOcurred:
323	GetResText = &quot;&quot;
324	MsgBox(&quot;Resource with ID =&quot; + str( nID ) + &quot; not found!&quot;, 16, GetProductName())
325	Resume CLERROR
326	CLERROR:
327End Function
328
329
330Function CutPathView(sDocUrl as String, Optional PathLen as Integer)
331Dim sViewPath as String
332Dim FileName as String
333Dim iFileLen as Integer
334	sViewPath = ConvertfromURL(sDocURL)
335	iViewPathLen = Len(sViewPath)
336	If iViewPathLen &gt; 60 Then
337		FileName = FileNameoutofPath(sViewPath, &quot;/&quot;)
338		iFileLen = Len(FileName)
339		If iFileLen &lt; 44 Then
340			sViewPath = Left(sViewPath,57-iFileLen-10) &amp; &quot;...&quot; &amp; Right(sViewPath,iFileLen + 10)
341		Else
342			sViewPath = Left(sViewPath,27) &amp; &quot; ... &quot; &amp; Right(sViewPath,28)
343		End If
344	End If
345	CutPathView = sViewPath
346End Function
347
348
349&apos; Deletes the content of all cells that are softformatted according
350&apos; to the &apos;InputStyleName&apos;
351Sub DeleteInputCells(oSheet as Object, InputStyleName as String)
352Dim oRanges as Object
353Dim oRange as Object
354	oRanges = oSheet.CellFormatRanges.createEnumeration
355	While oRanges.hasMoreElements
356		oRange = oRanges.NextElement
357		If Instr(1,oRange.CellStyle, InputStyleName) &lt;&gt; 0 Then
358			Call ReplaceRangeValues(oRange, &quot;&quot;)
359		End If
360	Wend
361End Sub
362
363
364&apos; Inserts a certain String to all cells of a Range that ist passed over
365&apos; either as an object or as the RangeName
366Sub ChangeValueofRange(oSheet as Object, Range, ReplaceValue, Optional StyleName as String)
367Dim oCellRange as Object
368	If Vartype(Range) = 8 Then
369		&apos; Get the Range out of the Rangename
370		oCellRange = oSheet.GetCellRangeByName(Range)
371	Else
372		&apos; The range is passed over as an object
373		Set oCellRange = Range
374	End If
375	If IsMissing(StyleName) Then
376		ReplaceRangeValues(oCellRange, ReplaceValue)
377	Else
378		If Instr(1,oCellRange.CellStyle,StyleName) Then
379			ReplaceRangeValues(oCellRange, ReplaceValue)
380		End If
381	End If
382End Sub
383
384
385Sub ReplaceRangeValues(oRange as Object, ReplaceValue)
386Dim oRangeAddress as Object
387Dim ColCount as Integer
388Dim RowCount as Integer
389Dim i as Integer
390	oRangeAddress = oRange.RangeAddress
391	ColCount = oRangeAddress.EndColumn - oRangeAddress.StartColumn
392	RowCount = oRangeAddress.EndRow - oRangeAddress.StartRow
393	Dim FillArray(RowCount) as Variant
394	Dim sLine(ColCount) as Variant
395	For i = 0 To ColCount
396		sLine(i) = ReplaceValue
397	Next i
398	For i = 0 To RowCount
399		FillArray(i) = sLine()
400	Next i
401	oRange.DataArray = FillArray()
402End Sub
403
404
405&apos; Returns the Value of the first cell of a Range
406Function GetValueofCellbyName(oSheet as Object, sCellName as String)
407Dim oCell as Object
408	oCell = GetCellByName(oSheet, sCellName)
409	GetValueofCellbyName = oCell.Value
410End Function
411
412
413Function DuplicateRow(oSheet as Object, RangeName as String)
414Dim oRange as Object
415Dim oCell as Object
416Dim oCellAddress as New com.sun.star.table.CellAddress
417Dim oRangeAddress as New com.sun.star.table.CellRangeAddress
418	oRange = oSheet.GetCellRangeByName(RangeName)
419	oRangeAddress = oRange.RangeAddress
420	oCell = oSheet.GetCellByPosition(oRangeAddress.StartColumn,oRangeAddress.StartRow)
421	oCellAddress = oCell.CellAddress
422	oSheet.Rows.InsertByIndex(oCellAddress.Row,1)
423	oRangeAddress = oRange.RangeAddress
424	oSheet.CopyRange(oCellAddress, oRangeAddress)
425	DuplicateRow = oRangeAddress.StartRow-1
426End Function
427
428
429&apos; Returns the String of the first cell of a Range
430Function GetStringofCellbyName(oSheet as Object, sCellName as String)
431Dim oCell as Object
432	oCell = GetCellByName(oSheet, sCellName)
433	GetStringofCellbyName = oCell.String
434End Function
435
436
437&apos; Returns a named Cell
438Function GetCellByName(oSheet as Object, sCellName as String) as Object
439Dim oCellRange as Object
440Dim oCellAddress as Object
441	oCellRange = oSheet.GetCellRangeByName(sCellName)
442	oCellAddress = oCellRange.RangeAddress
443	GetCellByName = oSheet.GetCellByPosition(oCellAddress.StartColumn,oCellAddress.StartRow)
444End Function
445
446
447&apos; Changes the numeric Value of a cell by transmitting the String of the numeric Value
448Sub ChangeCellValue(oCell as Object, ValueString as String)
449Dim CellValue
450	oCell.Formula = &quot;=Value(&quot; &amp; &quot;&quot;&quot;&quot; &amp; ValueString &amp; &quot;&quot;&quot;&quot; &amp; &quot;)&quot;
451	CellValue = oCell.Value
452	oCell.Formula = &quot;&quot;
453	oCell.Value = CellValue
454End Sub
455
456
457Function GetDocumentType(oDocument)
458	On Local Error GoTo NODOCUMENTTYPE
459&apos;	ShowSupportedServiceNames(oDocument)
460	If oDocument.SupportsService(&quot;com.sun.star.sheet.SpreadsheetDocument&quot;) Then
461		GetDocumentType() = &quot;scalc&quot;
462	ElseIf oDocument.SupportsService(&quot;com.sun.star.text.TextDocument&quot;) Then
463		GetDocumentType() = &quot;swriter&quot;
464	ElseIf oDocument.SupportsService(&quot;com.sun.star.drawing.DrawingDocument&quot;) Then
465		GetDocumentType() = &quot;sdraw&quot;
466	ElseIf oDocument.SupportsService(&quot;com.sun.star.presentation.PresentationDocument&quot;) Then
467		GetDocumentType() = &quot;simpress&quot;
468	ElseIf oDocument.SupportsService(&quot;com.sun.star.formula.FormulaProperties&quot;) Then
469		GetDocumentType() = &quot;smath&quot;
470	End If
471	NODOCUMENTTYPE:
472	If Err &lt;&gt; 0 Then
473		GetDocumentType = &quot;&quot;
474		Resume GOON
475		GOON:
476	End If
477End Function
478
479
480Function GetNumberFormatType(oDocFormats, oFormatObject as Object) as Integer
481Dim ThisFormatKey as Long
482Dim oObjectFormat as Object
483	On Local Error Goto NOFORMAT
484	ThisFormatKey = oFormatObject.NumberFormat
485	oObjectFormat = oDocFormats.GetByKey(ThisFormatKey)
486	GetNumberFormatType = oObjectFormat.Type
487	NOFORMAT:
488	If Err &lt;&gt; 0 Then
489		Msgbox(&quot;Numberformat of Object is not available!&quot;, 16, GetProductName())
490		GetNumberFormatType = 0
491		GOTO NOERROR
492	End If
493	NOERROR:
494	On Local Error Goto 0
495End Function
496
497
498Sub ProtectSheets(Optional oSheets as Object)
499Dim i as Integer
500Dim oDocSheets as Object
501	If IsMissing(oSheets) Then
502		oDocSheets = StarDesktop.CurrentFrame.Controller.Model.Sheets
503	Else
504		Set oDocSheets = oSheets
505	End If
506
507	For i = 0 To oDocSheets.Count-1
508		oDocSheets(i).Protect(&quot;&quot;)
509	Next i
510End Sub
511
512
513Sub UnprotectSheets(Optional oSheets as Object)
514Dim i as Integer
515Dim oDocSheets as Object
516	If IsMissing(oSheets) Then
517		oDocSheets = StarDesktop.CurrentFrame.Controller.Model.Sheets
518	Else
519		Set oDocSheets = oSheets
520	End If
521
522	For i = 0 To oDocSheets.Count-1
523		oDocSheets(i).Unprotect(&quot;&quot;)
524	Next i
525End Sub
526
527
528Function GetRowIndex(oSheet as Object, RowName as String)
529Dim oRange as Object
530	oRange = oSheet.GetCellRangeByName(RowName)
531	GetRowIndex = oRange.RangeAddress.StartRow
532End Function
533
534
535Function GetColumnIndex(oSheet as Object, ColName as String)
536Dim oRange as Object
537	oRange = oSheet.GetCellRangeByName(ColName)
538	GetColumnIndex = oRange.RangeAddress.StartColumn
539End Function
540
541
542Function CopySheetbyName(oSheets as Object, OldName as String, NewName as String, DestPos as Integer) as Object
543Dim oSheet as Object
544Dim Count as Integer
545Dim BasicSheetName as String
546
547	BasicSheetName = NewName
548	&apos; Copy the last table. Assumption: The last table is the template
549	On Local Error Goto RENAMESHEET
550	oSheets.CopybyName(OldName, NewName, DestPos)
551
552RENAMESHEET:
553	oSheet = oSheets(DestPos)
554	If Err &lt;&gt; 0 Then
555		&apos; Test if renaming failed
556		Count = 2
557		Do While oSheet.Name &lt;&gt; NewName
558			NewName = BasicSheetName &amp; &quot;_&quot; &amp; Count
559			oSheet.Name = NewName
560			Count = Count + 1
561		Loop
562		Resume CL_ERROR
563CL_ERROR:
564	End If
565	CopySheetbyName = oSheet
566End Function
567
568
569&apos; Dis-or enables a Window and adjusts the mousepointer accordingly
570Sub ToggleWindow(bDoEnable as Boolean)
571Dim oWindow as Object
572	oWindow = StarDesktop.CurrentFrame.ComponentWindow
573	oWindow.Enable = bDoEnable
574End Sub
575
576
577Function CheckNewSheetname(oSheets as Object, Sheetname as String, Optional oLocale) as String
578Dim nStartFlags as Long
579Dim nContFlags as Long
580Dim oCharService as Object
581Dim iSheetNameLength as Integer
582Dim iResultPos as Integer
583Dim WrongChar as String
584Dim oResult as Object
585	nStartFlags = com.sun.star.i18n.KParseTokens.ANY_LETTER_OR_NUMBER + com.sun.star.i18n.KParseTokens.ASC_UNDERSCORE
586	nContFlags = nStartFlags
587	oCharService = CreateUnoService(&quot;com.sun.star.i18n.CharacterClassification&quot;)
588	iSheetNameLength = Len(SheetName)
589	If IsMissing(oLocale) Then
590		oLocale = ThisComponent.CharLocale
591	End If
592	Do
593		oResult =oCharService.parsePredefinedToken(com.sun.star.i18n.KParseType.IDENTNAME, SheetName, 0, oLocale, nStartFlags, &quot;&quot;, nContFlags, &quot; &quot;)
594		iResultPos = oResult.EndPos
595		If iResultPos &lt; iSheetNameLength Then
596			WrongChar = Mid(SheetName, iResultPos+1,1)
597			SheetName = ReplaceString(SheetName,&quot;_&quot;, WrongChar)
598		End If
599	Loop Until iResultPos = iSheetNameLength
600	CheckNewSheetname = SheetName
601End Function
602
603
604Sub AddNewSheetName(oSheets as Object, ByVal SheetName as String)
605Dim Count as Integer
606Dim bSheetIsThere as Boolean
607Dim iSheetNameLength as Integer
608	iSheetNameLength = Len(SheetName)
609	Count = 2
610	Do
611		bSheetIsThere = oSheets.HasByName(SheetName)
612		If bSheetIsThere Then
613			SheetName = Right(SheetName,iSheetNameLength) &amp; &quot;_&quot; &amp; Count
614			Count = Count + 1
615		End If
616	Loop Until Not bSheetIsThere
617	AddNewSheetname = SheetName
618End Sub
619
620
621Function GetSheetIndex(oSheets, sName) as Integer
622Dim i as Integer
623	For i = 0 To oSheets.Count-1
624		If oSheets(i).Name = sName Then
625			GetSheetIndex = i
626			exit Function
627		End If
628	Next i
629	GetSheetIndex = -1
630End Function
631
632
633Function GetLastUsedRow(oSheet as Object) as Integer
634Dim oCell As Object
635Dim oCursor As Object
636Dim aAddress As Variant
637	oCell = oSheet.GetCellbyPosition(0, 0)
638	oCursor = oSheet.createCursorByRange(oCell)
639	oCursor.GotoEndOfUsedArea(True)
640	aAddress = oCursor.RangeAddress
641	GetLastUsedRow = aAddress.EndRow
642End Function
643
644
645&apos; Note To set a one lined frame you have to set the inner width to 0
646&apos; In the API all Units that refer to pt-Heights are &quot;1/100mm&quot;
647&apos; The convert factor from 1pt to 1/100 mm is approximately 35
648Function ModifyBorderLineWidth(ByVal oStyleBorder, iInnerLineWidth as Integer, iOuterLineWidth as Integer)
649Dim aBorder as New com.sun.star.table.BorderLine
650	aBorder = oStyleBorder
651	aBorder.InnerLineWidth = iInnerLineWidth
652	aBorder.OuterLineWidth = iOuterLineWidth
653	ModifyBorderLineWidth = aBorder
654End Function
655
656
657Sub AttachBasicMacroToEvent(oDocument as Object, EventName as String, SubPath as String)
658Dim PropValue(1) as new com.sun.star.beans.PropertyValue
659	PropValue(0).Name = &quot;EventType&quot;
660	PropValue(0).Value = &quot;StarBasic&quot;
661	PropValue(1).Name = &quot;Script&quot;
662	PropValue(1).Value = &quot;macro:///&quot; &amp; SubPath
663	oDocument.Events.ReplaceByName(EventName, PropValue())
664End Sub
665
666
667
668Function ModifyPropertyValue(oContent() as New com.sun.star.beans.PropertyValue, TargetProperties() as New com.sun.star.beans.PropertyValue)
669Dim MaxIndex as Integer
670Dim i as Integer
671Dim a as Integer
672	MaxIndex = Ubound(oContent())
673	bDoReplace = False
674	For i = 0 To MaxIndex
675		a = GetPropertyValueIndex(oContent(i).Name, TargetProperties())
676		If a &lt;&gt; -1 Then
677			If Vartype(TargetProperties(a).Value) &lt;&gt; 9 Then
678				If TargetProperties(a).Value &lt;&gt; oContent(i).Value Then
679					oContent(i).Value = TargetProperties(a).Value
680					bDoReplace = True
681				End If
682			Else
683				If Not EqualUnoObjects(TargetProperties(a).Value, oContent(i).Value) Then
684					oContent(i).Value = TargetProperties(a).Value
685					bDoReplace = True
686				End If
687			End If
688		End If
689	Next i
690	ModifyPropertyValue() = bDoReplace
691End Function
692
693
694Function GetPropertyValueIndex(SearchName as String, TargetProperties() as New com.sun.star.beans.PropertyValue ) as Integer
695Dim i as Integer
696	For i = 0 To Ubound(TargetProperties())
697		If Searchname = TargetProperties(i).Name Then
698			GetPropertyValueIndex = i
699			Exit Function
700		End If
701	Next i
702	GetPropertyValueIndex() = -1
703End Function
704
705
706Sub DispatchSlot(SlotID as Integer)
707Dim oArg() as new com.sun.star.beans.PropertyValue
708Dim oUrl as new com.sun.star.util.URL
709Dim oTrans as Object
710Dim oDisp as Object
711	oTrans = createUNOService(&quot;com.sun.star.util.URLTransformer&quot;)
712	oUrl.Complete = &quot;slot:&quot; &amp; CStr(SlotID)
713	oTrans.parsestrict(oUrl)
714	oDisp = StarDesktop.ActiveFrame.queryDispatch(oUrl, &quot;_self&quot;, 0)
715	oDisp.dispatch(oUrl, oArg())
716End Sub
717
718
719&apos;returns the type of the office application
720&apos;FatOffice = 0, WebTop = 1
721&apos;This routine has to be changed if the Product Name is being changed!
722Function IsFatOffice() As Boolean
723  If sProductname = &quot;&quot; Then
724    sProductname = GetProductname()
725  End If
726  IsFatOffice = TRUE
727  &apos;The following line has to include the current productname
728  If Instr(1,sProductname,&quot;WebTop&quot;,1) &lt;&gt; 0 Then
729    IsFatOffice = FALSE
730  End If
731End Function
732
733
734Function GetLocale(sLanguage as String, sCountry as String)
735Dim oLocale as New com.sun.star.lang.Locale
736	oLocale.Language = sLanguage
737	oLocale.Country = sCountry
738	GetLocale = oLocale
739End Function
740
741
742Sub ToggleDesignMode(oDocument as Object)
743Dim aSwitchMode as new com.sun.star.util.URL
744	aSwitchMode.Complete = &quot;.uno:SwitchControlDesignMode&quot;
745	aTransformer = createUnoService(&quot;com.sun.star.util.URLTransformer&quot;)
746	aTransformer.parseStrict(aSwitchMode)
747	oFrame = oDocument.currentController.Frame
748	oDispatch = oFrame.queryDispatch(aSwitchMode, oFrame.Name, 63)
749        Dim aEmptyArgs() as New com.sun.star.bean.PropertyValue
750	oDispatch.dispatch(aSwitchMode, aEmptyArgs())
751	Erase aSwitchMode
752End Sub
753
754
755Function isHighContrast(oPeer as Object)
756	Dim UIColor as Long
757	Dim myRed as Integer
758	Dim myGreen as Integer
759	Dim myBlue as Integer
760	Dim myLuminance as Double
761
762	UIColor = oPeer.getProperty( &quot;DisplayBackgroundColor&quot; )
763	myRed = Red (UIColor)
764	myGreen = Green (UIColor)
765	myBlue = Blue (UIColor)
766	myLuminance = (( myBlue*28 + myGreen*151 + myRed*77 ) / 256	)
767	isHighContrast = false
768	If myLuminance &lt;= 25 Then isHighContrast = true
769End Function
770
771
772Function CreateNewDocument(sType as String, Optional sAddMsg as String) as Object
773Dim NoArgs() as new com.sun.star.beans.PropertyValue
774Dim oDocument as Object
775Dim sUrl as String
776Dim ErrMsg as String
777	On Local Error Goto NOMODULEINSTALLED
778	sUrl = &quot;private:factory/&quot; &amp; sType
779	oDocument = StarDesktop.LoadComponentFromURL(sUrl,&quot;_default&quot;,0, NoArgs())
780NOMODULEINSTALLED:
781	If (Err &lt;&gt; 0) OR IsNull(oDocument) Then
782		If InitResources(&quot;&quot;, &quot;com&quot;) Then
783			Select Case sType
784				Case &quot;swriter&quot;
785					ErrMsg = GetResText(1001)
786				Case &quot;scalc&quot;
787					ErrMsg = GetResText(1002)
788				Case &quot;simpress&quot;
789					ErrMsg = GetResText(1003)
790				Case &quot;sdraw&quot;
791					ErrMsg = GetResText(1004)
792				Case &quot;smath&quot;
793					ErrMsg = GetResText(1005)
794				Case Else
795					ErrMsg = &quot;Invalid Document Type!&quot;
796			End Select
797			ErrMsg = ReplaceString(ErrMsg, chr(13), &quot;&lt;BR&gt;&quot;)
798			If Not IsMissing(sAddMsg) Then
799				ErrMsg = ErrMsg &amp; chr(13) &amp; sAddMsg
800			End If
801			Msgbox(ErrMsg, 48, GetProductName())
802		End If
803		If Err &lt;&gt; 0 Then
804			Resume GOON
805		End If
806	End If
807GOON:
808	CreateNewDocument = oDocument
809End Function
810
811
812&apos; This Sub has been used in order to ensure that after disposing a document
813&apos; from the backing window it is returned to the backing window, so the
814&apos; office won&apos;t be closed
815Sub DisposeDocument(oDocument as Object)
816Dim dispatcher as Object
817Dim parser as Object
818Dim disp as Object
819Dim url	as new com.sun.star.util.URL
820Dim NoArgs() as New com.sun.star.beans.PropertyValue
821Dim oFrame as Object
822	If Not IsNull(oDocument) Then
823		oDocument.setModified(false)
824		parser   = createUnoService(&quot;com.sun.star.util.URLTransformer&quot;)
825		url.Complete = &quot;.uno:CloseDoc&quot;
826		parser.parseStrict(url)
827		oFrame = oDocument.CurrentController.Frame
828		disp = oFrame.queryDispatch(url,&quot;_self&quot;, com.sun.star.util.SearchFlags.NORM_WORD_ONLY)
829		disp.dispatch(url, NoArgs())
830	End If
831End Sub
832
833&apos;Function to calculate if the year is a leap year
834Function CalIsLeapYear(ByVal iYear as Integer) as Boolean
835        CalIsLeapYear = ((iYear Mod 4 = 0) And ((iYear Mod 100 &lt;&gt; 0) Or (iYear Mod 400 = 0)))
836End Function
837</script:module>
838