home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Kompuutteri Kaikille K-CD 2002 #3
/
K-CD_2002-03.iso
/
OpenOffice
/
f_0018
/
develop.xba
< prev
next >
Wrap
Extensible Markup Language
|
2001-10-12
|
19KB
|
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>