DOS/V Power Report 2002 November/VPR0211A.ISO/OPENOFFICE/f_0138/develop.xba

Extensible Markup Language | 2001-12-18 | 17KB | 530 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 oGroupShapeList() as Object

Public oGridShape as Object
Public a as Integer
Public StartA as Integer
Public bIsFirstRun as Boolean
Public bIsVeryFirstRun as Boolean
Public bControlsareCreated as Boolean
Public nDBRefHeight as Long
Public nXTCPos&, nYTCPos&, nXDBPos&, nYDBPos&, nTCHeight&, nTCWidth&, nDBHeight&, nDBWidth&

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
    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
            oDBModelList(i).LabelControl = oTCModel
        End If
        GetLabelDiffHeight(i+1)
        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
                bIsFirstRun = True
                StartA = LastIndex + 1
                a = 0
            Else
                a = a + 1
            End If
            nYTCPos = nYDBPos + LABELDIFFHEIGHT
        Case cColumnarTop
            nYTCPos = nYDBPos + nDBHeight + cVertDistance
            If nYTCPos > cYOffset + nFormHeight Then
                nXDBPos = nMaxColRightX + cHoriDistance
                nXTCPos = nXDBPos
                nYDBPos = cYOffset + nTCHeight + cVertDistance
                nYTCPos = cYOffset
                bIsFirstRun = True
                StartA = LastIndex + 1
                a = 0
            Else
                a = a + 1
            End If
        Case cLeftJustified,cTopJustified
            If nMaxColRightX > cXOffset + nFormWidth Then
                Dim nOldYTCPos as Long
                nOldYTCPos = nYTCPos
                CheckJustifiedPosition()
            Else
                nXTCPos = nMaxColRightX + CHoriDistance
                If CurArrangement = cLeftJustified Then
                    nYTCPos = nYDBPos + LabelDiffHeight
                End If
            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
        ResetDBShape(oDBShapeList(i), nXDBPos)
        CheckOuterPoints(nXDBPos, nDBWidth, nYDBPos, nDBHeight, True)
    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
    nTCWidth = 2000
    nDBWidth = 2000
    nDBHeight = nDBRefHeight
    iReduceWidth = 0
    Select Case CurArrangement
        Case cColumnarLeft, cLeftJustified
            GetLabelDiffHeight(0)
            nYTCPos = cYOffset + LABELDIFFHEIGHT
            nXDBPos = cXOffset + 3050
            nYDBPos = cYOffset
        Case cColumnarTop, cTopJustified
            nXDBPos = cXOffset
            nYTCPos = cYOffset
    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
        oShape.Position = GetPoint(nXTCPos, nYTCPos)
        If CurArrangement = cColumnarTop Then
            oModel.Align = com.sun.star.awt.TextAlign.LEFT
        End If
    Else
        oModel = CreateUnoService(oModelService(cLabel))
' 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
            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))
    If CurHelpText <> "" Then
        oModel.HelpText = CurHelptext
    End If
    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
        oDBShapeList(i).Position = aPoint
    Else
        oDBModelList(i) = CreateUnoService(oModelService(CurControlType))
        oDBShapeList(i) = InsertControl(oDrawPage, oDBModelList(i), aPoint, aSize)
        SetNumerics(oDBModelList(i), CurFieldType)
        If CurControlType = cCheckBox Then
            oDBModelList(i).Label = ""
        End If
        ' 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)
        oDBModelList(i).DataField = CurFieldName
    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)
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)
    If bControlsAreCreated Then
        oDBShapeList(i).Position = aPoint
        nDBWidth = oDBShapeList(i).Size.Width
        nDBHeight = oDBShapeList(i).Size.Height
    Else
        oGroupShape = oDocument.CreateInstance("com.sun.star.drawing.GroupShape")
        oGroupShape.AnchorType = com.sun.star.text.TextContentAnchorType.AT_PARAGRAPH
        oDrawPage.Add(oGroupShape)
        CurFieldType = com.sun.star.sdbc.DataType.DATE
        oDateModel = CreateUnoService("com.sun.star.form.component.DateField")
        oDateModel.DataField = CurFieldName
        oDateShape = InsertControl(oGroupShape, oDateModel, aPoint, aSize)
        SetNumerics(oDateModel, CurFieldType)
        nDBHeight = GetDBHeight(oDateModel)
        nDateWidth = GetPreferredWidth(oDateModel,True)
        aSize = GetSize(nDateWidth,nDBHeight)
        oDateShape.SetSize(aSize)

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


' Note on all Controls except for the checkbox the Label has to be set
' a bit under the DBControl because its Height is also smaller
Sub GetLabelDiffHeight(Index as Integer)
    If (CurArrangement = cLeftJustified) Or (CurArrangement = cColumnarLeft) Then
        If Index <= Ubound(FieldMetaValues()) Then
            If FieldMetaValues(Index,2) = cCheckBox Then
                LabelDiffHeight = 0
            Else
                LabelDiffHeight = BasicLabelDiffHeight
            End If
        End If
    End If
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 + LABELDIFFHEIGHT
            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
                nYDBPos = nSecMaxRowY + cVertDistance
            Else
                nYDBPos = nMaxRowY + cVertDistance
            End If
            nYTCPos = nYDBPos + LABELDIFFHEIGHT
            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
    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
        ShapesToNirwana()
    End If
    oGridModel = CreateUnoService(oModelService(cGridControl))
    oGridModel.Name = "Grid1"
    aPoint = GetPoint(cXOffset, cYOffset)
    aSize = GetSize(nFormWidth, nFormHeight)
    oDBForm.InsertByName (oGridModel.Name, oGridModel)
    oGridShape = InsertControl(oDrawPage, oGridModel, aPoint, aSize)
    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
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
    CurControlName = ControlName
    oColumn = oGridModel.CreateColumn(CurControlName)
    oColumn.Name = CalcUniqueContentName(oGridModel, CurControlName)
    oColumn.Hidden = bHidden
    SetNumerics(oColumn, iLocFieldType)
    oColumn.DataField = CurFieldName
    oColumn.Label = ColName
    oColumn.Width = 0     ' Width of column is adjusted to Columname
    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


Sub GroupShapesTogether()
Dim i as Integer
    If CurArrangement <> cTabled Then
        For i = 0 To MaxIndex
            oGroupShapeList(i) = CreateUnoService("com.sun.star.drawing.ShapeCollection")
            oGroupShapeList(i).Add(oTCShapeList(i))
            oGroupShapeList(i).Add(oDBShapeList(i))
            oDrawPage.Group(oGroupShapeList(i))
        Next i
    Else
        RemoveNirwanaShapes()
    End If
End Sub</script:module>