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

Extensible Markup Language | 2001-12-18 | 9KB | 293 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 sDatabaseList()
Public iCommandTypes() as Integer
Public CurCommandType as Integer
Public oDataSource as Object
Public bEnableBinaryOptionGroup as Boolean


Sub GetDatabaseNames()
    If oDBContext.HasElements Then
        sDatabaseList() = oDBContext.ElementNames()
    End If
End Sub


Sub GetSelectedDBMetaData()
Dim OldsDBname as String
Dim DBIndex as Integer
    If Ubound(oDialogModel.lstDatabases.SelectedItems()) > -1 Then
        ToggleDatabasePage(False)
        DBIndex = oDialogModel.lstDatabases.SelectedItems(0)
        sDBName = sDatabaseList(DBIndex)
        If GetConnection(sDBName) Then
            If GetDBMetaData() Then
                With oDialogModel
                    .lstTables.Enabled = True
                    .lblTables.Enabled = True
                    .lstTables.StringItemList() = AddListToList(TableNames(), QueryNames())
                    iCommandTypes() = CreateCommandTypeList()
                    EmptyFieldsListboxes()
                End With
            End If
        End If
        bEnableBinaryOptionGroup = False
        ToggleDatabasePage(True)
    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 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)    ' '?' & ' Repeat and Cancel'
                bExitLoop = iMsg = SBCANCEL
                Resume CLERROR
                CLERROR:
            End If
        Loop Until bExitLoop
        On Local Error Goto 0
        If Not bGetConnection Then
            oDialogModel.lstDatabases.SelectedItems() = Nulllist()
            oDialogModel.lstTables.StringItemList() = NullList()
            oDialogModel.lstFields.StringItemList() = NullList()
            oDialogModel.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(oDialogModel.lstSelFields.StringItemList())
    Dim ColumnMap(MaxIndex)as Integer
    FieldNames() = oDialogModel.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
'        Msgbox IsEmpty(oField.HelpText)
'        Msgbox oField.HelpText
'        Msgbox oField.ControlDefault
'        Msgbox sFieldName & ":" & chr(13) & oField.dbg_Properties
        FieldMetaValues(n,0) = oField.Type
        FieldMetaValues(n,1) = oField.Precision
        FieldMetaValues(n,2) = GetValueoutofList(iType, WidthList(),1, WidthIndex)
        FieldMetaValues(n,3) = WidthList(WidthIndex,3)
        FieldMetaValues(n,4) = oField.FormatKey
' Todo: Check why the following lines do not work
'        Msgbox oField.ControlDefault
        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(oDialogModel.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
            Redim Preserve ResultFieldNames(m-1)
            Redim Preserve FieldNames(m-1)
            FieldNames() = ResultFieldNames()
            oDialogModel.lstFields.StringItemList = FieldNames()
            InitializeListboxProcedures(oDialogModel, oDialogModel.lstFields, oDialogModel.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 oDialogModel.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(oDialogModel.lstFields, ImgFieldNames())
        End If
    Else
        ReDim Preserve WidthList(15, 4)
        RemoveListItems(oDialogModel.lstFields(), oDialogModel.lstSelFields(), ImgFieldNames())
    End If
    oDialogModel.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
        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)
' Todo: Is this really the HelpText?
    CurHelpText = FieldMetaValues(Index,8)
    CurFieldName = FieldNames(Index)
End Sub</script:module>