com!online 2001 December/COMCD1201.iso/openoffice/f_0020/develop.xba

Extensible Markup Language | 2001-08-24 | 15.8 KB | 494 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 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 nDBRefWidth as Long
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
    For i = 0 To MaxIndex
        CurFieldType = FieldMetaValues(i,0)
        CurFieldLength = CDbl(FieldMetaValues(i,1))
        CurControlType = FieldMetaValues(i,2)
        CurControlName = FieldMetaValues(i,3)
        CurFieldName = FieldNames(i)
        oTCModel = InsertTextControl(i)
        InsertDBControl(oDBModel, i)
        bIsVeryFirstRun = False
        oDBModel.LabelControl = oTCModel
        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
Dim oLocTextShape as Object
Dim oLocDBShape as Object
    aSize = GetSize(nMaxTCWidth, nTCHeight)
    bIsFirstRun = True
    For i = StartA To LastIndex
        Set oLocTextShape = oTCShapeList(i)
        Set oLocDBShape = oDBShapeList(i)
        oLocTextShape.Size = aSize
        If i = StartA Then
            nXTCPos = oLocTextShape.Position.X
            nXDBPos = nXTCPos + nMaxTCWidth  + cHoriDistance
        End If
        nYDBPos = oLocDBShape.Position.Y
        nDBWidth = oLocDBShape.Size.Width
        nDBHeight = oLocDBShape.Size.Height
        aPoint = GetPoint(nXDBPos,nYDBPos)
        oLocDBShape.SetPosition(aPoint)
        CheckOuterPoints(nXDBPos, nDBWidth, nYDBPos, nDBHeight, True)
'        GroupShapes(oDrawPage, oLocTextShape, oLocDBShape)
    Next i
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
        nTCWidth = oShape.Size.Width
        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(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
            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(oDBModel as Object, i as Integer)
Dim aPoint as New com.sun.star.awt.Point
Dim aSize As New com.sun.star.awt.Size
Dim oShape as Object
Dim oControl as Object
Dim iColRightX as Long

    If Not bIsVeryFirstValueField Then
        nDBWidth = Clng(CurFieldLength/2 * nDBRefWidth)
    Else
        nDBWidth = 1
    End If
    aPoint = GetPoint(nXDBPos, nYDBPos)
    If bControlsAreCreated Then
        Set oShape = oDBShapeList(i)
        Set oDBModel = oShape.GetControl
        oShape.Position = aPoint
    Else
        aSize = GetSize(nDBWidth,nDBHeight)
        oDBModel = CreateUnoService(oModelService(CurControlType))
'        oDBModel.Name = CurControlName
        SetNumerics(oDBModel)
        oShape = InsertControl(oDBModel, aPoint, aSize)
        Set oDBShapeList(i)= oShape
' 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
            oDBModel.Label = ""
        End If

    End If
    If CurControlType = cImageControl Then
        ' Todo: Dies ist nur eine vorsichtige Schätzung
        nDBWidth = 2000
        nDBHeight = 2000
    Else
        If bIsVeryFirstValueField Then
            nDBRefWidth = GetPreferredWidth(oDBModel,True)
            ' Todo: Hier wird vereinfachend davon ausgegangen, dass es sich bei DB-Feldern immer um Textfelder handelt!
            nDBRefHeight = GetPreferredHeight(oDBModel)
            bIsVeryFirstValueField = False
        End If
        'Todo: Vielleicht k├╢nnte man dieses Feld auch noch tiefer machen
        If CurFieldType = com.sun.star.sdbc.DataType.LONGVARCHAR Then
            oDBModel.MultiLine = True
            nDBHeight = nDBRefHeight * 2
        Else
            nDBHeight = nDBRefHeight
        End If
        nDBWidth = CInt(CurFieldLength/10 * nDBRefWidth)
    End If
    aSize = GetSize(nDBWidth,nDBHeight)
    oShape.SetSize(aSize)
    CheckOuterPoints(nXDBPos, nDBWidth, nYDBPos, nDBHeight, True)
    oDBModel.DataField = CurFieldName
End Sub


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
Dim nWidth as Long
    If bControlsareCreated Then
        oDocument.LockControllers()
        ShapesToNirwana()
        oDocument.UnlockControllers()
    End If
    oGridModel = CreateUnoService(oModelService(cGridControl))
    oGridModel.Name = "Grid1"
    nWidth = 0
    For n = 0 to MaxIndex
        CurFieldType = FieldMetaValues(n,0)
        CurControlType = FieldMetaValues(n,2)
        CurFieldName = FieldNames(n)
        If CurControlType = cImageControl Then
'Todo: Hier muss in der Hilfe vermittelt werden, dass Image Controls nicht dargestellt werden k├╢nnen
            CurControlName = "TextField"
            oColumn = oGridModel.CreateColumn(CurControlName)
            oColumn.Name = CalcUniqueContentName(oGridModel, CurControlName)
            oColumn.Hidden = True
        Else
            CurControlName = FieldMetaValues(n,3)
        oColumn = oGridModel.CreateColumn(CurControlName)
        oColumn.Name = CalcUniqueContentName(oGridModel, CurControlName)
        End If
        SetNumerics(oColumn)
        oColumn.DataField = CurFieldName
        oColumn.Label = CurFieldName  '+ nFieldPostfixes(n); Todo: Was hat das nFieldPostfix hier zu suchen?
        oColumn.Width = 0     'Spaltenbreite richtet sich nach dem Feldnamen
        oGridModel.insertByName(oColumn.Name, oColumn)
        oProgressbar.Value = n
        nWidth = nWidth + oColumn.Width
    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 (oGridModel, aPoint, aSize)
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


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>