xref: /trunk/main/wizards/source/tools/Misc.xba (revision cdf0e10c)

<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="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
	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, wether it has to be loaded
&apos; or wether it is already on the desktop.
&apos; If the parameter bDisposable is set to False then then 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 ist 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 ist 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 over in Url-scription
&apos; The return-Value is in Urlscription
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;, &quot;com&quot;) Then
		ProductName = GetProductName()
		sError = GetResText(1006)
		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, ShortDescription as String) as boolean
	On Error Goto ErrorOcurred
	oResSrv = createUnoService( &quot;com.sun.star.resource.VclStringResourceLoader&quot; )
	If (IsNull(oResSrv)) then
		InitResources = FALSE
		MsgBox( Description &amp; &quot;: No resource loader found&quot;, 16, GetProductName())
	Else
		InitResources = TRUE
		oResSrv.FileName = ShortDescription
	End If
	Exit Function
ErrorOcurred:
	Dim nSolarVer
	InitResources = FALSE
	nSolarVer = GetSolarVersion()
	MsgBox(&quot;Resource file missing (&quot; &amp; ShortDescription  &amp; trim(str(nSolarVer)) + &quot;*.res)&quot;, 16, GetProductName())
	Resume CLERROR
	CLERROR:
End Function


Function GetResText( nID as integer ) As string
	On Error Goto ErrorOcurred
	If Not IsNull(oResSrv) Then
		GetResText = oResSrv.getString( nID )
	Else
		GetResText = &quot;&quot;
	End If
	Exit Function
ErrorOcurred:
	GetResText = &quot;&quot;
	MsgBox(&quot;Resource with ID =&quot; + str( nID ) + &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 ist passed over
&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 over 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


Function GetLocale(sLanguage as String, sCountry as String)
Dim oLocale as New com.sun.star.lang.Locale
	oLocale.Language = sLanguage
	oLocale.Country = sCountry
	GetLocale = oLocale
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;, &quot;com&quot;) Then
			Select Case sType
				Case &quot;swriter&quot;
					ErrMsg = GetResText(1001)
				Case &quot;scalc&quot;
					ErrMsg = GetResText(1002)
				Case &quot;simpress&quot;
					ErrMsg = GetResText(1003)
				Case &quot;sdraw&quot;
					ErrMsg = GetResText(1004)
				Case &quot;smath&quot;
					ErrMsg = GetResText(1005)
				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>