PC World 2004 January/PCWorld_2004-01_cd.bin/akce/openoffice/f_0173/DBMeta.xba

Extensible Markup Language | 2003-06-06 | 10KB | 337 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="DBMeta" script:language="StarBasic">REM  *****  BASIC  *****
Option Explicit


Public iCommandTypes() as Integer
Public CurCommandType as Integer
Public oDataSource as Object
Public bEnableBinaryOptionGroup as Boolean
'Public bSelectContent as Boolean


Function GetDatabaseNames(baddFirstListItem as Boolean)
Dim sDatabaseList()
    If oDBContext.HasElements Then
        Dim LocDBList() as String
        Dim MaxIndex as Integer
        Dim i as Integer
        LocDBList = oDBContext.ElementNames()
        MaxIndex = Ubound(LocDBList())
        If baddfirstListItem Then
            ReDim Preserve sDatabaseList(MaxIndex + 1)
            sDatabaseList(0) = sSelectDatasource
            a = 1
        Else
            ReDim Preserve sDatabaseList(MaxIndex)
            a = 0
        End If
        For i = 0 To MaxIndex
            sDatabaseList(a) = oDBContext.ElementNames(i)
            a = a + 1
        Next i
    End If
    GetDatabaseNames() = sDatabaseList()
End Function


Sub GetSelectedDBMetaData()
Dim OldsDBname as String
Dim DBIndex as Integer
Dim LocList() as String
'    If bStartUp Then
'        bStartUp = false
'        Exit Sub
'    End Sub
    If Ubound(DialogModel.lstDatabases.SelectedItems()) > -1 Then
        DeleteFirstListBoxEntry("lstDatabases", sSelectDatasource)
        ToggleDatabasePage(False)
        DBIndex = DialogModel.lstDatabases.SelectedItems(0)
        With DialogModel
            If DBIndex > -1 Then
                sDBName = DlgFormDB.getControl("lstDatabases").getSelectedItem()
                If GetConnection(sDBName) Then
                    If GetDBMetaData() Then
                        LocList() = AddListToList(Array(sSelectDBTable), TableNames())
                        .lstTables.StringItemList() = AddListToList(LocList(), QueryNames())
'                        bSelectContent = True
                        .lstTables.SelectedItems() = Array(0)
                        iCommandTypes() = CreateCommandTypeList()
                        EmptyFieldsListboxes()
                    End If
                End If
                bEnableBinaryOptionGroup = False
                .lstTables.Enabled = True
                .lblTables.Enabled = True
            Else
                DialogModel.lstTables.StringItemList = Array(sSelectDBTable)
                EmptyFieldsListboxes()
            End If
            ToggleDatabasePage(True)
        End With
    End If
End Sub


Function GetConnection(sDBName as String)
Dim oInteractionHandler as Object
Dim bExitLoop as Boolean
Dim bGetConnection as Boolean
Dim iMsg as Integer
Dim Nulllist()
    If Not IsNull(oDBConnection) Then
        oDBConnection.Dispose()
    End If
    oDataSource = oDBContext.GetByName(sDBName)
    If Not oDBContext.hasbyName(sDBName) Then
        GetConnection() = False
        Exit Function
    End If
    If Not oDataSource.IsPasswordRequired Then
        oDBConnection = oDBContext.GetByName(sDBName).GetConnection("","")
        GetConnection() = True
    Else
        oInteractionHandler = createUnoService("com.sun.star.sdb.InteractionHandler")
        oDataSource = oDBContext.GetByName(sDBName)
        On Local Error Goto NOCONNECTION
        Do
            bExitLoop = True
            oDBConnection = oDataSource.ConnectWithCompletion(oInteractionHandler)
            NOCONNECTION:
            bGetConnection = Err = 0
            If bGetConnection Then
                bGetConnection = Not IsNull(oDBConnection)
                If Not bGetConnection Then
                    Exit Do
                End If
            End If
            If Not bGetConnection Then
                iMsg = Msgbox (sMsgNoConnection,32 + 2, sMsgWizardName)
                bExitLoop = iMsg = SBCANCEL
                Resume CLERROR
                CLERROR:
            End If
        Loop Until bExitLoop
        On Local Error Goto 0
        If Not bGetConnection Then
            DialogModel.lstDatabases.SelectedItems() = Array(sSelectDatasource)
            DialogModel.lstTables.StringItemList() = Array(sSelectDBTable)
            DialogModel.lstFields.StringItemList() = NullList()
            DialogModel.lstSelFields.StringItemList() = NullList()
        End If
        GetConnection() = bGetConnection
    End If
End Function


Function GetDBMetaData()
    If oDBContext.HasElements Then
        Tablenames() = oDBConnection.Tables.ElementNames()
        Querynames() = oDBConnection.Queries.ElementNames()
        GetDBMetaData = True
    Else
        MsgBox(sMsgErrNoDatabase, 64, sMsgWizardName)
        GetDBMetaData = False
    End If
End Function


Sub GetTableMetaData()
Dim iType as Long
Dim m as Integer
Dim Found as Boolean
Dim i as Integer
Dim sFieldName as String
Dim n as Integer
Dim WidthIndex as Integer
Dim oField as Object
    MaxIndex = Ubound(DialogModel.lstSelFields.StringItemList())
    Dim ColumnMap(MaxIndex)as Integer
    FieldNames() = DialogModel.lstSelFields.StringItemList()
    ' Build a structure which maps the position of a selected field (within the selection) to the the column position within
    ' the table. So we ensure that the controls are placed in the same order the according fields are selected.
    For i = 0 To Ubound(FieldNames())
        sFieldName = FieldNames(i)
        Found = False
        n = 0
        While (n< MaxIndex And (Not Found))
            If (FieldNames(n) = sFieldName) Then
                Found = True
                ColumnMap(n) = i
            End If
            n = n + 1
        Wend
    Next i
    For n = 0 to MaxIndex
        sFieldname = FieldNames(n)
        oField = oColumns.GetByName(sFieldName)
        iType = oField.Type
        FieldMetaValues(n,0) = oField.Type
        FieldMetaValues(n,1) = AssignFieldLength(oField.Precision)
        FieldMetaValues(n,2) = GetValueoutofList(iType, WidthList(),1, WidthIndex)
        FieldMetaValues(n,3) = WidthList(WidthIndex,3)
        FieldMetaValues(n,4) = oField.FormatKey
        FieldMetaValues(n,5) = oField.DefaultValue
        FieldMetaValues(n,6) = oField.IsCurrency
        FieldMetaValues(n,7) = oField.Scale
'        If oField.Description <> "" Then
'' Todo: What's wrong with this line?
'            Msgbox oField.Helptext
'        End If
        FieldMetaValues(n,8) = oField.Description
    Next
    ReDim oDBShapeList(MaxIndex) as Object
    ReDim oTCShapeList(MaxIndex) as Object
    ReDim oDBModelList(MaxIndex) as Object
    ReDim oGroupShapeList(MaxIndex) as Object
End Sub


Function GetSpecificFieldNames() as Integer
Dim n as Integer
Dim m as Integer
Dim s as Integer
Dim iType as Integer
Dim oField as Object
Dim MaxIndex as Integer
Dim EmptyList()
    If Ubound(DialogModel.lstTables.StringItemList()) > -1 Then
        FieldNames() = oColumns.GetElementNames()
        MaxIndex = Ubound(FieldNames())
        If MaxIndex <> -1 Then
            Dim ResultFieldNames(MaxIndex)
            ReDim ImgFieldNames(MaxIndex)
            m = 0
            For n = 0 To MaxIndex
                oField = oColumns.GetByName(FieldNames(n))
                iType = oField.Type
                If GetIndexInMultiArray(WidthList(), iType, 0) <> -1 Then
                    ResultFieldNames(m) = FieldNames(n)
                    m = m + 1
                End If
                If GetIndexInMultiArray(ImgWidthList(), iType, 0) <> -1 Then
                    ImgFieldNames(s) = FieldNames(n)
                    s = s + 1
                End If
            Next n
            If s <> 0 Then
                Redim Preserve ImgFieldNames(s-1)
                bEnableBinaryOptionGroup = True
            Else
                bEnableBinaryOptionGroup = False
            End If
            If (DialogModel.optBinariesasGraphics.State = 1)  And (s <> 0) Then
                ResultFieldNames() = AddListToList(ResultFieldNames(), ImgFieldNames())
            Else
                Redim Preserve ResultFieldNames(m-1)
            End If
            FieldNames() = ResultFieldNames()
            DialogModel.lstFields.StringItemList = FieldNames()
            InitializeListboxProcedures(DialogModel, DialogModel.lstFields, DialogModel.lstSelFields)
        End If
        GetSpecificFieldNames = MaxIndex
    Else
        GetSpecificFieldNames = -1
    End If
End Function


Sub CreateDBForm()
    If oDrawPage.Forms.Count = 0 Then
          oDBForm = oDocument.CreateInstance("com.sun.star.form.component.Form")
        oDrawpage.Forms.InsertByIndex (0, oDBForm)
    Else
        oDBForm = oDrawPage.Forms.GetByIndex(0)
    End If
    oDBForm.Name = "Standard"
    oDBForm.DataSourceName = sDBName
    oDBForm.Command = TableName
    oDBForm.CommandType = CurCommandType
End Sub


Sub AddOrRemoveBinaryFieldsToWidthList()
Dim LocWidthList()
Dim MaxIndex as Integer
Dim OldMaxIndex as Integer
Dim s as Integer
Dim n as Integer
Dim m as Integer
    If Not bDebug Then
        On Local Error GoTo WIZARDERROR
    End If
    If DialogModel.optBinariesasGraphics.State = 1 Then
        OldMaxIndex = Ubound(WidthList(),1)
        If OldMaxIndex = 15 Then
            MaxIndex = Ubound(WidthList(),1) + Ubound(ImgWidthList(),1) + 1
            ReDim Preserve WidthList(MaxIndex,4)
            s = 0
            For n = OldMaxIndex + 1 To MaxIndex
                For m = 0 To 3
                    WidthList(n,m) = ImgWidthList(s,m)
                Next m
                s = s + 1
            Next n
            MergeList(DialogModel.lstFields, ImgFieldNames())
        End If
    Else
        ReDim Preserve WidthList(15, 4)
        RemoveListItems(DialogModel.lstFields(), DialogModel.lstSelFields(), ImgFieldNames())
    End If
    DialogModel.lstSelFields.Tag = True
WIZARDERROR:
    If Err <> 0 Then
        Msgbox(sMsgErrMsg, 16, GetProductName())
        Resume LOCERROR
        LOCERROR:
    End If
End Sub


Function CreateCommandTypeList()
Dim MaxTableIndex as Integer
Dim MaxQueryIndex as Integer
Dim MaxIndex as Integer
Dim i as Integer
Dim a as Integer
    MaxTableIndex = Ubound(TableNames()
    MaxQueryIndex = Ubound(QueryNames()
    MaxIndex = MaxTableIndex + MaxQueryIndex + 1
    If MaxIndex > -1 Then
        Dim LocCommandTypes(MaxIndex) as Integer
        For i = 0 To MaxTableIndex
            LocCommandTypes(i) = com.sun.star.sdb.CommandType.TABLE
        Next i
        a = i
        For i = 0 To MaxQueryIndex
            LocCommandTypes(a) = com.sun.star.sdb.CommandType.QUERY
            a = a + 1
        Next i
    End If
    CreateCommandTypeList() = LocCommandTypes()
End Function


Sub GetCurrentMetaValues(Index as Integer)
    CurFieldType = FieldMetaValues(Index,0)
    CurFieldLength = FieldMetaValues(Index,1)
    CurControlType = FieldMetaValues(Index,2)
    CurControlName = FieldMetaValues(Index,3)
    CurFormatKey = FieldMetaValues(Index,4)
    CurDefaultValue = FieldMetaValues(Index,5)
    CurIsCurrency = FieldMetaValues(Index,6)
    CurScale = FieldMetaValues(Index,7)
    CurHelpText = FieldMetaValues(Index,8)
    CurFieldName = FieldNames(Index)
End Sub


Function AssignFieldLength(FieldLength as Long) as Integer
    If FieldLength >= 65535 Then
        AssignFieldLength() = -1
    Else
        AssignFieldLength() = FieldLength
    End If
End Function
</script:module>