Komputer for Alle 2002 #3/K-CD-3-2002.ISO/OpenOffice/f_0018/develop.xba

Extensible Markup Language | 2001-10-12 | 18.5 KB | 545 lines

<?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="develop" script:language="StarBasic">REM  *****  BASIC  *****
Option Explicit

Public oDBShapeList() as Object
Public oTCShapeList() as Object
Public oDBModelList() as Object
Public oGridShape as Object
Public a as Integer
Public StartA as Integer
Public bIsFirstRun as Boolean
Public bIsVeryFirstRun as Boolean

Public bIsVeryFirstValueField as Boolean
' This boolean variable refers to the following Controltypes: cTextBox, cCheckBox, cDateBox, cTimeBox, cNumericBox, cCurrencyBox

Public bControlsareCreated as Boolean
Public nDBRefHeight as Long
Public nXTCPos&, nYTCPos&, nXDBPos&, nYDBPos&, nTCHeight&, nTCWidth&, nDBHeight&, nDBWidth&
Public CurControlType as Integer
Public CurFieldlength as Double
Public CurFieldType as Integer
Public CurFieldName as String
Public CurControlName as String
Dim iReduceWidth as Integer

Function PositionControls(Maxindex as Integer)
Dim oTCModel as Object
Dim oDBModel as Object
Dim i as Integer
    InitializePosSizes()
    bIsFirstRun = True
    bIsVeryFirstRun = True
    bIsVeryFirstValueField = True
    a = 0
    StartA = 0
    nMaxRowY = 0
    nSecMaxRowY = 0
    If CurArrangement = cLeftJustified Or cTopJustified Then
        oDialogModel.optAlign0.State = 1
    End If
    For i = 0 To MaxIndex
        GetCurrentMetaValues(i)
        oTCModel = InsertTextControl(i)
        If CurFieldType = com.sun.star.sdbc.DataType.TIMESTAMP Then
            InsertTimeStampShape(i)
        Else
            InsertDBControl(i)
            bIsVeryFirstRun = False
'            oDBModel.LabelControl = oTCModel
        End If
        ResetPosSizes(i)
        oProgressbar.Value = i
    Next i
    ControlCaptionstoStandardLayout()
    bControlsareCreated = True
End Function


Sub ResetPosSizes(LastIndex as Integer)
    Select Case CurArrangement
        Case cColumnarLeft
            nYDBPos = nYDBPos  + nDBHeight + cVertDistance
            If (nYDBPos > cYOffset + nFormHeight) Or (LastIndex = MaxIndex) Then
                RepositionColumnarLeftControls(LastIndex)
                nXTCPos = nMaxColRightX + 2 * cHoriDistance
                nXDBPos = nXTCPos + cHoriDistance + nMaxTCWidth
                nYDBPos = cYOffset
                nYTCPos = cYOffset
                bIsFirstRun = True
                StartA = LastIndex + 1
                a = 0
            Else
                a = a + 1
            End If
            nYTCPos = nYDBPos
        Case cColumnarTop
            nYTCPos = nYDBPos + nDBHeight + cVertDistance
            If nYTCPos > cYOffset + nFormHeight Then
                nXDBPos = nMaxColRightX + cHoriDistance
                nXTCPos = nMaxColRightX + cHoriDistance
                nYDBPos = cYOffset + nTCHeight + cVertDistance
                nYTCPos = cYOffset
                bIsFirstRun = True
                StartA = LastIndex + 1
                a = 0
            Else
                a = a + 1
            End If
        Case cLeftJustified,cTopJustified
' Todo: Berücksichtigen, wenn das Label eines Controls länger als das DB-Control ist
            If nMaxColRightX > cXOffset + nFormWidth Then
                Dim nOldYTCPos as Long
                nOldYTCPos = nYTCPos
                CheckJustifiedPosition()
            Else
                nXTCPos = nMaxColRightX + CHoriDistance
            End If
            a = a + 1
    End Select
End Sub


Sub    RepositionColumnarLeftControls(LastIndex as Integer)
Dim aSize As New com.sun.star.awt.Size
Dim aPoint As New com.sun.star.awt.Point
Dim i as Integer
    aSize = GetSize(nMaxTCWidth, nTCHeight)
    bIsFirstRun = True
    For i = StartA To LastIndex
        oLocTextShape.Size = aSize
        If i = StartA Then
            nXTCPos = oTCShapeList(i).Position.X
            nXDBPos = nXTCPos + nMaxTCWidth  + cHoriDistance
        End If
'        If oLocDBShape.SupportsService("com.sun.star.drawing.Shapes") Then
'            ResetDBShape(oLocDBShape(0), nXDBPos)
'            ResetDBShape(oLocDBShape(1), nXDBPos + oLocDBShape(0).Size.Width)
'            printdbgInfo oLocDBShape
'        Else
            ResetDBShape(oDBShapeList(i), nXDBPos)
            CheckOuterPoints(nXDBPos, nDBWidth, nYDBPos, nDBHeight, True)
'        End If
'        GroupShapes(oDrawPage, oLocTextShape, oLocDBShape)
    Next i
End Sub


Sub ResetDBShape(oLocDBShape as Object, iXPos as Long)
Dim aSize As New com.sun.star.awt.Size
Dim aPoint As New com.sun.star.awt.Point
    nYDBPos = oLocDBShape.Position.Y
    nDBWidth = oLocDBShape.Size.Width
    nDBHeight = oLocDBShape.Size.Height
    aPoint = GetPoint(iXPos,nYDBPos)
    oLocDBShape.SetPosition(aPoint)
End Sub


Sub InitializePosSizes()
    nXTCPos = cXOffset
    nYTCPos = cYOffset
    nTCWidth = 2000
    nTCHeight = 560
    nDBWidth = 2000
    nDBHeight = 560
    iReduceWidth = 0
    Select Case CurArrangement
        Case cColumnarLeft, cLeftJustified
            nXDBPos = cXOffset + 3050
            nYDBPos = cYOffset
        Case cColumnarTop, cTopJustified
            nXDBPos = cXOffset
    End Select
End Sub


Function InsertTextControl(i as Integer) as Object
Dim oShape as Object
Dim oModel as Object
Dim aPoint as New com.sun.star.awt.Point
Dim aSize As New com.sun.star.awt.Size
    If bControlsareCreated Then
        Set oShape = oTCShapeList(i)
        Set oModel = oShape.GetControl
        If CurArrangement = cLeftJustified Then
            nTCWidth = GetPreferredWidth(oModel, True, CurFieldname)
        Else
            nTCWidth = oShape.Size.Width
        End If
        nTCHeight = oShape.Size.Height
        oShape.Position = GetPoint(nXTCPos, nYTCPos)
        If CurArrangement = cColumnarTop Then
            oModel.Align = com.sun.star.awt.TextAlign.LEFT
        End If
    Else
        oModel = CreateUnoService(oModelService(cLabel))
'        oModel.Label = CurFieldName ' + nFieldPostfixes(i) (Todo: Was ist ein fieldPostfix?)
' Todo: According to FS this handling should be verified. I should not rely on the shape to create a model on its
' own. therefor the model should be inserted before the shape
'        oDBForm.InsertByName(oModel.Name, oModel)
        aPoint = GetPoint(nXTCPos, nYTCPos)
        aSize = GetSize(nTCWidth,nTCHeight)
        Set oShape = InsertControl(oDrawPage, oModel, aPoint, aSize)
        Set oTCShapeList(i)= oShape
        If bIsVeryFirstRun Then
            nTCHeight = GetPreferredHeight(oModel, CurFieldname)
            If CurArrangement = cColumnarTop Then
                nYDBPos = nYTCPos + nTCHeight
            End If
        End If
        nTCWidth = GetPreferredWidth(oModel, True, CurFieldname)
    End If
    If CurArrangement = cColumnarLeft Then
        ' Note This If Sequence must be called before retrieving the outer Points
        If bIsFirstRun Then
            nMaxTCWidth = nTCWidth
            bIsFirstRun = False
        ElseIf nTCWidth > nMaxTCWidth Then
            nMaxTCWidth = nTCWidth
        End If
    End If
    CheckOuterPoints(oShape.Position.X, nTCWidth, nYTCPos, nTCHeight, False)
    Select Case CurArrangement
        Case cLeftJustified
            nXDBPos = nMaxColRightX
        Case cColumnarTop,cTopJustified
            oModel.Align = com.sun.star.awt.TextAlign.LEFT
            nXDBPos = nXTCPos
            nYDBPos = nYTCPos + nTCHeight
            If CurFieldLength = 20 And nDBWidth > 2 * nTCWidth Then
                iReduceWidth = iReduceWidth + 1
            End If
    End Select
    oShape.SetSize(GetSize(nTCWidth,nTCHeight))
    InsertTextControl = oModel
End Function


Sub InsertDBControl(i as Integer)
Dim aPoint as New com.sun.star.awt.Point
Dim aSize As New com.sun.star.awt.Size
Dim oControl as Object
Dim iColRightX as Long

    aPoint = GetPoint(nXDBPos, nYDBPos)
    If bControlsAreCreated Then
'        Set oDBModel = oDBModelList(i) 'oDBShapeList(i).GetControl
        oDBShapeList(i).Position = aPoint
    Else
        oDBModelList(i) = CreateUnoService(oModelService(CurControlType))
        oDBShapeList(i) = InsertControl(oDrawPage, oDBModelList(i), aPoint, aSize)
        SetNumerics(oDBModelList(i), CurFieldType)
        ' Todo: According to FS this handling should be verified. I should not rely on the shape to create a model on its
        ' own. therefor the model should be inserted before the shape
        ' oDBForm.InsertByName(oDBModel.Name, oDBModel)
        If CurControlType = cCheckBox Then
            oDBModelList(i).Label = ""
        End If
    End If
    nDBHeight = GetDBHeight(oDBModelList(i))
    nDBWidth = GetPreferredWidth(oDBModelList(i),True)
    aSize = GetSize(nDBWidth,nDBHeight)
    oDBShapeList(i).SetSize(aSize)
    CheckOuterPoints(nXDBPos, nDBWidth, nYDBPos, nDBHeight, True)
    oDBModelList(i).DataField = CurFieldName
End Sub


Function InsertTimeStampShape(i as Integer) as Object
Dim oDateModel as Object
Dim oTimeModel as Object
Dim oDateShape as Object
Dim oTimeShape as Object
Dim oDateTimeShape as Object
Dim aPoint as New com.sun.star.awt.Point
Dim aSize as New com.sun.star.awt.Size
Dim nDateWidth as Long
Dim nTimeWidth as Long
Dim oGroupShape as Object

'    aPoint = GetPoint(nXDBPos, nYDBPos)
    oGroupShape = oDocument.CreateInstance("com.sun.star.drawing.GroupShape")
'    aSize = GetSize(2000, 600)
'    oGroupShape.Size = aSize
'    oGroupShape.Position = (aPoint) 'oFirstShape.Position
'    oGroupShape.AnchorType = com.sun.star.text.TextContentAnchorType.AT_PARAGRAPH
'    aSize = GetSize(1000, 600)
'    aPoint = GetPoint(0,0)

    CurFieldType = com.sun.star.sdbc.DataType.DATE
    oDateModel = CreateUnoService("com.sun.star.form.component.DateField")
    oDateModel.DataField = CurFieldName
    oDateShape = InsertControl(oDrawPage, oDateModel, aPoint, aSize)
    SetNumerics(oDateModel, CurFieldType)
    nDBHeight = GetDBHeight(oDateModel)
    nDateWidth = GetPreferredWidth(oDateModel,True)
    aSize = GetSize(nDateWidth,nDBHeight)
    oDateShape.SetSize(aSize)
    aPoint = GetPoint(nXDBPos+nDateWidth, nYDBPos)

    CurFieldType = com.sun.star.sdbc.DataType.TIME
    oTimeModel = CreateUnoService("com.sun.star.form.component.TimeField")
    oTimeModel.DataField = CurFieldName
    oTimeShape = InsertControl(oGroupShape, oTimeModel, aPoint, aSize)
    nTimeWidth = GetPreferredWidth(oTimeModel)
    aSize = GetSize(nTimeWidth,nDBHeight)
    oTimeShape.SetSize(aSize)
    Set oDBShapeList(i)= oDateTimeShape
    oGroupShape.Add(oTimeShape)
    nDBWidth = nDateWidth + nTimeWidth
    CheckOuterPoints(nXDBPos, nDBWidth, nYDBPos, nDBHeight, True)
    InsertTimeStampShape() = oGroupShape
End Function


Sub CheckJustifiedPosition()
Dim nLeftDist as Long
Dim nRightDist as Long
Dim oLocDBShape as Object
Dim oLocTextShape as Object
Dim nBaseWidth as Long
    nBaseWidth = nFormWidth + cXOffset
    nLeftDist = nMaxColRightX - nBaseWidth
    nRightDist = nBaseWidth - nXTCPos + cHoriDistance
    If nLeftDist < 0.5 * nRightDist and iReduceWidth > 2 Then
        ' Fieldwidths in the line can be made smaller
        AdjustLineWidth(StartA, a, nLeftDist, - 1)
        If CurArrangement = cLeftjustified Then
            nYDBPos = nMaxRowY + cVertDistance
            nYTCPos = nYDBPos + 5
            nXTCPos = cXOffset
        Else
            nYTCPos = nMaxRowY + cVertDistance
            nYDBPos = nYTCPos + nTCHeight
            nXTCPos = cXOffset
            nXDBPos = cXOffset
        End If
        bIsFirstRun = True
        StartA = a + 1
    Else
        Set oLocDBShape = oDBShapeList(a)
        Set oLocTextShape = oTCShapeList(a)
        If CurArrangement = cLeftJustified Then
            If nYDBPos + nDBHeight = nMaxRowY Then
                ' The last Control was the highes in the row
                nYTCPos = nSecMaxRowY + cVertDistance
            Else
                nYTCPos = nMaxRowY + cVertDistance
            End If
            nYDBPos = nYTCPos
            nXDBPos = cXOffset + nTCWidth
            oLocTextShape.Position = GetPoint(cXOffset, nYTCPos)
            oLocDBShape.Position = GetPoint(nXDBPos, nYDBPos)
            ' PosSizes for the next two Controls
            nXTCPos = oLocDBShape.Position.X + oLocDBShape.Size.Width + cHoriDistance
            bIsFirstRun = True
            CheckOuterPoints(nXDBPos, nDBWidth, nYDBPos, nDBHeight, True)
            nXDBPos = nMaxColRightX + cHoriDistance
        Else        ' cTopJustified
            If nYDBPos + nDBHeight = nMaxRowY Then
                ' The last Control was the highest in the row
                nYTCPos = nSecMaxRowY + cVertDistance
            Else
                nYTCPos = nMaxRowY + cVertDistance
            End If
            nYDBPos = nYTCPOS + nTCHeight
            nXDBPos = cXOffset
            nXTCPos = cXOffset
            oLocTextShape.Position = GetPoint(cXOffset, nYTCPos)
            oLocDBShape.Position = GetPoint(cXOffset, nYDBPos)
            bIsFirstRun = True
            If nDBWidth > nTCWidth Then
                CheckOuterPoints(nXDBPos, nDBWidth, nYDBPos, nDBHeight, True)
            Else
                CheckOuterPoints(nXDBPos, nTCWidth, nYDBPos, nDBHeight, True)
            End If
            nXTCPos = nMaxColRightX + cHoriDistance
            nXDBPos = nXTCPos
        End If
        AdjustLineWidth(StartA, a-1, nRightDist, 1)
        StartA = a
     End If
     iReduceWidth = 0
End Sub


Sub AdjustLineWidth(StartIndex as Integer, EndIndex as Integer, nDist as Long, Widthfactor as Integer)
Dim i as Integer
Dim oLocDBShape as Object
Dim oLocTCShape as Object
Dim CorrWidth as Integer
Dim bAdjustPos as Boolean
Dim iLocTCPosX as Long
Dim iLocDBPosX as Long
Dim ShapeCount as Integer
' Todo: Hier muss ber├╝cksichtigt werden, dass gewisse Widths z.B f├╝r numerische Controls nicht pl├╢tzlich zu klein werden
' Am besten werden nur TextControls gestaucht, so dass vorher geschaut werden muss, ob ├╝berhaupt TextControls vorhanden
' sind
    If WidthFactor > 0 Then
        ShapeCount = EndIndex-StartIndex + 1
    Else
        ShapeCount = iReduceWidth
    End If
    CorrWidth = (nDist)/ShapeCount
    bAdjustPos = False
    iLocTCPosX = cXOffset
    For i = StartIndex To EndIndex
        Set oLocDBShape = oDBShapeList(i)
        Set oLocTCShape = oTCShapeList(i)
        If bAdjustPos Then
            oLocTCShape.Position = GetPoint(iLocTCPosX, oLocTCShape.Position.Y)
            If CurArrangement = cLeftJustified Then
                iLocDBPosX = oLocTCShape.Position.X + oLocTCShape.Size.Width
                oLocDBShape.Position = GetPoint(iLocDBPosX, oLocDBShape.Position.Y)
            Else
                oLocDBShape.Position = GetPoint(iLocTCPosX, oLocTCShape.Position.Y + nTCHeight)
            End If
        Else
            bAdjustPos = True
        End If
        If CDbl(FieldMetaValues(i,1)) > 20 or WidthFactor > 0 Then
            oLocDBShape.Size = GetSize(oLocDBShape.Size.Width + WidthFactor * CorrWidth, oLocDBShape.Size.Height)
        End If
        iLocTCPosX = oLocDBShape.Position.X + oLocDBShape.Size.Width + cHoriDistance
        If CurArrangement = cTopJustified Then
            If oLocTCShape.Size.Width > oLocDBShape.Size.Width Then
                iLocTCPosX = oLocDBShape.Position.X + oLocTCShape.Size.Width + cHoriDistance
            End If
        End If
    Next i
End Sub


Sub CheckOuterPoints(nXPos, nWidth, nYPos, nHeight, bIsDBField as Boolean)
Dim nColRightX as Long
Dim nRowY as Long
Dim nOldMaxRowY as Long

    If CurArrangement = cLeftJustified Or CurArrangement = cTopJustified Then
        If bIsDBField Then
            ' Only at DBControls you can measure the Value of nMaxRowY
            If bIsFirstRun Then
                nMaxRowY = nYPos + nHeight
                nSecMaxRowY = nMaxRowY
            Else
                nRowY = nYPos + nHeight
                If nRowY >= nMaxRowY Then
                    nOldMaxRowY = nMaxRowY
                    nSecMaxRowY = nOldMaxRowY
                    nMaxRowY = nRowY
                End If
            End If
        End If
    End If
    ' Find the outer right point
    If bIsFirstRun Then
        nMaxColRightX = nXPos + nWidth
        bIsFirstRun = False
    Else
        nColRightX = nXPos + nWidth
        If nColRightX > nMaxColRightX Then
            nMaxColRightX = nColRightX
        End If
    End If
End Sub


Function PositionGridControl(MaxIndex as Integer)
Dim oControl as Object
Dim n as Integer
Dim oColumn as Object
Dim aPoint as New com.sun.star.awt.Point
Dim aSize as New com.sun.star.awt.Size
    If bControlsareCreated Then
        oDocument.LockControllers()
        ShapesToNirwana()
        oDocument.UnlockControllers()
    End If
    oGridModel = CreateUnoService(oModelService(cGridControl))
    oGridModel.Name = "Grid1"
    For n = 0 to MaxIndex
        GetCurrentMetaValues(n)
        If CurFieldType = com.sun.star.sdbc.DataType.TIMESTAMP Then
            oColumn = SetupGridColumn(oGridModel,"DateField", False, com.sun.star.sdbc.DataType.DATE, CurFieldName & " " & sDateAppendix)
            oColumn = SetupGridColumn(oGridModel,"TimeField", False, com.sun.star.sdbc.DataType.TIME, CurFieldName & " " & sTimeAppendix)
        Else
            If CurControlType = cImageControl Then
                oColumn = SetupGridColumn(oGridModel,"TextField", True, CurFieldType, CurFieldName)
            Else
                oColumn = SetupGridColumn(oGridModel, CurControlName, False, CurFieldType, CurFieldName)
            End If
        End If
        oProgressbar.Value = n
    next n
    aPoint = GetPoint(cXOffset, cYOffset)
    ' Todo: Man müsste die Größe und die Position der Controls von der Anzahl der
    ' Datenbankfelder abhängig machen
    aSize = GetSize(nFormWidth, nFormHeight)
    oDBForm.InsertByName (oGridModel.Name, oGridModel)
    oGridShape = InsertControl(oDrawPage, oGridModel, aPoint, aSize)
End Function



Function SetupGridColumn(oGridModel as Object, ControlName as String, bHidden as Boolean, iLocFieldType as Integer, ColName as String) as Object
Dim oColumn as Object
'Todo: Hier muss in der Hilfe vermittelt werden, dass Image Controls nicht dargestellt werden k├╢nnen
    CurControlName = ControlName
    oColumn = oGridModel.CreateColumn(CurControlName)
    oColumn.Name = CalcUniqueContentName(oGridModel, CurControlName)
    oColumn.Hidden = bHidden
    SetNumerics(oColumn, iLocFieldType)
    oColumn.DataField = CurFieldName
    oColumn.Label = ColName  '+ nFieldPostfixes(n); Todo: Was hat das nFieldPostfix hier zu suchen?
    oColumn.Width = 0     'Spaltenbreite richtet sich nach dem Feldnamen
    oGridModel.insertByName(oColumn.Name, oColumn)
End Function


Sub ControlCaptionstoStandardLayout()
Dim i as Integer
Dim iBorderType as Integer
Dim oCurModel as Object
Dim oStyle as Object
Dim iStandardColor as Long
    If CurArrangement <> cTabled Then
        oStyle = oDocument.StyleFamilies.GetByName("ParagraphStyles").GetByName("Standard")
        iStandardColor = oStyle.CharColor
        For i = 0 To MaxIndex
            oCurModel = oTCShapeList(i).GetControl
            If i = 0 Then
                If oCurModel.TextColor = iStandardColor Then
                    Exit Sub
                End If
            End If
            oCurModel.TextColor = iStandardColor
        Next i
    End If
End Sub


'Function CreateDateTimeShapeCollection(oDrawPage as Object, oFirstShape as Object, oSecShape as Object) as Object
'Dim oGroupShape as Object
'Dim aSize As New com.sun.star.awt.Size
'    oGroupShape = oDocument.CreateInstance("com.sun.star.drawing.GroupShape")
'    aSize = GetSize(oFirstShape.Size.Width + oSecShape.Size.Width, oFirstShape.Size.Height)
'    oGroupShape.Size = aSize
'    oGroupShape.Position = oFirstShape.Position
'    oGroupShape.AnchorType = com.sun.star.text.TextContentAnchorType.AT_PARAGRAPH
'    oDrawPage.Add(oGroupShape)
'    oGroupShape.Add(oFirstShape)
'    oGroupShape.Add(oSecShape)
'    CreateDateTimeShapeCollection() = oGroupShape
'End Function


'Sub GroupShapes(oDrawPage as Object, oLocTextShape as Object, oLocDBShape as Object)
'Dim oShapes as Object
'    oShapes = createUnoService("com.sun.star.drawing.ShapeCollection")
'    oShapes.Add(oLocTextShape)
'    oShapes.Add(oLocDBShape)
'    oDrawPage.Group(oShapes)
'End Sub</script:module>