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 Integer Public nDBRefHeight as Integer 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 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) ' 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) 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) 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 = CInt(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) 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 ' Können die Felder in der Reihe gestaucht werden? 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) nYTCPos = nMaxRowY + cVertDistance If CurArrangement = cLeftJustified Then 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) nXDBPos = nMaxColRightX + cHoriDistance Else 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) Else CheckOuterPoints(nXDBPos, nTCWidth, nYDBPos, nDBHeight) 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) Dim nColRightX Dim nRowY If CurArrangement = cLeftJustified Or CurArrangement = cTopJustified Then If bIsFirstRun Then nMaxRowY = nYPos + nHeight Else nRowY = nYPos + nHeight If nRowY > nMaxRowY Then nMaxRowY = nRowY 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 ShapesToNirwana() 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 CurControlName = "TextField" oColumn.Hidden = True Else CurControlName = FieldMetaValues(n,3) oColumn = oGridModel.CreateColumn(CurControlName) End If oColumn.Name = CalcUniqueContentName(oGridModel, CurControlName) 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