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 DialogModel.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 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)) 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 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, 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 Function GetCorrWidth(StartIndex as Integer, EndIndex as Integer, nDist as Long, Widthfactor as Integer) as Integer Dim ShapeCount as Integer If WidthFactor > 0 Then ShapeCount = EndIndex-StartIndex + 1 Else ShapeCount = iReduceWidth End If GetCorrWidth() = (nDist)/ShapeCount End Function 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 CorrWidth = GetCorrWidth(StartIndex, EndIndex, nDist, Widthfactor) 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 If (CurArrangement = cTopJustified) And (oLocTCShape.Size.Width > oLocDBShape.Size.Width) Then oLocDBShape.Size = GetSize(oLocTCShape.Size.Width + WidthFactor * CorrWidth, oLocDBShape.Size.Height) Else oLocDBShape.Size = GetSize(oLocDBShape.Size.Width + WidthFactor * CorrWidth, oLocDBShape.Size.Height) End If 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