REM ***** BASIC ***** Option Explicit Public Const SBMAXTEXTSIZE = 50 Function SetProgressValue(iValue as Integer) If iValue = 0 Then oProgressbar.End End If ProgressValue = iValue oProgressbar.Value = iValue End Function Function GetPreferredWidth(oModel as Object, bGetMaxWidth as Boolean, Optional LocText) Dim aPeerSize as new com.sun.star.awt.Size Dim nWidth as Integer Dim oControl as Object If Not IsMissing(LocText) Then ' Label aPeerSize = GetPeerSize(oModel, oControl, LocText) ElseIf CurControlType = cImageControl Then GetPreferredWidth() = 2000 Exit Function Else aPeerSize = GetPeerSize(oModel, oControl) End If nWidth = aPeerSize.Width ' We increase the preferred Width a bit so that the control does not become too small ' when we change the border from "3D" to "Flat" GetPreferredWidth = (nWidth + 10) * XPixelFactor ' PixelTo100thmm(nWidth) End Function Function GetPreferredHeight(oModel as Object, Optional LocText) Dim aPeerSize as new com.sun.star.awt.Size Dim nHeight as Integer Dim oControl as Object If Not IsMissing(LocText) Then ' Label aPeerSize = GetPeerSize(oModel, oControl, LocText) ElseIf CurControlType = cImageControl Then GetPreferredHeight() = 2000 Exit Function Else aPeerSize = GetPeerSize(oModel, oControl) End If nHeight = aPeerSize.Height ' We increase the preferred Height a bit so that the control does not become too small ' when we change the border from "3D" to "Flat" GetPreferredHeight = (nHeight+1) * YPixelFactor ' PixelTo100thmm(nHeight) End Function Function GetPeerSize(oModel as Object, oControl as Object, Optional LocText) Dim oPeer as Object Dim aPeerSize as new com.sun.star.awt.Size Dim NullValue oControl = oController.GetControl(oModel) oPeer = oControl.GetPeer() If oControl.Model.PropertySetInfo.HasPropertybyName("EffectiveMax") Then If oControl.Model.EffectiveMax = 0 Then ' This is relevant for decimal fields oControl.Model.EffectiveValue = 999.9999 Else oControl.Model.EffectiveValue = oControl.Model.EffectiveMax End If GetPeerSize() = oPeer.PreferredSize() oControl.Model.EffectiveValue = NullValue ElseIf Not IsMissing(LocText) Then oControl.Text = LocText GetPeerSize() = oPeer.PreferredSize() ElseIf CurFieldType = com.sun.star.sdbc.DataType.BIT Then GetPeerSize() = oPeer.PreferredSize() ElseIf CurFieldType = com.sun.star.sdbc.DataType.BOOLEAN Then GetPeerSize() = oPeer.PreferredSize() ElseIf CurFieldType = com.sun.star.sdbc.DataType.DATE Then oControl.Model.Date = Date GetPeerSize() = oPeer.PreferredSize() oControl.Model.Date = NullValue ElseIf CurFieldType = com.sun.star.sdbc.DataType.TIME Then oControl.Time = Time GetPeerSize() = oPeer.PreferredSize() oControl.Time = NullValue Else If oControl.MaxTextLen > SBMAXTEXTSIZE Then oControl.Text = Mid(SBSIZETEXT,1, SBMAXTEXTSIZE) Else oControl.Text = Mid(SBSIZETEXT,1, oControl.MaxTextLen) End If GetPeerSize() = oPeer.PreferredSize() oControl.Text = "" End If End Function Function TwipToCM(BYVAL nValue as long) as String TwipToCM = trim(str(nValue / 567)) + "cm" End function Function TwipTo100telMM(BYVAL nValue as long) as long TwipTo100telMM = nValue / 0.567 End function Function TwipToPixel(BYVAL nValue as long) as long ' not an exact calculation TwipToPixel = nValue / 15 End function Function PixelTo100thMMX(oControl as Object) as long oPeer = oControl.GetPeer() PixelTo100mmX = Clng(Peer.GetInfo.PixelPerMeterX/100000) ' PixelTo100thMM = nValue * 28 ' not an exact calculation End function Function PixelTo100thMMY(oControl as Object) as long oPeer = oControl.GetPeer() PixelTo100mmX = Clng(Peer.GetInfo.PixelPerMeterY/100000) ' PixelTo100thMM = nValue * 28 ' not an exact calculation End function Function GetPoint(xPos, YPos) as New com.sun.star.awt.Point Dim aPoint as New com.sun.star.awt.Point aPoint.X = xPos aPoint.Y = yPos GetPoint() = aPoint End Function Function GetSize(iWidth, iHeight) As New com.sun.star.awt.Size Dim aSize As New com.sun.star.awt.Size aSize.Width = iWidth aSize.Height = iHeight GetSize() = aSize End Function Sub ImportStyles() Dim OldIndex as Integer If Not bDebug Then On Local Error GoTo WIZARDERROR End If OldIndex = CurIndex CurIndex = GetCurIndex(DialogModel.lstStyles, Styles(),8) If CurIndex <> OldIndex Then ToggleLayoutPage(False) Dim sImportPath as String sImportPath = Styles(CurIndex, 8) bWithBackGraphic = LoadNewStyles(oDocument, DialogModel, CurIndex, sImportPath, Styles(), TexturePath) ControlCaptionsToStandardLayout() ToggleLayoutPage(True, "lstStyles") End If WIZARDERROR: If Err <> 0 Then Msgbox(sMsgErrMsg, 16, GetProductName()) Resume LOCERROR LOCERROR: End If End Sub Function SetNumerics(ByVal oLocObject as Object, iLocFieldType as Integer) as Object If CurControlType = cNumericBox Then oLocObject.TreatAsNumber = True Select Case iLocFieldType Case com.sun.star.sdbc.DataType.BIGINT oLocObject.EffectiveMax = 2147483647 * 2147483647 oLocObject.EffectiveMin = -(-2147483648 * -2147483648) ' oLocObject.DecimalAccuracy = 0 Case com.sun.star.sdbc.DataType.INTEGER oLocObject.EffectiveMax = 2147483647 oLocObject.EffectiveMin = -2147483648 Case com.sun.star.sdbc.DataType.SMALLINT oLocObject.EffectiveMax = 32767 oLocObject.EffectiveMin = -32768 Case com.sun.star.sdbc.DataType.TINYINT oLocObject.EffectiveMax = 127 oLocObject.EffectiveMin = -128 Case com.sun.star.sdbc.DataType.FLOAT, com.sun.star.sdbc.DataType.REAL, com.sun.star.sdbc.DataType.DOUBLE, com.sun.star.sdbc.DataType.DECIMAL, com.sun.star.sdbc.DataType.NUMERIC 'Todo: oLocObject.DecimalAccuracy = ... oLocObject.EffectiveDefault = CurDefaultValue ' Todo: HelpText??? End Select If oLocObject.PropertySetinfo.HasPropertyByName("Width")Then ' Note: an Access AutoincrementField does not provide this property Width oLocObject.Width = CurFieldLength + CurScale + 1 End If If CurIsCurrency Then 'Todo: How do you set currencies? End If ElseIf CurControlType = cTextBox Then 'com.sun.star.sdbc.DataType.CHAR, com.sun.star.sdbc.DataType.VARCHAR, com.sun.star.sdbc.DataType.LONGVARCHAR If CurFieldLength = 0 Then 'Or oLocObject.MaxTextLen > SBMAXTEXTSIZE oLocObject.MaxTextLen = SBMAXTEXTSIZE CurFieldLength = SBMAXTEXTSIZE Else oLocObject.MaxTextLen = CurFieldLength End If oLocObject.DefaultText = CurDefaultValue ElseIf CurControlType = cDateBox Then ' Todo Why does this not work?: oLocObject.DefaultDate = CurDefaultValue ElseIf CurControlType = cTimeBox Then ' com.sun.star.sdbc.DataType.DATE, com.sun.star.sdbc.DataType.TIME oLocObject.DefaultTime = CurDefaultValue ' Todo: Property TimeFormat? from where? ElseIf CurControlType = cCheckBox Then ' Todo Why does this not work?: oLocObject.DefaultState = CurDefaultValue End If If oLocObject.PropertySetInfo.HasPropertybyName("FormatKey") Then On Local Error Resume Next oLocObject.FormatKey = CurFormatKey End If End Function ' Destroy all Shapes in Nirwana Sub RemoveShapes() Dim n as Integer Dim oControl as Object Dim oShape as Object For n = oDrawPage.Count-1 To 0 Step -1 oShape = oDrawPage(n) If oShape.Position.Y > -2000 Then oDrawPage.Remove(oShape) End If Next n End Sub ' Destroy all Shapes in Nirwana Sub RemoveNirwanaShapes() Dim n as Integer Dim oControl as Object Dim oShape as Object For n = oDrawPage.Count-1 To 0 Step -1 oShape = oDrawPage(n) If oShape.Position.Y < -2000 Then oDrawPage.Remove(oShape) End If Next n End Sub ' Note: as Shapes cannot be removed from the DrawPage without destroying ' the object we have to park them somewhere beyond the visible area of the page Sub ShapesToNirwana() Dim n as Integer Dim oControl as Object For n = 0 To oDrawPage.Count-1 oDrawPage(n).Position = GetPoint(-20, -10000) Next n End Sub Function CalcUniqueContentName(BYVAL oContainer as Object, sBaseName as String) as String Dim nPostfix as Integer Dim sReturn as String nPostfix = 2 sReturn = sBaseName while (oContainer.hasByName(sReturn)) sReturn = sBaseName & nPostfix nPostfix = nPostfix + 1 Wend CalcUniqueContentName = sReturn End Function Function CountItemsInArray(BigArray(), SearchItem) Dim i as Integer Dim MaxIndex as Integer Dim ResCount as Integer ResCount = 0 MaxIndex = Ubound(BigArray()) For i = 0 To MaxIndex If SearchItem = BigArray(i) Then ResCount = ResCount + 1 End If Next i CountItemsInArray() = ResCount End Function Function GetDBHeight(oDBModel as Object) If CurControlType = cImageControl Then nDBHeight = 2000 Else If CurFieldType = com.sun.star.sdbc.DataType.LONGVARCHAR Then oDBModel.MultiLine = True nDBHeight = nDBRefHeight * 4 Else nDBHeight = nDBRefHeight End If End If GetDBHeight() = nDBHeight End Function Function GetFormWizardPaths() as Boolean FormPath = GetOfficeSubPath("Template","../wizard/bitmap") If FormPath <> "" Then WizardPath = GetOfficeSubPath("Template","wizard/") If Wizardpath <> "" Then TexturePath = GetOfficeSubPath("Gallery", "backgrounds/") If TexturePath <> "" Then WorkPath = GetPathSettings("Work") If WorkPath <> "" Then TempPath = GetPathSettings("Temp") If TempPath <> "" Then GetFormWizardPaths = True Exit Function End If End If End If End If End If DisposeDocument(oDocument) GetFormWizardPaths() = False End Function Function GetFilterName(sApplicationKey as String) as String Dim oArgs() Dim oFactory Dim i as Integer Dim Maxindex as Integer Dim UIName as String oFactory = createUnoService("com.sun.star.document.FilterFactory") oArgs() = oFactory.getByName(sApplicationKey) MaxIndex = Ubound(oArgs()) For i = 0 to MaxIndex If (oArgs(i).Name="UIName") Then UIName = oArgs(i).Value Exit For End If next i GetFilterName() = UIName End Function