Enter 2004 January/enter-2004-01.iso/files/soto_en/f_0017/DBMeta.xba

Extensible Markup Language | 2002-01-18 | 7.6 KB | 268 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 NullList()
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()
                    .lstFields.StringItemList() = NullList()
                    .lstSelFields.StringItemList() = NullList()
                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
        FieldMetaValues(n,0) = iType
        FieldMetaValues(n,1) = oField.Precision
        FieldMetaValues(n,2) = GetValueoutofList(iType, WidthList(),1, WidthIndex)
        FieldMetaValues(n,3) = WidthList(WidthIndex,3)
    Next
    ReDim oDBShapeList(MaxIndex) as Object
    ReDim oTCShapeList(MaxIndex) as Object
    ReDim oDBModelList(MaxIndex) as Object
'    ReDim oGroupShapeList(MaxIndex) as Object
End Sub


Sub GetSpecificFieldNames()
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())
        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
End Sub


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
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)
    CurFieldName = FieldNames(Index)
End Sub</script:module>