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(DialogModel.lstDatabases.SelectedItems()) > -1 Then ToggleDatabasePage(False) DBIndex = DialogModel.lstDatabases.SelectedItems(0) sDBName = sDatabaseList(DBIndex) If GetConnection(sDBName) Then If GetDBMetaData() Then With DialogModel .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 DialogModel.lstDatabases.SelectedItems() = Nulllist() DialogModel.lstTables.StringItemList() = NullList() 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 ' 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(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 Redim Preserve ResultFieldNames(m-1) Redim Preserve FieldNames(m-1) 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 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