1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
|
<?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()
Sub GetDatabaseNames()
If oDBContext.HasElements Then
sDatabaseList() = oDBContext.ElementNames()
End If
End Sub
Sub GetSelectedDBMetaData()
Dim NullList()
Dim OldsDBname as String
Dim bGetMetaData as Boolean
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
bGetMetaData = GetDBMetaData()
End If
If bGetMetaData Then
With oDialogModel
.lstTables.Enabled = True
.lblTables.Enabled = True
.lstTables.StringItemList() = AddListToList(TableNames(), QueryNames())
.lstFields.StringItemList() = NullList()
.lstSelFields.StringItemList() = NullList()
End With
End If
ToggleDatabasePage(True)
End If
End Sub
Function GetConnection(sDBName as String)
Dim oDatabase as Object
Dim oInteractionHandler as Object
Dim oDataSource as Object
Dim bExitLoop as Boolean
Dim bGetConnection as Boolean
Dim iMsg as Integer
oDatabase = oDBContext.GetByName(sDBName)
If Not oDatabase.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 Not bGetConnection Then
iMsg = Msgbox (sMsgNoConnection,32 + 2, sMsgWizardName) ' '?' & ' Repeat and Cancel'
bExitLoop = iMsg = SBCANCEL
End If
On Local Error Goto 0
Loop Until bExitLoop
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
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)
iType = oColumns.GetByName(sFieldName).Type
FieldMetaValues(n,0) = iType
' Todo: Geht das nicht etwas performanter?
FieldMetaValues(n,1) = GetValueoutofList(iType, WidthList(),1)
FieldMetaValues(n,2) = GetValueoutofList(iType, WidthList(),2)
FieldMetaValues(n,3) = GetValueoutofList(iType, WidthList(),4)
Next
ReDim oDBShapeList(MaxIndex) as Object
ReDim oTCShapeList(MaxIndex) as Object
End Sub
Sub GetSpecificFieldNames()
Dim n as Integer
Dim m 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)
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
Next n
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
If bIsQuery Then
oDBForm.CommandType = 1 ' Abfrage
else
oDBForm.CommandType = 0 ' Tabelle
End If
End Sub
Sub AddBinaryFieldsToWidthList()
Dim LocWidthList()
Dim MaxIndex as Integer
Dim OldMaxIndex as Integer
Dim s as Integer
Dim n as Integer
Dim m as Integer
' Todo: Die folgenden Zeilen könnten in einer allgemeinen Routine
' bearbeitet werden, z. B. durch Umschreiben von AddListToList, wobei
' beim Abfragen des Ubounds der zweiten Dimension eine Fehlerabfrage nötig wäre.
MaxIndex = Ubound(WidthList(),1) + Ubound(ImgWidthList(),1) + 1
OldMaxIndex = Ubound(WidthList(),1)
ReDim Preserve WidthList(MaxIndex,4)
s = 0
For n = OldMaxIndex + 1 To MaxIndex
For m = 0 To 4
WidthList(n,m) = ImgWidthList(s,m)
Next m
s = s + 1
Next n
FillUpFieldsListbox()
End Sub
Sub RemoveBinaryFieldsFromWidthList()
Dim MaxIndex as Integer
MaxIndex = Ubound(WidthList(),1) - Ubound(ImgWidthList(),1) - 1
ReDim Preserve WidthList(MaxIndex, 4)
FillUpFieldsListbox()
End Sub</script:module>
|
