summaryrefslogtreecommitdiff
path: root/wizards/source/tools/Misc.xba
blob: 2bf17d32e984dbfecc9180c504e93a9d2281502a (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
<?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(Namelist()) Then
			If Not IsMissing(DriverProperties()) Then
				RegisterNewDataSource(DSName, PropertyList(), DriverProperties())
			Else
				RegisterNewDataSource(DSName, PropertyList())
			End If
			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
		GetRegistryKeyContent() = oConfigProvider.createInstanceWithArguments(&quot;com.sun.star.configuration.ConfigurationAccess&quot;, aNodePath())
	Else
		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 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 ErrorOcurred
	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
ErrorOcurred:
	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 ErrorOcurred
	If Not IsNull(oResSrv) Then
		sString = oResSrv.resolveString(sID)
		GetResText = ReplaceString(sString, GetProductname(), &quot;%PRODUCTNAME&quot;)
	Else
		GetResText = &quot;&quot;
	End If
	Exit Function
ErrorOcurred:
	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 Integer
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>