Quelle  tools.xba   Sprache: unbekannt

<?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="tools" script:language="StarBasic">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
</script:module>