Home of site
Macroの杜
(OpenOffice.org/LibreOffice Basic編)
Base No.1
Baseに付属してくるDatabaseには HSQLDB と Firebirdがあります。
**********************【 Index 】**********************
File
DataSource
Connect with DataSource
Table
[ ResultSet Service ]
[ RowSet Service ]
[ PreparedStatement Service ]
[ createDataDescriptor() ]
Form
[ Form Button ]
[ Create / Edit ]
**********************【 Macro Code 】**********************
File
BF-1)[Base]新規Base fileの開閉(保存確認無し)
Sub oBaseOpen_Dummy
Dim Dummy()
oDoc = StarDesktop.loadComponentFromURL("private:factory/sdatabase", "_blank", 0, Dummy())
oAns = Msgbox("Fileを閉じますか?",4, "File Close確認")
if oAns = 6 then
oDoc.close(True)
End if
End Sub
BF-)[Base]新規Base fileの作成/保存( HSQLBD )
Sub oBaseOpen_Save()
Dim Dummy()
oDoc = StarDesktop.loadComponentFromURL( "private:factory/sdatabase", "_blank", 0, Dummy())
oDataSource = oDoc.DataSource
' set to use hsqldb
oDataSource.URL = "sdbc:embedded:hsqldb"
oAns = Msgbox("fileを保存しますか?",4, "File Save確認")
if oAns = 6 then
oInp = InputBox("Full pathでFile nameを入力して下さい(例 ： C:\temp\btest.odb)","保存File nameの入力")
oBName = ConvertToUrl(oInp)
oDoc.storeAsURL(oBName, Dummy())
End If
oAnsC = MsgBox("Fileを閉じますか?",4,"File Close確認")
If oAnsC = 6 then
oDoc.close(True)
End If
End Sub
'
' [ Note ]
' 作成したFileはDatasoruceに登録されていないので、作成したFileを用いてMacroを実行しても上手くいかない時がある
BF-)[Base]新規Base fileの作成/保存( Firebird )
Sub oBaseOpen_Save()
Dim oDoc as Object, oDataSource as Object
Dim Dummy()
oDoc = StarDesktop.loadComponentFromURL( "private:factory/sdatabase", "_blank", 0, Dummy())
oDataSource = oDoc.DataSource
' set to use hsqldb
oDataSource.URL = "sdbc:embedded:firebird"
oFileName = "c:\temp\Lo5012Firebird.odb"
oBName = ConvertToUrl(oFileName)
oDoc.storeAsURL(oBName, Dummy())
msgbox "Success",0,"LO5.0.1.2"
End Sub
'
' [ Note ]
' 作成したFileはDatasoruceに登録されていないので、作成したFileを用いてMacroを実行しても上手くいかない時がある
BF-2)[Base(Calc)]TableﾃﾞｰﾀをCalc fileに出力。[HSQLDB、Firebird ]
現在のファイルのTable名 ADDRESSの内容をClacに出力する。ADDRESS(項目名: ID, NAME, VERSION )が作成されていれば、事前準備は不要。
但し、事前の中で設定して、その後に使用している変数(oCon, oTbName, oCol(2))は別途設定のこと。
事前準備で作成するTableは Firebird用(SQL文がFirebirdの為)。HSQLDBを使う時はHSQLDBのSQLに変更のこと。
Sub BaseFirbird()
'==========[ ここから【事前準備】Calcへ出力する為にTableの準備。] ==========
oDoc = ThisComponent
oTempName = oDoc.getURL
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource as Object
Dim oCon as Object
oDataSource = oBaseContext.getByName(oTempName)
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt as Object
Dim oSQL as String, oTbName as String
Dim oCol(2) as String
oTbName = "ADDRESS"
oCol(0) = "ID"
oCol(1) = "NAME"
oCol(2) = "VERSION"
oStmt= oCon.createStatement()
'
oSQL = "RECREATE TABLE " & oTbName & "(" & oCol(0) & " INT NOT NULL PRIMARY KEY, " & oCol(1) & " VARCHAR(20) NOT NULL UNIQUE, " & oCol(2) & " VARCHAR(20)); "
oStmt.execute(oSQL)
'
' Insert Into Clause
Dim oSQL2 as String
Dim oValue as String
Dim i as Integer
oStmt = oCon.createStatement() ' Firebird ではTable作成後、再度、oStmｔの作成が必要
for i = 1 to 10
oValue = "VALUES (" & i & " , 'Firebird_" & i & "', 'LO6.2.4.2');"
oSQL2 = "INSERT INTO " & oTbName & " " & oValue
oStmt.executeUpdate(oSQL2)
Next i
' ********** [ 表示 → Tableの更新 ] **********
Dim dispatcher as Object
Dim oFrame as Object
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
oFrame = oDoc.getCurrentController().getFrame()
dispatcher.executeDispatch(oFrame,".uno:DBRefreshTables", "", 0, Array())
' ****************************************
'
'==========[ ここまで【事前準備】Calcへ出力する為にTableの準備。] ==========
'
oLoad_Calc(oCon, oTbName, oCol(2))
'
' Unconnect with the Datasource
oCon.close()
oCon.dispose
msgbox "Success",0,"LO 6.2.4.2 (x64)"
End Sub
'
Sub oLoad_Calc(db as Object, oTbName as String)
Dim Dummy()
Dim oCol(2) as String
Dim oDoc As Object
Dim oURL As String
Dim oSheet As Object
Dim oCell_0 As Object
Dim oCell_1 As Object
Dim oCell_2 As Object
Dim oCell_3 As Object
Dim oCell_4 As Object
Dim oRowSet As Object
Dim i As Integer
oURL ="private:factory/scalc"
oDoc = StarDeskTop.LoadComponentFromURL(oURL, "_blank", 0, Dummy())
oSheet = oDoc.Sheets(0)
oSheet.Name = "Import_fromBase"
oCol(0) = "ID"
oCol(1) = "NAME"
oCol(2) = "VERSION"
oBase_Item = join(oCol,",")
oRowSet =get_rowset(db, sql_select(oTbName, oBase_Item))
While oRowSet.Next
i=i+1
oCell_0= oSheet.getCellByPosition(0,i)
oCell_1= oSheet.getCellByPosition(1,i)
oCell_2= oSheet.getCellByPosition(2,i)
oCell_0.String = oRowSet.getString(1)
oCell_1.String = oRowSet.getString(2)
oCell_2.String = oRowSet.getString(3)
wend
End Sub
'
Function sql_select(iTable as String, iFields)
REM sql_select = "SELECT" & " " & iFields & " " & "FROM" & " " & iTable ' HSQLDB
sql_select = "SELECT" & " " & iFields & " " & "FROM" & " " & iTable & ";" ' Firebird
End Function
'
Function get_rowset(db as Object, iSql as String) as Object
Dim oRowSet as Object
oRowSet = createUnoService("com.sun.star.sdb.RowSet")
With oRowSet
.activeConnection = db
.Command = iSql
.execute
End With
get_rowset = oRowSet
End Function
BF-3)[Base(Calc)]Databaseのデータを新規Calc fileに入力する。(Baseのtableから1つずつCalcのセルに入力)
Sub oBase_Calc2
Dim db As Object
Dim oBase as String
Dim oDoc As Object
Dim oURL As String
Dim Dummy()
oBase ="oBase_test"
db = connect_to_database(oBase)
oURL ="private:factory/scalc"
oDoc = StarDeskTop.LoadComponentFromURL(oURL, "_blank", 0, Dummy())
oBase_Query(db,oDoc)
disconnect_from_database(db)
End Sub
Sub disconnect_from_database ( db as Object)
db.close
db.dispose()
End Sub
Sub oBase_Query(db as Object, iDoc as Object)
Dim oArray(4) As String
Dim oRowSet As Object
oArray(0) = "ISBN"
oArray(1) = "title"
oArray(2) = "author"
oArray(3) = "publish"
oArray(4) = "published"
oBase_Item = join(oArray,",")
oRowSet =get_rowset(db, sql_select("table1", oBase_Item))
oSheetName = "Import_Base"
load_sheet(iDoc, oSheetName, oRowSet)
End Sub
Sub load_sheet(iDoc as Object, iName as String, iRowSet as Object)
Dim oSheet as Object
Dim oCell as Object
Dim r as Integer
Dim endMarker as String
oSheet = iDoc.createInstance("com.sun.star.sheet.Spreadsheet")
iDoc.Sheets.insertByName(iName, oSheet)
If Not isNull (iRowSet) then
While iRowSet.Next
r = r+1
c = 0
endMarker = "Getting_Data"
While endMarker <> ""
oCell = oSheet.getCellByPosition(c, r)
If isNumeric(iRowSet.getString(c)) then
oCell.Value = iRowSet.getString(c)
else
oCell.String = iRowSet.getString(c)
End if
c =c + 1
endMarker = iRowSet.getString(c)
Wend
Wend
End if
End Sub
'
Function connect_to_database(dbName as String) as Object
Dim dbContext As Object
Dim oDataSource As Object
dbContext =createUnoService("com.sun.star.sdb.DatabaseContext")
oDataSource= dbContext.getByName(dbName)
connect_to_database=oDataSource.GetConnection("","")
End Function
'
Function sql_select(iTable as String, iFields)
sql_select = "SELECT" & " " & iFields & " " & "FROM" & " " & iTable
End Function
Function get_rowset(db as Object, iSql as String) as Object
Dim oRowSet as Object
oRowSet = createUnoService("com.sun.star.sdb.RowSet")
With oRowSet
.activeConnection = db
.Command = iSql
.execute
End With
get_rowset = oRowSet
End Function
BF-)[Base]指定file名でBase fileを作成(Base起動無し)
Const sDBBaseName$ = "c:\temp\oBase3.odb"
Sub CallCreateBinaryDB()
LoadDBLibs()
oName = ConvertToUrl(sDBBaseName)
CreateBinaryDB(oName, True)
End Sub
Sub LoadDBLibs()
If NOT BasicLibraries.isLibraryLoaded("Standard") Then
BasicLibraries.LoadLibrary("Standard")
End If
End sub
REM Use "Option Compatible", or you can not use a default argument.
Sub CreateBinaryDB(Optional dbURL$ , Optional bVerbose)
Dim oDBContext 'DatabaseContext service.
Dim oDB 'Database data source
REM No URL Specified, get one.
If dbURL = "" Then dbURL = ChooseAFile(OOoBaseFilters(), False)
REM Still No URL Specified, exit.
If dbURL = "" Then Exit Sub
If FileExists(dbURL) Then
If bVerbose Then Print "The file already exists."
Else
If bVerbose Then Print "Creating " & dbURL
oDBContext = createUnoService( "com.sun.star.sdb.DatabaseContext" )
oDB = oDBContext.createInstance()
oDB.URL = "sdbc:embedded:hsqldb"
oAns = msgbox("保存しますか？",4,"Confirm to save")
if oAns = 6 then
oDB.DatabaseDocument.storeAsURL(dbURL, Array())
End If
End if
End Sub
DataSource
BD-)[Base]( Don't work )登録されているDataSource名の取得(その1)
Sub oResisterSource
Dim oBaseContext 'Global database context.
Dim oGetSrcDir as String
Dim oDoc 'The document on which to work.
Dim oTempDir$ 'Temporary string variable.
'Global Library "Tools" Load
GlobalScope.BasicLibraries.LoadLibrary("Tools")
oDoc = ThisComponent
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
'Get DataSource
oFileURL = oDoc.getURL()
oDataSource = oBaseContext.getByName(oFileURL)
'Define DataSource Name( File Name )
oFName = FileNameOutOfPath(oFileURL, "/") : 'print oFName
oPos = InStr(oFName, ".")
oDBName = Left(oFName, oPos-1) : 'print oDBName
'Register the object if you want, but this is not required for use.
oBaseContext.registerObject(oDBName, oDataSource)
'Confirm
Dim oDSources
Dim oFlag
oDSources = oBaseContext.getElementNames()
oFlag = 0
for i = 0 to UBound(oDSources)
If oDBName = oDSources(i) then
oFlag = 1
End if
next i
If oFlag <> 1 Then
MsgBox( oDBName & "は登録されていません。", 0, "DataSourceの登録確認")
Exit Sub
else
MsgBox("Success", 0, "DataSourceの登録確認")
End If
End Sub
BD-)[Base]登録されているDataSource名の取得(その2)[HSQLDB、Firebird ]
Sub oRegisteredDataSource
Dim oBaseContext 'Global database context.
Dim oEnum 'Enumeration of registered data sources.
Dim oDataSource 'Database source
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
If NOT oBaseContext.hasElements() Then
Print "There are no registered data sources."
Exit Sub
End If
'Enumerate the currently registered data sources.
oEnum = oBaseContext.createEnumeration()
oDisp = "[Datasource Name]"
Do While oEnum.hasMoreElements()
oDataSource = oEnum.nextElement()
oDisp = oDisp & Chr$(13) & oDataSource.Name
Loop
MsgBox(oDisp,0,"Firebird/LO6.2.4.2")
End Sub
BD-)[Base]登録されているDataSource名の取得(その3)[HSQLDB、Firebird ]
Sub oResisteredDataSource2
Dim oBaseContext 'Global database context.
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
If NOT oBaseContext.hasElements() Then
MsgBox( "登録されているDataSourceはありません")
Exit Sub
End If
MsgBox(Join(oBaseContext.getElementNames(), CHR$(10)),0, "Registered Sources/LO6.4.2.4")
End Sub
BD-)[Base]登録されているDataSource名の取得(その4)[HSQLDB、Firebird ]
Sub DatabaseList()
Dim dbContext As Object
Dim dbNames
Dim d As Integer
Dim dbText As String
dbContext =createUnoService("com.sun.star.sdb.DatabaseContext")
dbNames = dbContext.getElementNames()
for d=0 to UBound(dbNames())
dbText = dbtext + dbNames(d) + chr(10)
next d
msgbox dbText
End Sub
BD-)[Base]登録されているDataSource名の取得(Full Path File)[HSQLDB、Firebird ]
Sub oDatabase_List
Dim dbContext As Object
Dim dbNames as Object
Dim d As Integer
Dim dbURL As String
Dim oTemp as String
dbContext =createUnoService("com.sun.star.sdb.DatabaseContext")
dbNames = dbContext.getElementNames()
dbURL = ""
for d=0 to UBound(dbNames())
oTemp = ""
oTemp = dbContext.getDatabaseLocation(dbNames(d))
if d <> 3 and d <> 9 then
dbURL = dbURL + oTemp + chr$(10)
end if
next d
msgbox dbURL,0, "登録されているDataSource"
End Sub
BD-)[Base]登録されているDataSource数の取得[HSQLDB、Firebird ]
Sub oResisteredDataSource1
Dim oBaseContext 'Global database context.
Dim oRstDataSources
Dim oCount
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
If NOT oBaseContext.hasElements() Then
MsgBox( "登録されているDataSourceはありません")
Exit Sub
End If
oRstDataSources = oBaseContext.getElementNames()
oCount = UBound(oRstDataSources)+1
MsgBox("本パソコンに登録されているDataSourceは" & oCount & " つです")
End Sub
BD-)[Base]DataSourceの登録[HSQLDB、Firebird ]
Sub RegisterDB_Source()
Dim oDBContext As Object
Dim oDBNames() as String
Dim i As Integer
Dim oRgstrDB As String
Dim oFlag as Integer
Dim oDisp as String
oDBContext =createUnoService("com.sun.star.sdb.DatabaseContext")
oDBNames = oDBContext.getElementNames()
'
oFlag = 0
oRgstrDB = "oBaseMacroTest"
oDisp="[Before ResisterDB]" & Chr$(10) & Join(oDBContext.getElementNames(), Chr$(10))
for i =0 to UBound(oDBNames)
if oDBNames(i) = oRgstrDB then
oFlag = 999
Exit for
end if
next i
'
if oFlag = 999 then
oDisp = "DataSource名 : " & oRgstrDB & " は既に登録されています。"
msgbox(oDisp,0,"既に登録済みです。")
Exit Sub
end if
'
' Resister
Dim oFileDb as String
Dim oUrlDb as String
Dim oDummy()
oFileDb = "c:\temp\" & oRgstrDB & ".odb"
oUrlDb = ConvertToUrl(oFileDb)
' FIle Exixt Check
If FileExists(oUrlDb) = False then
MsgBox( oFileDb & " は存在しません", 0, "Caution !!")
Exit Sub
End If
oDB = StarDesktop.loadComponentFromURL( oUrlDb, "_blank",0,oDummy())
oDBContext.registerObject(oRgstrDB,oDB.DataSource)
'
'Doculment Close
If HasUnoInterfaces(oDB,"com.sun.star.util.XCloseable") then
oDB.close(true)
End If
'
oDisp=oDisp & Chr$(10) & Chr$(10) & "[After ResisterDB]" & Chr$(10) & Join(oDBContext.getElementNames(), Chr$(10))
' Display
msgbox "登録完了" & Chr$(10) & oDisp
End Sub
BD-)[Base]登録削除[HSQLDB、Firebird ]
Sub oRevokeDataSource
Dim oBaseContext as Object 'Global database context.
Dim oDBName as String
Dim oDSources as Object
Dim oFlag as Integer
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDBName = "oBaseMacroTest"
oDSources = oBaseContext.getElementNames()
oFlag = 0
for i = 0 to UBound(oDSources)
If oDBName = oDSources(i) then
oFlag = 1
End if
next i
if oFlag = 0 then
oDisp = oDBName & Chr$(10) & " は登録されていません。"
msgbox oDisp
Exit Sub
end if
'
oDisp = oDBName & "のDataSourceから削除処置の結果" & Chr$(10) & Chr$(10) & _
"[ Before Revoke DataSource]"& Chr$(10) & Join(oBaseContext.getElementNames(), Chr$(10))
'
'Revoke DataSorce Resistered DataSource at List
oBaseContext.revokeObject(oDBName)
'
'Confirm
oDisp=oDisp & Chr$(10) & Chr$(10) & "[After Revoke DataSource]" & Chr$(10) & Join(oBaseContext.getElementNames(), Chr$(10))
Msgbox oDisp
End Sub
BD-)[Base]Password有無Check[HSQLDB、Firebird ]
Sub PasswordSource()
Dim oBaseContext as Object
Dim oFileURL as String
Dim oDoc as Object
Dim oDataSource as Object
Dim oRequiredPass as Boolean
Dim oDisp as String
oDoc = ThisComponent
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
'Get DataSource
oFileURL = oDoc.getURL()
oDataSource = oBaseContext.getByName(oFileURL)
oRequiredPass = oDataSource.IsPasswordRequired
'
oDisp = "[ DataSourceにPasswprdが必要か ]" & Chr$(10) & ConvertFromUrl(oFileURL) & Chr$(10) &" → " & oRequiredPass
msgbox( oDisp, 0,"Password")
End Sub
BD-)[Base]ReadOnly確認[HSQLDB、Firebird ]
Sub ReadOnlySource()
Dim oBaseContext as Object
Dim oFileURL as String
Dim oDoc as Object
Dim oDataSource as Object
Dim oIsReadOnly as Boolean
Dim oDisp as String
oDoc = ThisComponent
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
'Get DataSource
oFileURL = oDoc.getURL()
oDataSource = oBaseContext.getByName(oFileURL)
oIsReadOnly = oDataSource.IsReadOnly
'
oDisp = "[ DataSourceのReadonly確認 ]" & Chr$(10) & ConvertFromUrl(oFileURL) & Chr$(10) &" → " & oIsReadOnly
msgbox( oDisp, 0,"ReadOnly")
End Sub
BD-)[Base]
･Connect with DataSource[Base]
BC-)[Base]DataSourceにConnect(その1)[HSQLDB、Firebird ]
Sub oConnectDataSource
Dim oBaseContext 'Global database context.
Dim oUser$ 'User name while connecting.
Dim oPass$ 'Password while connections.
'Set the user name and password for connection.
'Default is no user or password required to Connect DataSouce of Hsqldb.
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
'Select DataSource Name
If NOT oBaseContext.hasElements() Then
MsgBox( "登録されているDataSourceはありません")
Exit Sub
End If
oDSources = oBaseContext.getElementNames()
for i = 0 to UBound(oDSources)
oAns=MsgBox("接続するDataSOurce名は " & Chr$(10) & "「 " & oDSources(i) & " 」" & Chr$(10) & "ですか?", 4, "DataSourceの選択")
If oAns = 6 then
'Connect with the DataSource
Dim oDataSource 'Data sources for the specified database.
Dim oCon 'Connection to a database.
oDataSource = oBaseContext.getByName(oDSources(i))
oCon = oDataSource.getConnection(oUser, oPass)
MsgBox("Success")
oCon.close() 'Unconnect with the Datasource
Exit Sub 'Exit
End if
next i
MsgBox("DataSourceが登録されていません。")
End Sub
BC-)[Base]DataSourceにConnect(その2)[HSQLDB、Firebird ]
Sub oConnectByInteractionHandler
Dim oBaseContext 'Global database context.
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
'Select DataSource Name
If NOT oBaseContext.hasElements() Then
MsgBox( "登録されているDataSourceはありません")
Exit Sub
End If
oDSources = oBaseContext.getElementNames()
for i = 0 to UBound(oDSources)
oAns=MsgBox("接続するSource名は " & Chr$(10) & "「 " & oDSources(i) & " 」" & Chr$(10) & "ですか?", 4, "DataSourceの選択")
If oAns = 6 then
'Connect with the DataSource
Dim oDataSource 'Data sources for the specified database.
Dim oHandler 'Interaction handler in case a password is required.
Dim oCon 'Connection to a database.
oDataSource = oBaseContext.getByName(oDSources(i))
oHandler = createUnoService("com.sun.star.sdb.InteractionHandler")
oCon = oDataSource.ConnectWithCompletion(oHandler)
MsgBox("Success")
oCon.close() 'Unconnect with the Datasource
Exit Sub 'Exit
End if
next i
MsgBox("DataSourceが登録されていません。")
End Sub
BC-)[Base]Supported Driver一覧[HSQLDB、Firebird ]
Sub oSupportedDBDrivers
Dim oManager 'Connection driver manager.
Dim oEnum 'Enumeration of supported drivers.
Dim oDriver 'An indiviual driver.
Dim oDriverNames as String
oManager = CreateUnoService("com.sun.star.sdbc.DriverManager")
oEnum = oManager.createEnumeration()
i = 1
Do While (oEnum.hasMoreElements() and i <= 100) 'i <=100は無限Loop防止
oDriver = oEnum.nextElement()
oDriverNames = oDriverNames & i & ") " & _
oDriver.getImplementationName() & CHR$(10)
i =i +1
Loop
'
MsgBox(oDriverNames, 0, "Supported Database Drivers[ LO Ver : " & GetSolarVersion & " ]")
End Sub
BC-)[Base]CSV fileに必要なDriverを調べる[HSQLDB、Firebird]
Sub oFlatDriverArgs
Dim oFileName
Dim oFileURL
Dim oURL$
Dim oManager 'Connection driver manager.
Dim oDriver 'An indiviual driver.
Dim oPropInfo 'Supported properties.
Dim oProp 'A specific property.
Dim oArray()
Dim oProperties as String 'Utility string variable.
oFileName = "C:\temp\test.csv"
oFileURL = ConvertToUrl(oFileName)
oURL = "sdbc:flat:" & oFileURL
oManager = CreateUnoService("com.sun.star.sdbc.DriverManager")
'Obtain a driver that supports the specified URL
oDriver = oManager.getDriverByURL(oURL)
If IsNull(oDriver) Then
MsgBox("Sorry, no driver available for " & oURL)
Exit Sub
End If
oPropInfo = oDriver.getPropertyInfo(oURL, oArray())
oProperties = "[ " & oFileName & " ]" & Chr$(10)
For i = LBound(oPropInfo) To UBound(oPropInfo)
oProp = oPropInfo(i)
If NOT oProp.IsRequired Then
oProperties = oProperties &"「Not Reuire」 " & Chr$(10) & " Name : " & oProp.Name & Chr$(10) & _
" Value : " & oPropInfo(i).Value & Chr$(10) & " DesCription :" & oPropInfo(i).Description & CHR$(10)
Else
oProperties = oProperties &"「 Reuire 」 " & Chr$(10) & " Name : " & oProp.Name & Chr$(10) & _
" Value : " & oPropInfo(i).Value & Chr$(10) & " DesCription :" & oPropInfo(i).Description & CHR$(10)
End If
Next
MsgBox(oProperties, 0, "Properties for " & oDriver.getImplementationName())
End Sub
Table[Base]
BT-)[Base]新規Table( All Data Type )作成[ For HSQLDB ]
Sub BaseTableCreate()
On Error Goto oBad
'Create New Base Document
Dim oDoc as Object
Dim oTempName as String
Dim oFlag as Integer
oFlag = 0
oDoc = ThisComponent
oTempName = oDoc.getURL
'
' Connect DB
Dim oBaseContent as Object
Dim oDB as Object
Dim oCon as Object
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDB = oBaseContext.getByName(oTempName)
oCon = oDB.getConnection("", "")
oFlag = 777
'
' Create New Table
Dim oTables as Object
Dim oTableName as String
Dim oTableDescriptor as Object
Dim oCols as Object
Dim oCol as Object
'
oTableName = "CreateTb"
' Access Tables in Connecting DB
oTables = oCon.getTables()
'
' 同名Tableが存在するか?
Dim oTNames() as Object
oTNames = oTables.getElementNames()
for i = 0 to UBound(oTNames)
if oTableName = oTNames(i) then
oDisp = "既に [ " & oTableName & " ] と同じ名前のTableがありますので処理を終了します。"
msgbox oDisp,0,"同名Tableが存在します。"
oCon.close()
oCon.dispose
Exit Sub
end if
next i
'
' Define the Table Property
oTableDescriptor = oTables.createDataDescriptor()
oTableDescriptor.Name = oTableName
' Define the Datas to table Columns( 最低一項目は設定が必要 )
oCols = oTableDescriptor.getColumns()
oCol = oCols.createDataDescriptor()
' INTEGER : 整数
oCol.Name = "ID"
oCol.Type = com.sun.star.sdbc.DataType.INTEGER
' oCol.TypeName = "INTEGER" ' Type は TypeName でも設定可能
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
oCol.Precision = 10 ' max 10
oCol.IsAutoIncrement = True
'
oCol.Description = "Primary Key"
'
oCol.FormatKey = com.sun.star.sdbcx.KeyType.UNIQUE
oCols.appendByDescriptor(oCol)
'
' TINYINT : 最短整数
oCol.Name = "TinyInt"
oCol.Type = com.sun.star.sdbc.DataType.TINYINT
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
oCol.Precision = 3 ' max 3
oCol.IsAutoIncrement = false
oCols.appendByDescriptor(oCol)
'
' SMALLINT : 短整数
oCol.Name = "SmallInt"
oCol.Type = com.sun.star.sdbc.DataType.SMALLINT
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
oCol.Precision = 5 ' max 5
oCol.IsAutoIncrement = false
oCols.appendByDescriptor(oCol)
'
' BIGINT : 長整数
oCol.Name = "BigInt"
oCol.Type = com.sun.star.sdbc.DataType.BIGINT
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
oCol.Precision = 19 ' max 19
oCol.IsAutoIncrement = false
oCols.appendByDescriptor(oCol)
'
' FLOAT : 浮動小数点
oCol.Name = "Float"
oCol.Type = com.sun.star.sdbc.DataType.FLOAT
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
oCol.Precision = 50 ' max 50
oCol.IsAutoIncrement = false
oCols.appendByDescriptor(oCol)
'
' REAL : 実数
oCol.Name = "Real"
oCol.Type = com.sun.star.sdbc.DataType.REAL
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
Rem oCol.Precision = 50 ' 設定不要
oCol.IsAutoIncrement = false
oCols.appendByDescriptor(oCol)
'
' DOUBLE : 倍精度浮動小数点
oCol.Name = "Double"
oCol.Type = com.sun.star.sdbc.DataType.DOUBLE
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
REM oCol.Precision = 50 ' 設定不要
oCol.IsAutoIncrement = false
oCols.appendByDescriptor(oCol)
'
' NUMERIC : 数値
oCol.Name = "Numeric"
oCol.Type = com.sun.star.sdbc.DataType.NUMERIC
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
oCol.Precision = 50 ' max 646,456,993
oCol.IsAutoIncrement = false
oCols.appendByDescriptor(oCol)
'
' DECIMAL : 十進数
oCol.Name = "Decimal"
oCol.Type = com.sun.star.sdbc.DataType.DECIMAL
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
oCol.Precision = 50 ' max 646,456,993
oCol.IsAutoIncrement = false
oCol.Scale = 2 ' DECIAMLの時の小数点以下の桁数
oCols.appendByDescriptor(oCol)
'
' .Scale 設定したので後の設定で .Scale 設定があるとErrorになるので、oClo を再度設定
oCol = oCols.createDataDescriptor()
' CHAR : テキスト(固定)
oCol.Name = "Char"
oCol.Type = com.sun.star.sdbc.DataType.CHAR
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
oCol.Precision = 255 ' max 2,147,483,647
oCol.IsAutoIncrement = false
oCols.appendByDescriptor(oCol)
'
' VARCHAR : テキスト
oCol.Name = "Varchar"
oCol.Type = com.sun.star.sdbc.DataType.VARCHAR
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
oCol.Precision = 255 ' max
oCol.IsAutoIncrement = false
oCols.appendByDescriptor(oCol)
'
' LONGVARCHAR : メモ
oCol.Name = "LongVarchar"
oCol.Type = com.sun.star.sdbc.DataType.LONGVARCHAR
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
REM oCol.Precision = 255 ' 設定不要
oCol.IsAutoIncrement = false
oCols.appendByDescriptor(oCol)
'
' DATE : 日付
oCol.Name = "Date"
oCol.Type = com.sun.star.sdbc.DataType.DATE
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
oCol.IsAutoIncrement = false
oCols.appendByDescriptor(oCol)
'
' TIME : 時刻
oCol.Name = "Time"
oCol.Type = com.sun.star.sdbc.DataType.TIME
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
oCol.IsAutoIncrement = false
oCols.appendByDescriptor(oCol)
'
' TIMESTAMP : 日付/時刻
oCol.Name = "TimeStamp"
oCol.Type = com.sun.star.sdbc.DataType.TIMESTAMP
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
oCol.IsAutoIncrement = false
oCols.appendByDescriptor(oCol)
'
' BINARY : 二進数(固定)
oCol.Name = "Binary"
oCol.Type = com.sun.star.sdbc.DataType.BINARY
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
oCol.Precision = 2147483647 ' 2,147483647 固定
oCol.IsAutoIncrement = false
oCols.appendByDescriptor(oCol)
'
' VARBINARY : 二進数
oCol.Name = "VarBinary"
oCol.Type = com.sun.star.sdbc.DataType.VARBINARY
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
oCol.Precision = 2147483647 ' 2,147483647 固定
oCol.IsAutoIncrement = false
oCols.appendByDescriptor(oCol)
'
' LONGVARBINARY : イメージ
oCol.Name = "LongvarBinary"
oCol.Type = com.sun.star.sdbc.DataType.LONGVARBINARY
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
REM oCol.Precision = 50 ' 設定不要
oCol.IsAutoIncrement = false
oCols.appendByDescriptor(oCol)
'
' BOOLEAN : はい/いいえ
oCol.Name = "Boolean"
oCol.Type = com.sun.star.sdbc.DataType.BOOLEAN
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
oCol.IsAutoIncrement = false
oCols.appendByDescriptor(oCol)
'
' OTHER : その他
oCol.Name = "Other"
oCol.Type = com.sun.star.sdbc.DataType.OTHER
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
REM oCol.Precision = 50 ' 設定不要
oCol.IsAutoIncrement = false
oCols.appendByDescriptor(oCol)
'
' Create Table but not to be able to look the table, because it needs to store Base Document.
oTables.appendByDescriptor(oTableDescriptor)
'
'Base Document Save
oDB.DatabaseDocument.store()
'
oCon.Close()
oCon.dispose
'
' Display
msgbox "Success"
Exit Sub
oBad:
if oFlag = 777 then
oCon.Close()
oCon.dispose
end if
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
BT-)[Base]新規Tableの追加(その1)[ For HSQLDB ]《File指定はDialog使用》[Table名：BINDATA(大文字必須)]
Sub oBaseCreateBinaryTable
REM Create the database specified by dbURL. If it
REM does not exist, then it is created.
REM If bForceNew is True, then an existing table is deleted first.
REM If bVerbose is True, progress messages are printed.
Dim oFName As String
Dim dbURL As String
Dim sTableName$ 'The name of the table to creat.
Dim oTable 'A table in the database.
Dim oTables 'Tables in the document
Dim oTableDescriptor 'Defines a table and how it looks.
Dim oCols 'The columns for a table.
Dim oCol 'A single column descriptor.
Dim oCon 'Database connection.
Dim oBaseContext 'Database context service.
Dim oDB 'Database data source.
Dim bForceNew
Dim bVerbose
bForceNew = false
bVerbose = false
'If the database does not exist, then create it.
If NOT FileExists(dbURL) Then
oTCBinaryDB(dbURL, bVerbose)
End If
'Use the DatabaseContext to get a reference to the database.
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDB = oBaseContext.getByName(dbURL)
oCon = oDB.getConnection("", "")
oTables = oCon.getTables()
sTableName$ = "BINDATA"
If oTables.hasByName(sTableName$) Then
bVerbose = true
If bForceNew Then
If bVerbose Then Print "Deleting table " & sTableName
oTables.dropByName(sTableName)
oDB.DatabaseDocument.store()
Else
If bVerbose Then Print "Table " & sTableName & " already exists!"
oCon.close(true)
Exit Sub
End If
End If
'For now, this should always be True
If NOT oTables.hasByName(sTableName$) Then
oTableDescriptor = oTables.createDataDescriptor()
oTableDescriptor.Name = sTableName$
oCols = oTableDescriptor.getColumns()
oCol = oCols.createDataDescriptor()
oCol.Name = "ID"
oCol.Type = com.sun.star.sdbc.DataType.INTEGER
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
oCol.IsAutoIncrement = True
oCol.Precision = 10
oCol.Description = "Primary Key"
oCols.appendByDescriptor(oCol)
oCol.Name = "NAME"
oCol.Type = com.sun.star.sdbc.DataType.VARCHAR
oCol.Description = "Filename"
oCol.Precision = 255
oCol.IsAutoIncrement = False
oCols.appendByDescriptor(oCol)
oCol.Name = "DATA"
oCol.Type = com.sun.star.sdbc.DataType.LONGVARBINARY
oCol.Precision = 2147483647
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
oCol.Description = "Binary Data"
oCols.appendByDescriptor(oCol)
oTables.appendByDescriptor(oTableDescriptor)
End If
'Do not dispose the database context or you will NOT be able to get it back without restarting OpenOffice.org.
'Store the associated document to persist the changes to disk.
oDB.DatabaseDocument.store()
oCon.close()
If bVerbose Then Print "Table " & sTableName & " created!"
End Sub
Sub oTCBinaryDB(Optional dbURL$ , Optional bVerbose)
Dim oDBContext 'DatabaseContext service.
Dim oDB 'Database data source
'No URL Specified, get one.
If dbURL = "" Then dbURL = oNameByDialog(oDisplayFilters())
'Still No URL Specified, exit.
If dbURL = "" Then End
If FileExists(dbURL) Then
If bVerbose Then Print "The file already exists."
Else
If bVerbose Then Print "Creating " & dbURL
oDBContext = createUnoService( "com.sun.star.sdb.DatabaseContext" )
oDB = oDBContext.createInstance()
oDB.URL = "sdbc:embedded:hsqldb"
oDB.DatabaseDocument.storeAsURL(dbURL, Array())
End If
End Sub
'[ Function 1 ]
Function oNameByDialog$(sFilters())
Dim oDialog As Object
Dim i As Integer
oDialog = CreateUnoService("com.sun.star.ui.dialogs.FilePicker")
i = com.sun.star.ui.dialogs.TemplateDescription.FILESAVE_SIMPLE
oDialog.initialize(Array(i))
For i = LBound(sFilters()) To UBound(sFilters())
Dim sFilterName$
Dim sFilterValue$
sFilterName = sFilters(i).Name
sFilterValue = sFilters(i).Value
oDialog.appendFilter(sFilterName, sFilterValue)
Next i
If oDialog.Execute() = 1 Then
sPath = oDialog.Files(0)
oNameByDialog() = sPath
End If
End Function
'[ Function 2 ]
Function oDisplayFilters()
Dim oArray(7) as new com.sun.star.beans.PropertyValue
oArray(0).Name = "All Files"
oArray(0).Value = "*.*"
oArray(1).Name = "Calc File(*.ods)"
oArray(1).Value = "*.ods"
oArray(2).Name = "Base File(*.odb)"
oArray(2).Value = "*.odb"
oArray(3).Name = "Writer File(*.odt)"
oArray(3).Value = "*.odt"
oArray(4).Name = "Draw File(*.odg)"
oArray(4).Value = "*.odg"
oArray(5).Name = "Impress File(*.odp)"
oArray(5).Value = "*.odp"
oArray(6).Name = "Math File(*.odf)"
oArray(6).Value = "*.odf"
oArray(7).Name = "Text File(*.txt)"
oArray(7).Value = "*.txt"
oDisplayFilters() = oArray()
End Function
BT-)[Base]新規Tableの追加(その2)[ For HSQLDB ]《File指定はMacro Code中》[Table編集画面にて終了]
Sub oBase_TableName
Dim db As Object
Dim oBase as String
Dim Dummy()
Dim oTable As Object
oBase ="oBase_test"
db = connect_to_database(oBase)
list_tables(db)
'新規Tableを編集
oTable = StarDesktop.loadComponentFromURL(".component:DB/TableDesign", "_blank", 0, Dummy())
a=oTable.getByName()
print a
'disconnect_from_database(db)
End Sub
'[ Sub Routine1 ]
Sub disconnect_from_database ( db as Object)
db.close
db.dispose()
End Sub
'[ Sub Routine2 ]
Sub list_tables(db as Object)
Dim dbTables As Object
Dim dbTableNames As Object
Dim opText As String
dbTables=db.getTables
dbTableNames=dbTables.getElementNames
opText=join(dbTableNames , chr(10))
msgbox opText
End sub
'[ Function1 ]
Function connect_to_database(dbName as String) as Object
Dim dbContext As Object
Dim oDataSource As Object
dbContext =createUnoService("com.sun.star.sdb.DatabaseContext")
oDataSource= dbContext.getByName(dbName)
connect_to_database=oDataSource.GetConnection("","")
End Function
BT-)[Base]新規Tableの追加(その3)[ For HSQLDB ]《File指定はMacro Code中》[Table名：BINDATA]≪Queryを用いてTable追加≫{Tableを追加するFileは起動せず}
Sub oBaseCreateBinaryTablesUseSQL
Dim dbURL As String
Dim bForceNew
Dim bVerbose
Dim sTableName$ 'The name of the table to creat.
Dim oTable 'A table in the database.
Dim oTables 'Tables in the document
Dim oTableDescriptor 'Defines a table and how it looks.
Dim oCols 'The columns for a table.
Dim oCol 'A single column descriptor.
Dim oCon 'Database connection.
Dim oBaseContext 'Database context service.
Dim oDB 'Database data source.
Dim oResult 'Restul of executing an SQL statement.
Dim nCount As Long 'Counting variable.
Dim oStmt
Dim sSql$
oBaseFName = "C:\temp\oBase_Table.odb"
dbURL = ConvertToUrl(oBaseFName)
bForceNew = true ' 強制的にTableの新規作成を行うかどうか
bVerbose = false ' Flag for OverWriting of Table. true: OverWrite is OK false : OverWrite is NG
'If the database does not exist, then create it.
If NOT FileExists(dbURL) Then
oCaution = ConvertFromUrl(dbURL)
Msgbox(oCaution & "が存在しません。空fileでも良いので作成してから再度実行して下さい。")
Exit Sub
End If
'Use the DatabaseContext to get a reference to the database.
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDB = oBaseContext.getByName(dbURL)
oCon = oDB.getConnection("", "")
oStmt = oCon.createStatement()
sTableName$ = "BINDATA"
'First, check to see if the table exists!
sSql = "select count(*) from INFORMATION_SCHEMA.SYSTEM_TABLES " & "where TABLE_NAME='" & sTableName & "' " & "AND TABLE_SCHEM='PUBLIC'"
nCount = 0
oResult = oStmt.executeQuery(sSql)
If NOT IsNull(oResult) AND NOT IsEmpty(oResult) Then
oResult.Next()
nCount = oResult.getLong(1)
End If
If nCount <> 0 Then
If bForceNew Then
If Not bVerbose Then
oAns = MsgBox( "Deleting table " & sTableName, 4, "既存Table削除の最終確認")
'[ Caution] : The default behavior is to use RESTRICT rather than CASCADE. RESTRICT prevents the deletion if other things depend on this table.
If oAns = 6 then
sSql = "DROP TABLE " & DBQuoteName(sTablename, oCon) & "IF EXISTS CASCADE"
oStmt.executeQuery(sSql)
RefreshTables(dbURL$, oCon)
End If
End if
Else
If Not bVerbose Then
print "Table " + sTableName + " already exists!"
oCon.close()
Exit Sub
End If
End If
End If
'I did not quote the field names because I know that they are all uppercase with nothing special about them.
sSql = "CREATE TABLE " & DBQuoteName(sTableName, oCon) & "(ID INTEGER NOT NULL IDENTITY PRIMARY KEY, " & " NAME VARCHAR(255) NULL, " & " DATA LONGVARBINARY NULL)"
oStmt.executeQuery(sSql)
If bVerbose Then
Print "Created table in " & dbURL
End If
RefreshTables(dbURL$, oCon)
'Do not dispose the database context or you will NOT be able to get it back without restarting OpenOffice.org.
'Store the associated document to persist the changes to disk.
print "OK!!"
oDB.DatabaseDocument.store()
oCon.close()
If bVerbose Then Print "Table " & sTableName & " created!"
End Sub
'[ Functin1 ]
Function DBQuoteName(sName As String, oCon) As String
Dim sQuote As String
sQuote = oCon.getMetaData().getIdentifierQuoteString() ' 「 " 」の事
DBQuoteName = sQuote & sName & sQuote
End Function
'[ Function2 ]
Function RefreshTables(sURL$, oCon)
Dim oDoc 'Document to refresh.
Dim oDisp 'Dispatch helper.
Dim oFrame 'Current frame.
oDoc = oFindComponentWithURL(sURL, False)
If NOT IsNULL(oDOC) AND NOT IsEmpty(oDoc) Then
oDisp = createUnoService("com.sun.star.frame.DispatchHelper")
oFrame = oDoc.getCurrentController().getFrame()
oDisp.executeDispatch(oFrame,".uno:DBRefreshTables", "", 0, Array())
End If
End Function
'[ Function3 ]
Function oFindComponentWithURL(sName$, bLoadIfNotFound As Boolean)
Dim oDocs ' Enumeration of the loaded components.
Dim oDoc ' A single enumerated component.
Dim sDocURL$ ' URL of the component that we are checking.
'Use some methods from the Tools library.
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
oDocs = StarDesktop.getComponents().createEnumeration()
Do While oDocs.hasMoreElements()
oDoc = oDocs.nextElement()
sDocURL = oGetDocURL(oDoc)
'Just in case the name contains the full URL. If the name is an Empty string, then return an Unsaved document.
If sName = sDocURL Then
oFindComponentWithURL() = oDoc
Exit Function
End If
'This will only work if the name contains the file extension.
If InStr(sDocURL, "/") > 0 Then
If FileNameoutofPath(sDocURL, "/") = sName Then
oFindComponentWithURL() = oDoc
Exit Function
End If
End If
Loop
'The document was not found perhaps the name did not contain a file extension.
oDocs = StarDesktop.getComponents().createEnumeration()
Do While oDocs.hasMoreElements()
oDoc = oDocs.nextElement()
sDocURL = oGetDocURL(oDoc)
If InStr(sDocURL, "/") > 0 Then
If GetFileNameWithoutExtension(sDocURL, "/") = sName Then
oFindComponentWithURL() = oDoc
Exit Function
End If
End If
Loop
'The name was still not found, check to see if a document exists with the specified URL.
If bLoadIfNotFound AND FileExists(sName) Then
oDoc = StarDesktop.loadComponentFromURL(sName, "_blank", 0, Array())
oFindComponentWithURL() = oDoc
'Else
' FindComponentWithURL = NULL
End If
End Function
'[ Function4 ]
Function oGetDocURL(oDoc) As String
GetDocURL() = ""
If NOT HasUNOInterfaces(oDoc, "com.sun.star.frame.XStorable") Then 'The OOo help does not support the XStorable interface, but the Basic IDE does.
MsgBox("This Document does not support com.sun.star.frame.XStorable,")
Exit Function
End If
End Function
BT-)[Base]新規Tableの追加(その4)[ For HSQLDB ]《File指定はMacro Code中》[Table名：MacroTableTest(大文字必須)]
Sub oTableCreate
'Create New Base Document
Dim oDoc
Dim Dummy()
Dim oAns
oDoc = StarDesktop.loadComponentFromURL("private:factory/sdatabase", "_blank", 0, Dummy())
oDataSource = oDoc.DataSource
' set to use hsqldb
oDataSource.URL = "sdbc:embedded:hsqldb"
oTempName = ConvertToUrl("c:\temp\oBaseMacroTest.odb")
if FileExists(oTempName) then
oAns = msgbox("同名fileがあります。削除しますか?", 4, "既存fileの削除確認")
if oAns = 6 then
'
Else
MsgBox("中断します。")
Exit Sub
End if
end if
oDoc.StoreAsURL(oTempName,Dummy())
'Load the Tools library
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
'Connect DB
Dim oBaseContent
Dim oDB
Dim oCon
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDB = oBaseContext.getByName(oTempName)
oCon = oDB.getConnection("", "")
'Create New Table
Dim oTables
Dim oTableName
Dim oTableDescriptor
'Access Tables in Connecting DB
oTables = oCon.getTables()
'Define the Table Property
oTableDescriptor = oTables.createDataDescriptor()
oTableName = "MACROTESTTABLE"
oTableDescriptor.Name = oTableName
'Define the Datas to table Columns( 最低一項目は設定が必要 )
oCols = oTableDescriptor.getColumns()
oCol = oCols.createDataDescriptor()
oCol.Name = "ID"
oCol.Type = com.sun.star.sdbc.DataType.INTEGER
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
oCol.IsAutoIncrement = True
oCol.Precision = 10
oCol.Description = "Primary Key"
oCols.appendByDescriptor(oCol)
'Create Table but not to be able to look the table, because it needs to store Base Document.
oTables.appendByDescriptor(oTableDescriptor)
'
oDB.DatabaseDocument.store() 'Base Document Save
oCon.close() 'DataBaseとのConnect切断
oDoc.close(true) 'Base File Close
msgbox("Success")
End Sub
BT-)[Base]Tableの削除
Sub DropTable
On Error Goto oBad
Dim oDoc as Object
Dim oTempName as String
Dim oFlag as Integer
oFlag = 0
oDoc = ThisComponent
oTempName = oDoc.getURL
'
' Connect DB
Dim oBaseContent as Object
Dim oDB as Object
Dim oCon as Object
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDB = oBaseContext.getByName(oTempName)
oCon = oDB.getConnection("", "")
oFlag = 777
'
' DB の Table 取得
Dim oTables as Object
Dim oTableName as String
oTableName = "CreateTb"
'
' Access Tables in Connecting DB
oTables = oCon.getTables()
'
' 同名Tableの削除
if oTables.getCount() <> 0 then
Dim oTNames() as Object
oTNames = oTables.getElementNames()
'
for i = 0 to UBound(oTNames)
if oTableName = oTNames(i) then
oTables.dropByName(oTableName)
' oTables.dropByIndex(i)
'
oDisp = "Table Nmae [ " & oTableName & " ] は削除しました。"
else
oDisp = "同名Tableはありません"
end if
next i
else
oDisp = "Tableがありません。"
end if
'
msgbox oDisp,0,"Tableの削除"
'
' Con Close
oCon.Close()
oCon.dispose
'
'
' Display
msgbox "Success"
Exit Sub
oBad:
if oFlag = 777 then
oCon.Close()
oCon.dispose
end if
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
BT-)[Base]Table数を取得
Sub DBTableNum()
'Connect DataSource
Dim oBaseContext 'Global database context.
Dim oUser$ 'User name while connecting.
Dim oPass$ 'Password while connections.
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
'Select DataSource Name
If NOT oBaseContext.hasElements() Then
MsgBox( "登録されているDataSourceはありません")
Exit Sub
End If
oDSources = oBaseContext.getElementNames()
for i = 0 to UBound(oDSources)
oAns=MsgBox("接続するDataSOurce名は " & Chr$(10) & _
"「 " & oDSources(i) & " 」" & Chr$(10) & "ですか?", 4, "DataSourceの選択")
If oAns = 6 then
'Connect with the DataSource
Dim oDataSource 'Data sources for the specified database.
Dim oCon 'Connection to a database.
oDataSource = oBaseContext.getByName(oDSources(i))
oCon = oDataSource.getConnection(oUser, oPass)
'Get the Table Num
Dim oConTables
Dim oTableNum
oConTables = oCon.getTables
oTableNum = oConTables.getCount()
If oTableNum <> 0 then
MsgBox("DataSource " & oDSources(i) & " には " & oTableNum & " tablesあります。", 0, "Table数")
Else
MsgBox("DataSource " & oDSources(i) & " にはTableがありません。")
End If
'
oCon.close() 'Unconnect with the Datasource
Exit Sub 'Exit
End if
next i
MsgBox("DataSourceが登録されていません。")
End Sub
BT-)[Base]Table名を取得(その1)
Sub DBTableName()
'Connect DataSource
Dim oBaseContext 'Global database context.
Dim oUser$ 'User name while connecting.
Dim oPass$ 'Password while connections.
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
'Select DataSource Name
If NOT oBaseContext.hasElements() Then
MsgBox( "登録されているDataSourceはありません")
Exit Sub
End If
'
oDSources = oBaseContext.getElementNames()
'
for i = 0 to UBound(oDSources)
oAns=MsgBox("接続するDataSOurce名は " & Chr$(10) & _
"「 " & oDSources(i) & " 」" & Chr$(10) & "ですか?", 4, "DataSourceの選択")
If oAns = 6 then
'Connect with the DataSource
Dim oDataSource 'Data sources for the specified database.
Dim oCon 'Connection to a database
oDataSource = oBaseContext.getByName(oDSources(i))
oCon = oDataSource.getConnection(oUser, oPass)
'Get the Table Nums
Dim oConTables
Dim oTNames
Dim oTableName
oConTables = oCon.getTables
oTNames = oConTables.getElementNames()
If NOT IsEmpty(oTNames) then
oTableName = "[ DB : 「 " & oDSources(i) & " 」 に含まれるTable Name ]" & Chr$(10)
for n = 0 to Ubound(oTNames)
oTableName = oTableName & n+1 & ") " & oTNames(n) & Chr$(10)
next n
MsgBox( oTableName, 0, "Table Name")
Else
MsgBox("DataSource " & oDSources(i) & " にはTableがありません。")
End If
'
oCon.close() 'Unconnect with the Datasource
Exit Sub 'Exit
End if
next i
MsgBox("DataSourceが登録されていません。")
End Sub
BT-)[Base]Table名を取得(その2)
Sub BaseTableName()
Dim db As Object
Dim oBase as String
oBase ="oBase_test"
db = connect_to_database(oBase)
list_tables(db)
disconnect_from_database(db)
End Sub
'[ Sub Routine1 ]
Sub disconnect_from_database ( db as Object)
db.close
db.dispose()
End Sub
'[ Sub Routine2 ]
Sub list_tables(db as Object)
Dim dbTables As Object
Dim dbTableNames
Dim opText As String
dbTables=db.getTables
dbTableNames=dbTables.getElementNames
opText=join(dbTableNames , chr(10))
msgbox opText
End Sub
'[ Function1 ]
Function connect_to_database(dbName as String) as Object
Dim dbContext As Object
Dim oDataSource As Object
dbContext =createUnoService("com.sun.star.sdb.DatabaseContext")
oDataSource= dbContext.getByName(dbName)
connect_to_database=oDataSource.GetConnection("","")
End Function
BT-)[Base]Table名をReName[Only HSQLDB]
Sub DBTableReName()
'Connect DataSource
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
'Select DataSource Name
If NOT oBaseContext.hasElements() Then
MsgBox( "登録されているDataSourceはありません")
Exit Sub
End If
'
oDSources = oBaseContext.getElementNames()
'
for i = 0 to UBound(oDSources)
oAns=MsgBox("接続するDataSOurce名は " & Chr$(10) & _
"「 " & oDSources(i) & " 」" & Chr$(10) & "ですか?", 4, "DataSourceの選択")
If oAns = 6 then
'Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName(oDSources(i))
oCon = oDataSource.getConnection(oUser, oPass)
'Get the Table Nums
Dim oConTables
Dim oTNames
Dim oTableName
oConTables = oCon.getTables
oTNames = oConTables.getElementNames()
If NOT IsEmpty(oTNames) then
'Select Table
Dim oTableAns
Dim oDBTableNm
If UBound(oTNames) = 0 then
oDBTableNm = oTNames(0)
else
for n = 0 to UBound(oTNames)
oTableAns = MsgBox(oTNames(n) & " ですか?", 4, "Tabeの選択")
If oTableAns = 6 then
oDBTableNm = oTNames(n)
n = UBound(oTNames)
End If
next n
End If
'ReName of Table Name
Dim oDBTable
Dim oFromTableName
Dim oToTableName
Dim oDisp
oDBTable = oConTables.getByName(oDBTableNm)
oFromTableName = oDBTableNm
oToTableName = "家族構成テーブル"
If NOT oConTables.hasByName(oToTableName) then
oDBtable.rename(oToTableName)
If oConTables.hasByName(oToTableName) and NOT oConTables.hasByName(oFromTableName) then
oDisp = "「 " & oFromTableName & " 」" & Chr$(10) & "のTable Name を" & Chr$(10) & _
"「 " & oToTableName & " 」" & Chr$(10) & "にReNameしました"
MsgBox(oDisp, 0, "ReName of Table Name")
else
MsgBox("ReNameに失敗しました", 0, "Caution !!")
End If
else
MsgBox(oToTableName & "は既に同名Tableが存在します", 0, "Caution !!")
End If
Else
MsgBox("DataSource " & oDSources(i) & " にはTableがありません。", 0, "Caution !!")
End If
'
oCon.close() 'Unconnect with the Datasource
Exit Sub 'Exit
End if
next i
MsgBox("DataSourceが登録されていません。", 0, "Caution !!")
End Sub
'
' Note
' FirebirdではTableのRenameは不可。 新しいTbを作成 ⇒ ﾃﾞｰﾀをCopy ⇒ 旧Tableを削除 の処置が必要。
' 参考サイト https://stackoverflow.com/questions/12291919/is-it-possible-to-rename-a-table-in-firebird/33279443
BT-)[Base]TableのColumn数を取得
Sub DBTableColsNum()
'Connect DataSource
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
'Select DataSource Name
If NOT oBaseContext.hasElements() Then
MsgBox( "登録されているDataSourceはありません")
Exit Sub
End If
'
oDSources = oBaseContext.getElementNames()
'
for i = 0 to UBound(oDSources)
oAns=MsgBox("接続するDataSOurce名は " & Chr$(10) & _
"「 " & oDSources(i) & " 」" & Chr$(10) & "ですか?", 4, "DataSourceの選択")
If oAns = 6 then
'Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName(oDSources(i))
oCon = oDataSource.getConnection(oUser, oPass)
'Get the Table Nums
Dim oConTables
Dim oTNames
Dim oTableName
oConTables = oCon.getTables
oTNames = oConTables.getElementNames()
If NOT IsEmpty(oTNames) then
'Select Table
Dim oTableAns
Dim oDBTableNm
If UBound(oTNames) = 0 then
oDBTableNm = oTNames(0)
else
for n = 0 to UBound(oTNames)
oTableAns = MsgBox(oTNames(n) & " ですか?", 4, "Tabeの選択")
If oTableAns = 6 then
oDBTableNm = oTNames(n)
n = UBound(oTNames)
End If
next n
End If
'Table Column数の取得
Dim oTCols
oTCols = oConTables.getByName(oDBTableNm).getColumns()
oTableCols = oTCols.getCount()
MsgBox("Table : " & oDBTableNm & " のColumn数は " & _
oTableCols & " です。", 0, "Table Column数(Item数)")
Else
MsgBox("DataSource " & oDSources(i) & " にはTableがありません。")
End If
'
oCon.close()
Exit Sub
End if
next i
MsgBox("DataSourceが登録されていません。")
End Sub
BT-)[Base]TableのData Name(Column Name)を取得
Sub oDBTableColsName
'Connect DataSource
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
'Select DataSource Name
If NOT oBaseContext.hasElements() Then
MsgBox( "登録されているDataSourceはありません")
Exit Sub
End If
'
oDSources = oBaseContext.getElementNames()
'
for i = 0 to UBound(oDSources)
oAns=MsgBox("接続するDataSOurce名は " & Chr$(10) & _
"「 " & oDSources(i) & " 」" & Chr$(10) & "ですか?", 4, "DataSourceの選択")
If oAns = 6 then
'Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName(oDSources(i))
oCon = oDataSource.getConnection(oUser, oPass)
'Get the Table Nums
Dim oConTables
Dim oTNames
Dim oTableName
oConTables = oCon.getTables
oTNames = oConTables.getElementNames()
If NOT IsEmpty(oTNames) then
'Select Table
Dim oTableAns
Dim oDBTableNm
If UBound(oTNames) = 0 then
oDBTableNm = oTNames(0)
else
for n = 0 to UBound(oTNames)
oTableAns = MsgBox(oTNames(n) & " ですか?", 4, "Tabeの選択")
If oTableAns = 6 then
oDBTableNm = oTNames(n)
n = UBound(oTNames)
End If
next n
End If
'Data Nameの取得
Dim oTCols
Dim oTCNames
Dim oColsName
oTCols = oConTables.getByName(oDBTableNm).getColumns()
oTCNames = oTCols.getElementNames()
oColsName = "[ DB : 「 " & oDSources(i) & " 」 ］" & Chr$(10) 'Add DataSource Name
oColsName = oColsName & "<< " & oDBTableNm & " >>" & Chr$(10) 'Add Table Name
If NOT IsEmpty(oTCNames) then
for j = 0 to UBound(oTCNames)
oColsName = oColsName & j+1 & ") " & oTCNames(j) & Chr$(10)
next j
Else
oColsName = "Data Itemがありません。"
End If
MsgBox( oColsName, 0, "Item( Column ) Name")
Else
MsgBox("DataSource " & oDSources(i) & " にはTableがありません。")
End If
'
oCon.close()
Exit Sub
End if
next i
MsgBox("DataSourceが登録されていません。")
End Sub
BT-)[Base]dbg情報{ Table Cloumn }
Sub dbgDBTableColumns()
'Connect DataSource
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
'Select DataSource Name
If NOT oBaseContext.hasElements() Then
MsgBox( "登録されているDataSourceはありません")
Exit Sub
End If
'
oDSources = oBaseContext.getElementNames()
'
for i = 0 to UBound(oDSources)
oAns=MsgBox("接続するDataSOurce名は " & Chr$(10) & _
"「 " & oDSources(i) & " 」" & Chr$(10) & "ですか?", 4, "DataSourceの選択")
If oAns = 6 then
'Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName(oDSources(i))
oCon = oDataSource.getConnection(oUser, oPass)
'Get the Table Nums
Dim oConTables
Dim oTNames
Dim oTableName
oConTables = oCon.getTables
oTNames = oConTables.getElementNames()
If NOT IsEmpty(oTNames) then
'Select Table
Dim oTableAns
Dim oDBTableNm
If UBound(oTNames) = 0 then
oDBTableNm = oTNames(0)
else
for n = 0 to UBound(oTNames)
oTableAns = MsgBox(oTNames(n) & " ですか?", 4, "Tabeの選択")
If oTableAns = 6 then
oDBTableNm = oTNames(n)
n = UBound(oTNames)
End If
next n
End If
'dbg
Dim oTCols
Dim oTColsMethods
Dim oTColsSupportedInterfaces
Dim oTColsProperties
oTCols = oConTables.getByName(oDBTableNm).getColumns()
oTColsMethods = oTCols.dbg_methods
oTColsSupportedInterfaces = oTCols.dbg_SupportedInterfaces
oTColsProperties = oTCols.dbg_properties
MsgBox( oTColsSupportedInterfaces, 0, "dbg_SupportedInterfaces for DB Table Columns")
MsgBox( oTColsMethods, 0, "dbg_methods for DB Table Columns")
MsgBox( oTColsProperties, 0, "dbg_properties for DB Table Columns")
Else
MsgBox("DataSource " & oDSources(i) & " にはTableがありません。")
End If
'
oCon.close()
Exit Sub
End if
next i
MsgBox("DataSourceが登録されていません。")
End Sub
BT-)[Base]getTypes{ Table Cloumn }
Sub DBTableColsType()
'Connect DataSource
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
'Select DataSource Name
If NOT oBaseContext.hasElements() Then
MsgBox( "登録されているDataSourceはありません")
Exit Sub
End If
'
oDSources = oBaseContext.getElementNames()
'
for i = 0 to UBound(oDSources)
oAns=MsgBox("接続するDataSOurce名は " & Chr$(10) & _
"「 " & oDSources(i) & " 」" & Chr$(10) & "ですか?", 4, "DataSourceの選択")
If oAns = 6 then
'Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName(oDSources(i))
oCon = oDataSource.getConnection(oUser, oPass)
'Get the Table Nums
Dim oConTables
Dim oTNames
Dim oTableName
oConTables = oCon.getTables
oTNames = oConTables.getElementNames()
If NOT IsEmpty(oTNames) then
'Select Table
Dim oTableAns
Dim oDBTableNm
If UBound(oTNames) = 0 then
oDBTableNm = oTNames(0)
else
for n = 0 to UBound(oTNames)
oTableAns = MsgBox(oTNames(n) & " ですか?", 4, "Tabeの選択")
If oTableAns = 6 then
oDBTableNm = oTNames(n)
n = UBound(oTNames)
End If
next n
End If
'Column Typeの取得
Dim oTCols
Dim oTCTypes
Dim oColsType
oTCols = oConTables.getByName(oDBTableNm).getColumns()
oTCTypes = oTCols.getTypes()
oColsType = "[ DB : 「 " & oDSources(i) & " 」 ］" & Chr$(10) 'Add DataSource Name
oColsType = oColsType & "＜＜ " & oDBTableNm & " ＞＞" & Chr$(10) 'Add Table Name
If NOT IsEmpty(oTCTypes) then
for j = 0 to UBound(oTCTypes)
oColsType = oColsType & j+1 & ") " & oTCTypes(j).Name & Chr$(10)
next j
Else
oColsType = "Columnがありません。"
End If
MsgBox( oColsType, 0, "getTypes")
Else
MsgBox("DataSource " & oDSources(i) & " にはTableがありません。")
End If
'
oCon.close()
Exit Sub
End if
next i
MsgBox("DataSourceが登録されていません。")
End Sub
BT-)[Base]getImplementationID{ Table Cloumn }
Sub oDBTCImplementationID
'Connect DataSource
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
'Select DataSource Name
If NOT oBaseContext.hasElements() Then
MsgBox( "登録されているDataSourceはありません")
Exit Sub
End If
'
oDSources = oBaseContext.getElementNames()
'
for i = 0 to UBound(oDSources)
oAns=MsgBox("接続するDataSOurce名は " & Chr$(10) & _
"「 " & oDSources(i) & " 」" & Chr$(10) & "ですか?", 4, "DataSourceの選択")
If oAns = 6 then
'Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName(oDSources(i))
oCon = oDataSource.getConnection(oUser, oPass)
'Get the Table Nums
Dim oConTables
Dim oTNames
Dim oTableName
oConTables = oCon.getTables
oTNames = oConTables.getElementNames()
If NOT IsEmpty(oTNames) then
'Select Table
Dim oTableAns
Dim oDBTableNm
If UBound(oTNames) = 0 then
oDBTableNm = oTNames(0)
else
for n = 0 to UBound(oTNames)
oTableAns = MsgBox(oTNames(n) & " ですか?", 4, "Tabeの選択")
If oTableAns = 6 then
oDBTableNm = oTNames(n)
n = UBound(oTNames)
End If
next n
End If
'Column IDの取得
Dim oTCols
Dim oTCID
Dim oColsID
oTCols = oConTables.getByName(oDBTableNm).getColumns()
oTCID = oTCols.getImplementationID()
oColsID = "[ DB : 「 " & oDSources(i) & " 」 ］" & Chr$(10) 'Add DataSource Name
oColsID = oColsID & "<< " & oDBTableNm & " >>" & Chr$(10) 'Add Table Name
If NOT IsEmpty(oTCID) then
for j = 0 to UBound(oTCID)
oColsID = oColsID & j+1 & ") " & oTCID(j) & Chr$(10)
next j
Else
oColsID = "Columnがありません。"
End If
MsgBox( oColsID, 0, "getImplementationID()")
Else
MsgBox("DataSource " & oDSources(i) & " にはTableがありません。")
End If
'
oCon.close()
Exit Sub
End if
next i
MsgBox("DataSourceが登録されていません。")
End Sub
BT-)[Base]ImplementationName ＆ ID取得
Sub oDBTableColsImplementation
'Connect DataSource
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
'Select DataSource Name
If NOT oBaseContext.hasElements() Then
MsgBox( "登録されているDataSourceはありません")
Exit Sub
End If
'
oDSources = oBaseContext.getElementNames()
'
for i = 0 to UBound(oDSources)
oAns=MsgBox("接続するDataSOurce名は " & Chr$(10) & _
"「 " & oDSources(i) & " 」" & Chr$(10) & "ですか?", 4, "DataSourceの選択")
If oAns = 6 then
'Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName(oDSources(i))
oCon = oDataSource.getConnection(oUser, oPass)
'Get the Table Nums
Dim oConTables
Dim oTNames
Dim oTableName
oConTables = oCon.getTables
oTNames = oConTables.getElementNames()
If NOT IsEmpty(oTNames) then
'Select Table
Dim oTableAns
Dim oDBTableNm
If UBound(oTNames) = 0 then
oDBTableNm = oTNames(0)
else
for n = 0 to UBound(oTNames)
oTableAns = MsgBox(oTNames(n) & " ですか?", 4, "Tabeの選択")
If oTableAns = 6 then
oDBTableNm = oTNames(n)
n = UBound(oTNames)
End If
next n
End If
'Implementation
Dim oTCols
Dim oTColsImpName
Dim oTColsImpID
Dim oDisp
oTCols = oConTables.getByName(oDBTableNm).getColumns()
oTColsImpName = oTCols.getImplementationName()
oTColsImpID = oTCols.getImplementationID()
oDisp = "DB : " & oDSources(i) & Chr$(10) & "Table Name : " & oDBTableNm & Chr$(10) & _
"[ Implementation Name : " & oTColsImpName & " ]" & Chr$(10) & _
"[ Implementation ID ]" & Chr$(10)
for j = LBound(oTColsImpID) to UBound(oTColsImpID)
oDisp = oDisp & " " & j+1 & ") " & oTColsImpID(j) & Chr$(10)
Next j
MsgBox( oDisp, 0, "Implementation of Column" )
Else
MsgBox("DataSource " & oDSources(i) & " にはTableがありません。")
End If
'
oCon.close()
Exit Sub
End if
next i
MsgBox("DataSourceが登録されていません。")
End Sub
BT-)[Base]( Don't work )Table Refresh1
Sub oTableRefresh
On Error Goto oBad
'Create New Base Document
Dim oDoc as Object
Dim Dummy()
oTempName = ConvertToUrl("c:\temp\oBaseMacro3.odb")
oDoc = StarDesktop.loadComponentFromURL(oTempName, "_default", 0, Dummy())
oDataSource = oDoc.DataSource
'
' set to use hsqldb
oDataSource.URL = "sdbc:embedded:hsqldb"
' store
Dim oArgs(0) As new com.sun.star.beans.PropertyValue
oArgs(0).Name = "Overwrite"
oArgs(0).Value = true
oDoc.StoreAsURL(oTempName,oArgs())
'
' Load the Tools library
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
'
' Connect DB
Dim oBaseContent as Object
Dim oDB as Object
Dim oCon as Object
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDB = oBaseContext.getByName(oTempName)
oCon = oDB.getConnection("", "")
'
Dim oStmt as Object
Dim oSQL1 as String
Dim oSQL2 as String
Dim oTableName as String
oTableName = "TABLE_REFRESH" ' 大文字
oStmt = oCon.createStatement()
' CREATE TABLE句
' 既存Tableがあると削除する
oSQL1 = "DROP TABLE " & oTableName & " IF EXISTS; "
oStmt.execute(oSQL1)
'
oSQL2 = "CREATE TABLE " & oTableName & "(ID INTEGER IDENTITY, oDate Date, PRIMARY KEY (ID)) "
oStmt.execute(oSQL2)
'
' ********** [ 表示 → Tableの更新 ] **********
'
oCon.getTables().refresh()
'
' ****************************************
'
oCon.Close()
oCon.dispose
'
' Display
msgbox "Success"
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
'
oCon.Close()
oCon.dispose
End Sub
'
' [ Note ]
' OpenOffice.org Basic Macro Proguramming By Andrew Pitonyak ⇒ Unfortunately, calling refresh (see Listing 5) does not always work.)
BT-)[Base]Table Refresh2
Sub oTableRefresh
On Error Goto oBad
'Create New Base Document
Dim oDoc as Object
Dim Dummy()
oTempName = ConvertToUrl("c:\temp\oBaseMacro3.odb")
oDoc = StarDesktop.loadComponentFromURL(oTempName, "_default", 0, Dummy())
oDataSource = oDoc.DataSource
'
' set to use hsqldb
oDataSource.URL = "sdbc:embedded:hsqldb"
' store
Dim oArgs(0) As new com.sun.star.beans.PropertyValue
oArgs(0).Name = "Overwrite"
oArgs(0).Value = true
oDoc.StoreAsURL(oTempName,oArgs())
'
' Load the Tools library
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
'
' Connect DB
Dim oBaseContent as Object
Dim oDB as Object
Dim oCon as Object
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDB = oBaseContext.getByName(oTempName)
oCon = oDB.getConnection("", "")
'
Dim oStmt as Object
Dim oSQL1 as String
Dim oSQL2 as String
Dim oTableName as String
oTableName = "UPDATE_DISP" ' 大文字
oStmt = oCon.createStatement()
' CREATE TABLE句
' 既存Tableがあると削除する
oSQL1 = "DROP TABLE " & oTableName & " IF EXISTS; "
oStmt.execute(oSQL1)
'
oSQL2 = "CREATE TABLE " & oTableName & "(ID INTEGER IDENTITY, oDate Date, PRIMARY KEY (ID)) "
oStmt.execute(oSQL2)
'
oCon.Close()
oCon.dispose
'
' ********** [ 表示 → Tableの更新 ] **********
'
Dim dispatcher as Object
Dim oFrame as Object
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
oFrame = oDoc.getCurrentController().getFrame()
dispatcher.executeDispatch(oFrame,".uno:DBRefreshTables", "", 0, Array())
'
' ****************************************
'
' Display
msgbox "Success"
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
'
oCon.Close()
oCon.dispose
End Sub
BT-)[Base]
[ ResultSet Service ]
BTRt-)Tableの行No.の取得[For HSQLDB]
Sub oSQLResultset
On Error Goto oBad
'Create New Base Document
Dim oDoc
Dim Dummy()
Dim oAns
oDoc = StarDesktop.loadComponentFromURL("private:factory/sdatabase", "_blank", 0, Dummy())
oDataSource = oDoc.DataSource
'
' set to use hsqldb
oDataSource.URL = "sdbc:embedded:hsqldb"
oTempName = ConvertToUrl("c:\temp\oBaseMacroTest.odb")
if FileExists(oTempName) then
oAns = msgbox("同名fileがあります。削除しますか?", 4, "既存fileの削除確認")
if oAns = 6 then
Kill(oTempName)
Else
MsgBox("中断します。")
Exit Sub
End if
end if
oDoc.StoreAsURL(oTempName,Dummy())
'
' Load the Tools library
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
'
' Connect DB
Dim oBaseContent
Dim oDB
Dim oCon
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDB = oBaseContext.getByName(oTempName)
oCon = oDB.getConnection("", "")
' CREATE TABLE句
Dim oStmt as Object
Dim oSQL as String
Dim oTableName as String
oTableName = "ADRESS" ' 大文字
oStmt = oCon.createStatement()
oSQL = "CREATE TABLE " & oTableName & "(ID INTEGER IDENTITY,ADRESS varchar(5),TITLE varchar(10),NAME varchar(30), PRIMARY KEY (ID)) "
oStmt.execute(oSQL)
'
' INSERT INTO句
Dim oSQL2 as String
Dim oValue as String
Dim i as Integer
for i = 1 to 100
oValue = "VALUES(" & i & ",'home', 'Test" & i & "', 'New_OOo3')"
oSQL2 = "INSERT INTO " & oTableName & "(ID, ADRESS, TITLE, NAME)" & " " & oValue
oStmt.executeUpdate(oSQL2)
Next i
'
' ResultSet
Dim oSQL3 as String
Dim oRS as Object
Dim oLastRowNo, oFirstRowNo, oPreviousRow, oNextRow as Long
oStmt.ResultSetType = com.sun.star.sdbc.ResultSetType.SCROLL_INSENSITIVE
oSQL3 = "SELECT * FROM " & oTableName
oRS = oStmt.executeQuery(oSQL3)
'
oDisp = "Table Name => " & oTableName & Chr$(10) & Chr$(10)
'
oRS.Last
oLastRowNo = oRS.Row
'
oRS.Previous
oPreviousRow = oRS.Row
'
oRS.First
oFirstRowNo = oRS.Row
'
oRS.Next
oNextRow = oRS.Row
'
' ResultSet Close
oRS.close
Set oRS = Nothing
'
oDisp = oDisp & "最後のRow No => " & oLastRowNo & Chr$(10) & _
"前のRow No => " & oPreviousRow & Chr$(10) & _
"最初のRow No => " & oFirstRowNo & Chr$(10) & _
"次のRow No => " & oNextRow
msgbox(oDisp,0,"Tableの行No")
'
oCon.Close()
oCon.dispose
'
' Display
msgbox "Success"
Exit Sub
oBad:
oCon.Close()
oCon.dispose
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
'
'[Note]
Firebirdでは、Resultsetで行の移動をする Last / First / Previous / Next / .Relative() プロパティはsupport外になっている(LO 6.2.4.2)。 Resultsetの.Absolute() 又はRowset Serviceを利用のこと。
BTRt-)現在のCurosr位置判定[For HSQLDB]
Sub oSQLResultset
On Error Goto oBad
'Create New Base Document
Dim oDoc
Dim Dummy()
Dim oAns
oDoc = StarDesktop.loadComponentFromURL("private:factory/sdatabase", "_blank", 0, Dummy())
oDataSource = oDoc.DataSource
'
' set to use hsqldb
oDataSource.URL = "sdbc:embedded:hsqldb"
oTempName = ConvertToUrl("c:\temp\oBaseMacroTest.odb")
if FileExists(oTempName) then
oAns = msgbox("同名fileがあります。削除しますか?", 4, "既存fileの削除確認")
if oAns = 6 then
Kill(oTempName)
Else
MsgBox("中断します。")
Exit Sub
End if
end if
oDoc.StoreAsURL(oTempName,Dummy())
'
' Load the Tools library
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
'
' Connect DB
Dim oBaseContent
Dim oDB
Dim oCon
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDB = oBaseContext.getByName(oTempName)
oCon = oDB.getConnection("", "")
' CREATE TABLE句
Dim oStmt as Object
Dim oSQL as String
Dim oTableName as String
oTableName = "ADRESS" ' 大文字
oStmt = oCon.createStatement()
oSQL = "CREATE TABLE " & oTableName & "(ID INTEGER IDENTITY,ADRESS varchar(5),TITLE varchar(10),NAME varchar(30), PRIMARY KEY (ID)) "
oStmt.execute(oSQL)
'
' INSERT INTO句
Dim oSQL2 as String
Dim oValue as String
Dim i as Integer
for i = 1 to 100
oValue = "VALUES(" & i & ",'home', 'Test" & i & "', 'New_OOo3')"
oSQL2 = "INSERT INTO " & oTableName & "(ID, ADRESS, TITLE, NAME)" & " " & oValue
oStmt.executeUpdate(oSQL2)
Next i
'
' ResultSet
Dim oSQL3 as String
Dim oRS as Object
Dim oIsBeforeFirst1, oIsAfterLast1, oIsFirst1, oIsLast1 as Boolean
Dim oIsBeforeFirst2, oIsAfterLast2, oIsFirst2, oIsLast2 as Boolean
Dim oIsBeforeFirst3, oIsAfterLast3, oIsFirst3, oIsLast3 as Boolean
Dim oIsBeforeFirst4, oIsAfterLast4, oIsFirst4, oIsLast4 as Boolean
Dim oIsBeforeFirst5, oIsAfterLast5, oIsFirst5, oIsLast5 as Boolean
Dim oIsBeforeFirst6, oIsAfterLast6, oIsFirst6, oIsLast6 as Boolean
Dim oIsBeforeFirst7, oIsAfterLast7, oIsFirst7, oIsLast7 as Boolean
Dim oRowNo1, oRowNo2, oRowNo3, oRowNo4, oRowNo5, oRowNo6, oRowNo7 as Integer
'
oStmt.ResultSetType = com.sun.star.sdbc.ResultSetType.SCROLL_INSENSITIVE
oSQL3 = "SELECT * FROM " & oTableName
oRS = oStmt.executeQuery(oSQL3)
'
oDisp = "Table Name => " & oTableName & Chr$(10) & Chr$(10)
'
oRowNo1 = oRS.getRow()
oIsBeforeFirst1 = oRS.isBeforeFirst
oIsAfterLast1 = oRS.isAfterLast
oIsFirst1 = oRS.isFirst
oIsLast1 = oRS.isLast
oDisp = oDisp & " 現在のCurorのRow No => " & oRowNo1 & Chr$(10) & _
Chr$(9) & "isBeforeFirst => " & oIsBeforeFirst1 & Chr$(9) & "isAfterLast => " & oIsAfterLast1 & Chr$(10) & _
Chr$(9) & "isFirst => " & oIsFirst1 & Chr$(9) & "isLast => " & oIsLast1 & Chr$(10) & Chr(10)
'
oRS.Last
oRowNo2 = oRS.getRow()
oIsBeforeFirst2 = oRS.isBeforeFirst
oIsAfterLast2 = oRS.isAfterLast
oIsFirst2 = oRS.isFirst
oIsLast2 = oRS.isLast
oDisp = oDisp & " 現在のCurorのRow No => " & oRowNo2 & Chr$(10) & _
Chr$(9) & "isBeforeFirst => " & oIsBeforeFirst2 & Chr$(9) & "isAfterLast => " & oIsAfterLast2 & Chr$(10) & _
Chr$(9) & "isFirst => " & oIsFirst2 & Chr$(9) & "isLast => " & oIsLast2 & Chr$(10) & Chr(10)
'
oRS.Absolute(50)
oRowNo3 = oRS.getRow()
oIsBeforeFirst3 = oRS.isBeforeFirst
oIsAfterLast3 = oRS.isAfterLast
oIsFirst3 = oRS.isFirst
oIsLast3 = oRS.isLast
oDisp = oDisp & " 現在のCurorのRow No => " & oRowNo3 & Chr$(10) & _
Chr$(9) & "isBeforeFirst => " & oIsBeforeFirst3 & Chr$(9) & "isAfterLast => " & oIsAfterLast3 & Chr$(10) & _
Chr$(9) & "isFirst => " & oIsFirst3 & Chr$(9) & "isLast => " & oIsLast3 & Chr$(10) & Chr(10)
'
oRS.Relative(-10)
oRowNo4 = oRS.getRow()
oIsBeforeFirst4 = oRS.isBeforeFirst
oIsAfterLast4 = oRS.isAfterLast
oIsFirst4 = oRS.isFirst
oIsLast4 = oRS.isLast
oDisp = oDisp & " 現在のCurorのRow No => " & oRowNo4 & Chr$(10) & _
Chr$(9) & "isBeforeFirst => " & oIsBeforeFirst4 & Chr$(9) & "isAfterLast => " & oIsAfterLast4 & Chr$(10) & _
Chr$(9) & "isFirst => " & oIsFirst4 & Chr$(9) & "isLast => " & oIsLast4 & Chr$(10) & Chr(10)
'
oRS.First
oRowNo5 = oRS.getRow()
oIsBeforeFirst5 = oRS.isBeforeFirst
oIsAfterLast5 = oRS.isAfterLast
oIsFirst5 = oRS.isFirst
oIsLast5 = oRS.isLast
oDisp = oDisp & " 現在のCurorのRow No => " & oRowNo5 & Chr$(10) & _
Chr$(9) & "isBeforeFirst => " & oIsBeforeFirst5 & Chr$(9) & "isAfterLast => " & oIsAfterLast5 & Chr$(10) & _
Chr$(9) & "isFirst => " & oIsFirst5 & Chr$(9) & "isLast => " & oIsLast5 & Chr$(10) & Chr(10)
'
oRS.afterLast
oRowNo6 = oRS.getRow()
oIsBeforeFirst6 = oRS.isBeforeFirst
oIsAfterLast6 = oRS.isAfterLast
oIsFirst6 = oRS.isFirst
oIsLast6 = oRS.isLast
oDisp = oDisp & " 現在のCurorのRow No( End of result set ) => " & oRowNo6 & Chr$(10) & _
Chr$(9) & "isBeforeFirst => " & oIsBeforeFirst6 & Chr$(9) & "isAfterLast => " & oIsAfterLast6 & Chr$(10) & _
Chr$(9) & "isFirst => " & oIsFirst6 & Chr$(9) & "isLast => " & oIsLast6 & Chr$(10) & Chr(10)
'
oRS.beforeFirst
oRowNo7 = oRS.getRow()
oIsBeforeFirst7 = oRS.isBeforeFirst
oIsAfterLast7 = oRS.isAfterLast
oIsFirst7 = oRS.isFirst
oIsLast7 = oRS.isLast
oDisp = oDisp & " 現在のCurorのRow No( the Front of result set ) => " & oRowNo7 & Chr$(10) & _
Chr$(9) & "isBeforeFirst => " & oIsBeforeFirst7 & Chr$(9) & "isAfterLast => " & oIsAfterLast7 & Chr$(10) & _
Chr$(9) & "isFirst => " & oIsFirst7 & Chr$(9) & "isLast => " & oIsLast7
'
' ResultSet Close
oRS.close
Set oRS = Nothing
'
msgbox(oDisp,0,"ResultSet Service")
'
oCon.Close()
oCon.dispose
'
' Display
msgbox "Success"
Exit Sub
oBad:
oCon.Close()
oCon.dispose
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
BTRt-)現在のCurosr位置判定[For Firebird]
Sub BaseFirbird()
Dim oDoc as Object, oBaseContext as Object
Dim oUser$
Dim oPass$
Dim oTempName as String
oDoc = ThisComponent
oTempName = oDoc.getURL
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource as Object
Dim oCon as Object
oDataSource = oBaseContext.getByName(oTempName)
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt as Object
Dim oSQL as String, oTbName as String
oTbName = "ADDRESS"
oStmt = oCon.createStatement()
'
oSQL = "RECREATE TABLE " & oTbName & "(ID INT NOT NULL PRIMARY KEY, NAME VARCHAR(20) NOT NULL UNIQUE, VERSION VARCHAR(20)); "
oStmt.execute(oSQL)
'
' Insert Into Clause
Dim oSQL2 as String
Dim oValue as String
Dim i as Integer
oStmt = oCon.createStatement() ' Firebird ではTable作成後、再度、oStmｔの作成が必要
for i = 1 to 10
oValue = "VALUES (" & i & " , 'Firebird_" & i & "', 'LO6.2.4.2');"
oSQL2 = "INSERT INTO " & oTbName & " " & oValue
oStmt.executeUpdate(oSQL2)
Next i
' ********** [ 表示 → Tableの更新 ] **********
Dim dispatcher as Object
Dim oFrame as Object
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
oFrame = oDoc.getCurrentController().getFrame()
dispatcher.executeDispatch(oFrame,".uno:DBRefreshTables", "", 0, Array())
' ****************************************
'
' ' ResultSet
Dim oSQL3 as String
Dim oRS as Object
Dim oIsBeforeFirst1, oIsAfterLast1, oIsFirst1, oIsLast1 as Boolean
Dim oIsBeforeFirst2, oIsAfterLast2, oIsFirst2, oIsLast2 as Boolean
Dim oRowNo1, oRowNo2 as Integer
'
oStmt.ResultSetType = com.sun.star.sdbc.ResultSetType.SCROLL_INSENSITIVE
oSQL3 = "SELECT * FROM " & oTbName
oRS = oStmt.executeQuery(oSQL3)
'
oDisp = "Table Name => " & oTbName & Chr$(10) & Chr$(10)
'
oRowNo1 = oRS.getRow()
oIsBeforeFirst1 = oRS.isBeforeFirst
oIsAfterLast1 = oRS.isAfterLast
oIsFirst1 = oRS.isFirst
' oIsLast1 = oRS.isLast ' Firebird ではｻﾎﾟｰﾄされていない。 LO 6.2.4.2 (x64)
oDisp = oDisp & " 現在のCurorのRow No => " & oRowNo1 & Chr$(10) & _
Chr$(9) & "isBeforeFirst => " & oIsBeforeFirst1 & Chr$(9) & "isAfterLast => " & oIsAfterLast1 & Chr$(10) & _
Chr$(9) & "isFirst => " & oIsFirst1 & Chr$(10) & Chr(10)
'
oRS.Absolute(5)
oRowNo2 = oRS.getRow()
oIsBeforeFirst2 = oRS.isBeforeFirst
oIsAfterLast2 = oRS.isAfterLast
oIsFirst2 = oRS.isFirst
'oIsLast2 = oRS.isLast ' Firebird ではｻﾎﾟｰﾄされていない。 LO 6.2.4.2 (x64)
oDisp = oDisp & " 現在のCurorのRow No => " & oRowNo2 & Chr$(10) & _
Chr$(9) & "isBeforeFirst => " & oIsBeforeFirst2 & Chr$(9) & "isAfterLast => " & oIsAfterLast2 & Chr$(10) & _
Chr$(9) & "isFirst => " & oIsFirst2
'
' ResultSet Close
oRS.close
Set oRS = Nothing
'
' Display
msgbox oDisp,0,"ResultSet Service(LO 6.2.4.2 (x64))"
'
oCon.Close()
oCon.dispose
msgbox "Success",0,"LO 6.2.4.2 (x64)"
End Sub
'
'[ Note ]
Firebirdでは、Resultsetで行の移動をする Last / First / Previous / Next / .Relative() プロパティはsupport外になっている(LO 6.2.4.2)。 Resultsetの.Absolute() 又はRowset Serviceを利用のこと。
isLast もsupport外になっている(LO 6.2.4.2)
BTRt-)Result SetからのColumn情報取得1[For HSQLDB]
Sub oSQLResultset
On Error Goto oBad
'Create New Base Document
Dim oDoc as Object
Dim Dummy()
Dim oAns as Long
oDoc = StarDesktop.loadComponentFromURL("private:factory/sdatabase", "_blank", 0, Dummy())
oDataSource = oDoc.DataSource
'
' set to use hsqldb
oDataSource.URL = "sdbc:embedded:hsqldb"
oTempName = ConvertToUrl("c:\temp\oBaseMacroTest.odb")
if FileExists(oTempName) then
oAns = msgbox("同名fileがあります。削除しますか?", 4, "既存fileの削除確認")
if oAns = 6 then
Kill(oTempName)
Else
MsgBox("中断します。")
Exit Sub
End if
end if
oDoc.StoreAsURL(oTempName,Dummy())
'
' Load the Tools library
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
'
' Connect DB
Dim oBaseContent as Object
Dim oDB as Object
Dim oCon as Object
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDB = oBaseContext.getByName(oTempName)
oCon = oDB.getConnection("", "")
' CREATE TABLE句
Dim oStmt as Object
Dim oSQL as String
Dim oTableName as String
oTableName = "ADRESS" ' 大文字
oStmt = oCon.createStatement()
oSQL = "CREATE TABLE " & oTableName & "(ID INTEGER IDENTITY,ADRESS varchar(5),TITLE varchar(10),NAME varchar(30), PRIMARY KEY (ID)) "
oStmt.execute(oSQL)
'
' INSERT INTO句
Dim oSQL2 as String
Dim oValue as String
Dim i as Integer
for i = 1 to 100
oValue = "VALUES(" & i & ",'home', 'Test" & i & "', 'New_OOo3')"
oSQL2 = "INSERT INTO " & oTableName & "(ID, ADRESS, TITLE, NAME)" & " " & oValue
oStmt.executeUpdate(oSQL2)
Next i
'
' Result Set
Dim oSQL3 as String
Dim oRS as Object
oSQL3 = "SELECT * FROM " & oTableName
oRS = oStmt.executeQuery(oSQL3)
'
' Result Setから、TableのColumn情報を取得
Dim oRSCol as Object
Dim oHasElmt as boolean
Dim oColNum as Integer
Dim oColIndex, oColName as Object
Dim oColFind as Object
Dim oColDisPlaySize1, oColDisPlaySize2, oColDisPlaySize3 as Integer
Dim oColLabel1, oColName1, oColTypename1 as String
Dim oColLabel2, oColName2, oColTypename2 as String
Dim oColLabel3, oColName3, oColTypename3 as String
Dim oColPrecision1, oColType1 as Integer
Dim oColPrecision2, oColType2 as Integer
Dim oColPrecision3, oColType3 as Integer
'
oRSCol = oRS.getColumns()
'
oHasElmt = oRSCol.hasElements()
oColNum = oRSCol.getCount()
oDisp = "Table Name => " & oTableName & Chr$(10) & "Data( Column )の有(true)無(false) =>" & oHasElmt & Chr$(10) & _
"Column 数 => " & oColNum & Chr$(10) & Chr$(10)
'
'
oColIndex = oRSCol.getByIndex(0)
'
oColDisPlaySize1 = oColIndex.DisplaySize
oColLabel1 = oColIndex.Label
oColName1 = oColIndex.Name
oColPrecision1 = oColIndex.Precision
oColType1 = oColIndex.Type
oColTypename1 = oColIndex.TypeName
oDisp = oDisp & "「 oRSCol.getByIndex(0) 」にてColumn Object取得" & Chr$(10) & _
"表示されるCloumn幅(文字数) => " & oColDisPlaySize1 & Chr$(10) & _
"表示されるColumn Name => " & oColLabel1 & Chr$(10) & _
"Columnの認識名 => " & oColName1 & Chr$(10) & _
"ColumnのPrecision => " & oColPrecision1 & Chr$(10) & _
"ColumnのType => " & oColType1 & Chr$(10) & _
"ColumnのTypeName => " & oColTypename1 & Chr$(10) & Chr$(10)
'
oColName = oRSCol.getByName("ADRESS")
'
oColDisPlaySize2 = oColName.DisplaySize
oColLabel2 = oColName.Label
oColName2 = oColName.Name
oColPrecision2 = oColName.Precision
oColType2 = oColName.Type
oColTypename2 = oColName.TypeName
oDisp = oDisp & "「 oRSCol.getByName([String]) 」にてColumn Object取得" & Chr$(10) & _
"表示されるCloumn幅(文字数) => " & oColDisPlaySize2 & Chr$(10) & _
"表示されるColumn Name => " & oColLabel2 & Chr$(10) & _
"Columnの認識名 => " & oColName2 & Chr$(10) & _
"ColumnのPrecision => " & oColPrecision2 & Chr$(10) & _
"ColumnのType => " & oColType2 & Chr$(10) & _
"ColumnのTypeName => " & oColTypename2 & Chr$(10) & Chr$(10)
'
oColFind = oRSCol.getByIndex(Int( oRSCol.findColumn("TITLE")))
'
oColDisPlaySize3 = oColFind.DisplaySize
oColLabel3 = oColFind.Label
oColName3 = oColFind.Name
oColPrecision3 = oColFind.Precision
oColType3 = oColFind.Type
oColTypename3 = oColFind.TypeName
oDisp = oDisp & "「 oRSCol.getByIndex(Int( oRSCol.findColumn([String]))) 」にてColumn Object取得" & Chr$(10) & _
"表示されるCloumn幅(文字数) => " & oColDisPlaySize3 & Chr$(10) & _
"表示されるColumn Name => " & oColLabel3 & Chr$(10) & _
"Columnの認識名 => " & oColName3 & Chr$(10) & _
"ColumnのPrecision => " & oColPrecision3 & Chr$(10) & _
"ColumnのType => " & oColType3 & Chr$(10) & _
"ColumnのTypeName => " & oColTypename3
'
' ResultSet Close
oRS.close
Set oRS = Nothing
'
msgbox(oDisp,0,"Result SetからのColumn情報")
'
'
oCon.Close()
oCon.dispose
'
' Display
msgbox "Success"
Exit Sub
oBad:
oCon.Close()
oCon.dispose
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
BTRt-)Result SetからのColumn情報取得1[For Firebird]
Sub BaseFirbird()
Dim oDoc as Object, oBaseContext as Object
Dim oUser$
Dim oPass$
Dim oTempName as String
oDoc = ThisComponent
oTempName = oDoc.getURL
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource as Object
Dim oCon as Object
oDataSource = oBaseContext.getByName(oTempName)
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt as Object
Dim oSQL as String, oTbName as String
Dim oCol1 as String, oCol2 as String, oCol3 as String
oTbName = "ADDRESS"
oCol1="ID"
oCol2="NAME"
oCol3="TITLE"
oStmt = oCon.createStatement()
'
oSQL = "CREATE TABLE " & oTbName & "(" & oCol1 & " " & "INT NOT NULL PRIMARY KEY, " & oCol2 & " " & "VARCHAR(20) NOT NULL UNIQUE, " & _
oCol3 & " " & "VARCHAR(40) NOT NULL UNIQUE); "
oStmt.execute(oSQL)
' ********** [ 表示 → Tableの更新 ] **********
Dim dispatcher as Object
Dim oFrame as Object
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
oFrame = oDoc.getCurrentController().getFrame()
dispatcher.executeDispatch(oFrame,".uno:DBRefreshTables", "", 0, Array())
' ****************************************
'
' Result Set
Dim oSQL3 as String
Dim oRS as Object
oSQL3 = "SELECT * FROM " & oTbName
oRS = oStmt.executeQuery(oSQL3)
'
' Result Setから、TableのColumn情報を取得
Dim oRSCol as Object
Dim oHasElmt as boolean
Dim oColNum as Integer
Dim oColIndex, oColName as Object
Dim oColFind as Object
Dim oColDisPlaySize1, oColDisPlaySize2, oColDisPlaySize3 as Integer
Dim oColLabel1, oColName1, oColTypename1 as String
Dim oColLabel2, oColName2, oColTypename2 as String
Dim oColLabel3, oColName3, oColTypename3 as String
Dim oColPrecision1, oColType1 as Integer
Dim oColPrecision2, oColType2 as Integer
Dim oColPrecision3, oColType3 as Integer
'
oRSCol = oRS.getColumns()
'
oHasElmt = oRSCol.hasElements()
oColNum = oRSCol.getCount()
oDisp = "Table Name => " & oTbName & Chr$(10) & "Data( Column )の有(true)無(false) =>" & oHasElmt & Chr$(10) & _
"Column 数 => " & oColNum & Chr$(10) & Chr$(10)
'
'
oColIndex = oRSCol.getByIndex(0)
'
oColDisPlaySize1 = oColIndex.DisplaySize ' Firebird では 32 ← 下記Note参照
oColLabel1 = oColIndex.Label
oColName1 = oColIndex.Name
oColPrecision1 = oColIndex.Precision
oColType1 = oColIndex.Type
oColTypename1 = oColIndex.TypeName
oDisp = oDisp & "「 oRSCol.getByIndex(0) 」にてColumn Object取得" & Chr$(10) & _
"表示されるCloumn幅(文字数) => " & oColDisPlaySize1 & Chr$(10) & _
"表示されるColumn Name => " & oColLabel1 & Chr$(10) & _
"Columnの認識名 => " & oColName1 & Chr$(10) & _
"ColumnのPrecision => " & oColPrecision1 & Chr$(10) & _
"ColumnのType => " & oColType1 & Chr$(10) & _
"ColumnのTypeName => " & oColTypename1 & Chr$(10) & Chr$(10)
'
oColName = oRSCol.getByName(oCol2)
'
oColDisPlaySize2 = oColName.DisplaySize ' Firebird では 32 ← 下記Note参照
oColLabel2 = oColName.Label
oColName2 = oColName.Name
oColPrecision2 = oColName.Precision
oColType2 = oColName.Type
oColTypename2 = oColName.TypeName
oDisp = oDisp & "「 oRSCol.getByName([String]) 」にてColumn Object取得" & Chr$(10) & _
"表示されるCloumn幅(文字数) => " & oColDisPlaySize2 & Chr$(10) & _
"表示されるColumn Name => " & oColLabel2 & Chr$(10) & _
"Columnの認識名 => " & oColName2 & Chr$(10) & _
"ColumnのPrecision => " & oColPrecision2 & Chr$(10) & _
"ColumnのType => " & oColType2 & Chr$(10) & _
"ColumnのTypeName => " & oColTypename2 & Chr$(10) & Chr$(10)
'
Dim oIndexNo as Integer
oIndexNo = Int( oRSCol.findColumn(oCol3)) ' Firebirdの時は 3, HSQLDBの時は 2
'
oColFind = oRSCol.getByIndex(oIndexNo-1) ' Firebird の場合は-1が必要。
'
oColDisPlaySize3 = oColFind.DisplaySize ' Firebird では 32 ← 下記Note参照
oColLabel3 = oColFind.Label
oColName3 = oColFind.Name
oColPrecision3 = oColFind.Precision ' Firebird では 0
oColType3 = oColFind.Type
oColTypename3 = oColFind.TypeName 'Firebird と HSQLDB との違いに注意
oDisp = oDisp & "「 oRSCol.getByIndex(Int( oRSCol.findColumn([String]))) 」にてColumn Object取得" & Chr$(10) & _
"表示されるCloumn幅(文字数) => " & oColDisPlaySize3 & Chr$(10) & _
"表示されるColumn Name => " & oColLabel3 & Chr$(10) & _
"Columnの認識名 => " & oColName3 & Chr$(10) & _
"ColumnのPrecision => " & oColPrecision3 & Chr$(10) & _
"ColumnのType => " & oColType3 & Chr$(10) & _
"ColumnのTypeName => " & oColTypename3
'
' ResultSet Close
oRS.close
Set oRS = Nothing
'
msgbox(oDisp,0,"Result SetからのColumn情報")
'
' Unconnect with the Datasource
oCon.close()
oCon.dispose
msgbox "Success",0,"LO 6.2.4.2 (x64)"
End Sub
'
'[Note]
' FIrebirdの VARCHAR(n) 型は「キャラクタセットによらず32K以内必須」なので、32しか返ってこない模様
' 参考URL : FIREBIRD WIKI / データ型
BTRt-)Result SetからのColumn情報取得2[For HSQLDB]
Sub oSQLResultset
On Error Goto oBad
'Create New Base Document
Dim oDoc as Object
Dim Dummy()
Dim oAns as Long
oDoc = StarDesktop.loadComponentFromURL("private:factory/sdatabase", "_blank", 0, Dummy())
oDataSource = oDoc.DataSource
'
' set to use hsqldb
oDataSource.URL = "sdbc:embedded:hsqldb"
oTempName = ConvertToUrl("c:\temp\oBaseMacroTest.odb")
if FileExists(oTempName) then
oAns = msgbox("同名fileがあります。削除しますか?", 4, "既存fileの削除確認")
if oAns = 6 then
Kill(oTempName)
Else
MsgBox("中断します。")
Exit Sub
End if
end if
oDoc.StoreAsURL(oTempName,Dummy())
'
' Load the Tools library
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
'
' Connect DB
Dim oBaseContent as Object
Dim oDB as Object
Dim oCon as Object
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDB = oBaseContext.getByName(oTempName)
oCon = oDB.getConnection("", "")
' CREATE TABLE句
Dim oStmt as Object
Dim oSQL as String
Dim oTableName as String
oTableName = "ADRESS" ' 大文字
oStmt = oCon.createStatement()
oSQL = "CREATE TABLE " & oTableName & "(ID INTEGER IDENTITY,ADRESS varchar(5),TITLE varchar(10),NAME varchar(30), PRIMARY KEY (ID)) "
oStmt.execute(oSQL)
'
' INSERT INTO句
Dim oSQL2 as String
Dim oValue as String
Dim i as Integer
for i = 1 to 100
oValue = "VALUES(" & i & ",'home', 'Test" & i & "', 'New_OOo3')"
oSQL2 = "INSERT INTO " & oTableName & "(ID, ADRESS, TITLE, NAME)" & " " & oValue
oStmt.executeUpdate(oSQL2)
Next i
'
' Result Set
Dim oSQL3 as String
Dim oRS as Object
oSQL3 = "SELECT * FROM " & oTableName
oRS = oStmt.executeQuery(oSQL3)
'
' Result Setから、TableのColumn情報を取得
Dim oRSCol as Object
Dim oColEnum as Object
Dim oCol as Object
'
Dim oHasElmt as boolean
Dim oColNum as Integer
Dim oColIndex, oColName as Object
Dim oColFind as Object
Dim oColDisPlaySize1, oColDisPlaySize2, oColDisPlaySize3 as Integer
Dim oColLabel1, oColName1, oColTypename1 as String
Dim oColLabel2, oColName2, oColTypename2 as String
Dim oColLabel3, oColName3, oColTypename3 as String
Dim oColPrecision1, oColType1 as Integer
Dim oColPrecision2, oColType2 as Integer
Dim oColPrecision3, oColType3 as Integer
'
oRSCol = oRS.getColumns()
oColEnum = oRSCol.createEnumeration()
oDisp = ""
nn = 1
Do While oColEnum.hasMoreElements() and nn < 1000
oCol = oColEnum.nextElement
oDisp = oDisp & "Col No." & nn & " => " & oCol.Name & Chr$(9) & oCol.DisplaySize & Chr$(10)
nn = nn+1
Loop
'
' ResultSet Close
oRS.close
Set oRS = Nothing
'
msgbox(oDisp,0,"Result SetからのColumn情報")
'
'
oCon.Close()
oCon.dispose
'
' Display
msgbox "Success"
Exit Sub
oBad:
oCon.Close()
oCon.dispose
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
BTRt-)Result SetからのColumn情報取得2[For Firebird]
Sub BaseFirbird()
Dim oDoc as Object, oBaseContext as Object
Dim oUser$
Dim oPass$
Dim oTempName as String
oDoc = ThisComponent
oTempName = oDoc.getURL
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource as Object
Dim oCon as Object
oDataSource = oBaseContext.getByName(oTempName)
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt as Object
Dim oSQL as String, oTbName as String
Dim oCol1 as String, oCol2 as String, oCol3 as String
oTbName = "ADDRESS"
oCol1="ID"
oCol2="NAME"
oCol3="TITLE"
oStmt = oCon.createStatement()
'
oSQL = "CREATE TABLE " & oTbName & "(" & oCol1 & " " & "INT NOT NULL PRIMARY KEY, " & oCol2 & " " & "VARCHAR(20) NOT NULL UNIQUE, " & _
oCol3 & " " & "VARCHAR(40) NOT NULL UNIQUE); "
oStmt.execute(oSQL)
' ********** [ 表示 → Tableの更新 ] **********
Dim dispatcher as Object
Dim oFrame as Object
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
oFrame = oDoc.getCurrentController().getFrame()
dispatcher.executeDispatch(oFrame,".uno:DBRefreshTables", "", 0, Array())
' ****************************************
'
' Result Set
Dim oSQL3 as String
Dim oRS as Object
oSQL3 = "SELECT * FROM " & oTbName
oRS = oStmt.executeQuery(oSQL3)
'
' Result Setから、TableのColumn情報を取得
Dim oRSCol as Object
Dim oHasElmt as boolean
Dim oColNum as Integer
Dim oColIndex, oColName as Object
Dim oColFind as Object
Dim oColDisPlaySize1, oColDisPlaySize2, oColDisPlaySize3 as Integer
Dim oColLabel1, oColName1, oColTypename1 as String
Dim oColLabel2, oColName2, oColTypename2 as String
Dim oColLabel3, oColName3, oColTypename3 as String
Dim oColPrecision1, oColType1 as Integer
Dim oColPrecision2, oColType2 as Integer
Dim oColPrecision3, oColType3 as Integer
'
oRSCol = oRS.getColumns()
'
oColEnum = oRSCol.createEnumeration()
oDisp = "[Firebird(LO 6.2.4.2 (x64))]" & Chr$(10)
nn = 1
Do While oColEnum.hasMoreElements() and nn < 1000
oCol = oColEnum.nextElement
oDisp = oDisp & "Col No." & nn & " => " & oCol.Name & Chr$(9) & oCol.DisplaySize & Chr$(10)
nn = nn+1
Loop
' '
' ResultSet Close
oRS.close
Set oRS = Nothing
'
msgbox(oDisp,0,"Result SetからのColumn情報")
'
' Unconnect with the Datasource
oCon.close()
oCon.dispose
msgbox "Success",0,"LO 6.2.4.2 (x64)"
End Sub
BTRt-)MetaDataとしてColumn情報を出力[For HSQLDB]
Sub oSQLResultset
On Error Goto oBad
'Create New Base Document
Dim oDoc as Object
Dim Dummy()
Dim oAns as Long
oDoc = StarDesktop.loadComponentFromURL("private:factory/sdatabase", "_blank", 0, Dummy())
oDataSource = oDoc.DataSource
'
' set to use hsqldb
oDataSource.URL = "sdbc:embedded:hsqldb"
oTempName = ConvertToUrl("c:\temp\oBaseMacroTest.odb")
if FileExists(oTempName) then
oAns = msgbox("同名fileがあります。削除しますか?", 4, "既存fileの削除確認")
if oAns = 6 then
Kill(oTempName)
Else
MsgBox("中断します。")
Exit Sub
End if
end if
oDoc.StoreAsURL(oTempName,Dummy())
'
' Load the Tools library
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
'
' Connect DB
Dim oBaseContent as Object
Dim oDB as Object
Dim oCon as Object
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDB = oBaseContext.getByName(oTempName)
oCon = oDB.getConnection("", "")
' CREATE TABLE句
Dim oStmt as Object
Dim oSQL as String
Dim oTableName as String
oTableName = "ADRESS" ' 大文字
oStmt = oCon.createStatement()
oSQL = "CREATE TABLE " & oTableName & "(ID INTEGER IDENTITY,ADRESS varchar(5),TITLE varchar(10),NAME varchar(30), PRIMARY KEY (ID)) "
oStmt.execute(oSQL)
'
' INSERT INTO句
Dim oSQL2 as String
Dim oValue as String
Dim i as Integer
for i = 1 to 100
oValue = "VALUES(" & i & ",'home', 'Test" & i & "', 'New_OOo3')"
oSQL2 = "INSERT INTO " & oTableName & "(ID, ADRESS, TITLE, NAME)" & " " & oValue
oStmt.executeUpdate(oSQL2)
Next i
'
' Result Set
Dim oSQL3 as String
Dim oRS as Object
oSQL3 = "SELECT * FROM " & oTableName
oRS = oStmt.executeQuery(oSQL3)
'
' Result Setから、TableのColumn情報をMetaDataとして出力
Dim oTxtPath,oTxtFileName as String
oTxtPath = "c:\temp\"
oTxtFileName = "oResultSetMetaData.txt"
'
Dim oMetaData as Object
Dim oColNum as Long
Dim oOutputTitle() as String
Dim oOutPutData as String
oMetaData = oRS.MetaData
oColNum = oMetaData.getColumnCount()
'
oOutPutData = "----- [ ResultSet MetaData ] ----" & Chr$(10) & Chr$(10)
oOutPutData = oOutPutData & "Column 数 = " & oColNum & Chr$(10) & Chr$(10)
'
' Title行の出力
'oOutputTitle = Array("No","Name","Lable","DisplaySize","Type","TypeName","Precision","Scale","TableName","SchemaNaeme","自動増分","CaseSensitive","Currenty","Null値可能")
oOutputTitle = Array("No","Name","Lable","表示列幅")
for i = 0 to UBound(oOutputTitle)
oOutPutData = oOutPutData & oOutPutTitle(i) & Chr$(9)
next i
'
' 一旦、Data出力
oOutPutTxtFile(oTxtPath, oTxtFileName,oOutPutData)
'
' Column 情報の出力
for i = 1 to oColNum
oOutPutData = i & Chr$(9)
oOutPutData = oOutPutData & oMetaData.getColumnName(i) & Chr$(9)
oOutPutData = oOutPutData & oMetaData.getColumnLabel(i) & Chr$(9)
oOutPutData = oOutPutData & oMetaData.getColumnDisplaySize(i) & Chr$(9)
oOutPutTxtFile(oTxtPath, oTxtFileName,oOutPutData)
Next i
'
' RessultSet Close
oRS.close
Set oRS = Nothing
'
' DisConnect
oCon.Close()
oCon.dispose
'
' Display
msgbox "Success"
Exit Sub
oBad:
oCon.Close()
oCon.dispose
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
'
Sub oOutPutTxtFile(oPath, oFileName, oPntData)
Dim oFileNumber as Integer
Dim oTxtFile as String
oFileNumber = FreeFile()
oTxtFile = oPath & oFileName
Open oTxtFile for Append as oFileNumber
print #oFileNumber, oPntData ' Data Into File
Close #oFileNumber
End Sub
BTRt-)MetaDataとしてColumn情報を出力[For Firebird]
Sub BaseFirbird()
Dim oDoc as Object, oBaseContext as Object
Dim oUser$
Dim oPass$
Dim oTempName as String
oDoc = ThisComponent
oTempName = oDoc.getURL
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource as Object
Dim oCon as Object
oDataSource = oBaseContext.getByName(oTempName)
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt as Object
Dim oSQL as String, oTbName as String
oTbName = "ADDRESS"
oStmt = oCon.createStatement()
'
oSQL = "RECREATE TABLE " & oTbName & "(ID INT NOT NULL PRIMARY KEY, NAME VARCHAR(20) NOT NULL UNIQUE, VERSION VARCHAR(20)); "
oStmt.execute(oSQL)
'
' Insert Into Clause
Dim oSQL2 as String
Dim oValue as String
Dim i as Integer
oStmt = oCon.createStatement() ' Firebird ではTable作成後、再度、oStmｔの作成が必要
for i = 1 to 10
oValue = "VALUES (" & i & " , 'Firebird_" & i & "', 'LO6.2.4.2');"
oSQL2 = "INSERT INTO " & oTbName & " " & oValue
oStmt.executeUpdate(oSQL2)
Next i
' ********** [ 表示 → Tableの更新 ] **********
Dim dispatcher as Object
Dim oFrame as Object
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
oFrame = oDoc.getCurrentController().getFrame()
dispatcher.executeDispatch(oFrame,".uno:DBRefreshTables", "", 0, Array())
' ****************************************
'
'' Result Set
Dim oSQL3 as String
Dim oRS as Object
oSQL3 = "SELECT * FROM " & oTbName
oRS = oStmt.executeQuery(oSQL3)
'
' Result Setから、TableのColumn情報をMetaDataとして出力
Dim oTxtPath,oTxtFileName as String
oTxtPath = "c:\temp\"
oTxtFileName = "oResultSetMetaData.txt"
'
Dim oMetaData as Object
Dim oColNum as Long
Dim oOutputTitle() as String
Dim oOutPutData as String
oMetaData = oRS.MetaData
oColNum = oMetaData.getColumnCount()
'
oOutPutData = "----- [ ResultSet MetaData ] ----" & Chr$(10) & Chr$(10)
oOutPutData = oOutPutData & "Column 数 = " & oColNum & Chr$(10) & Chr$(10)
'
' Title行の出力
'oOutputTitle = Array("No","Name","Lable","DisplaySize","Type","TypeName","Precision","Scale","TableName","SchemaNaeme","自動増分","CaseSensitive","Currenty","Null値可能")
oOutputTitle = Array("No","Name","Lable","表示列幅")
for i = 0 to UBound(oOutputTitle)
oOutPutData = oOutPutData & oOutPutTitle(i) & Chr$(9)
next i
'
' 一旦、Data出力
oOutPutTxtFile(oTxtPath, oTxtFileName,oOutPutData)
'
' Column 情報の出力
for i = 1 to oColNum
oOutPutData = i & Chr$(9)
oOutPutData = oOutPutData & oMetaData.getColumnName(i) & Chr$(9)
oOutPutData = oOutPutData & oMetaData.getColumnLabel(i) & Chr$(9)
oOutPutData = oOutPutData & oMetaData.getColumnDisplaySize(i) & Chr$(9)
oOutPutTxtFile(oTxtPath, oTxtFileName,oOutPutData)
Next i
' '
' ResultSet Close
oRS.close
Set oRS = Nothing
'
'
' Unconnect with the Datasource
oCon.close()
oCon.dispose
msgbox "Success",0,"LO 6.2.4.2 (x64)"
End Sub
'
Sub oOutPutTxtFile(oPath, oFileName, oPntData)
Dim oFileNumber as Integer
Dim oTxtFile as String
oFileNumber = FreeFile()
oTxtFile = oPath & oFileName
Open oTxtFile for Append as oFileNumber
print #oFileNumber, oPntData ' Data Into File
Close #oFileNumber
End Sub
BTRt-)MetaDataとしてColumn情報を取得[For HSQLDB]
Sub oSQLResultset
On Error Goto oBad
'Create New Base Document
Dim oDoc as Object
Dim Dummy()
Dim oAns as Long
oDoc = StarDesktop.loadComponentFromURL("private:factory/sdatabase", "_blank", 0, Dummy())
oDataSource = oDoc.DataSource
'
' set to use hsqldb
oDataSource.URL = "sdbc:embedded:hsqldb"
oTempName = ConvertToUrl("c:\temp\oBaseMacroTest.odb")
if FileExists(oTempName) then
oAns = msgbox("同名fileがあります。削除しますか?", 4, "既存fileの削除確認")
if oAns = 6 then
Kill(oTempName)
Else
MsgBox("中断します。")
Exit Sub
End if
end if
oDoc.StoreAsURL(oTempName,Dummy())
'
' Load the Tools library
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
'
' Connect DB
Dim oBaseContent as Object
Dim oDB as Object
Dim oCon as Object
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDB = oBaseContext.getByName(oTempName)
oCon = oDB.getConnection("", "")
' CREATE TABLE句
Dim oStmt as Object
Dim oSQL as String
Dim oTableName as String
oTableName = "ADRESS" ' 大文字
oStmt = oCon.createStatement()
oSQL = "CREATE TABLE " & oTableName & "(ID INTEGER IDENTITY,ADRESS varchar(5),TITLE varchar(10),NAME varchar(30), PRIMARY KEY (ID)) "
oStmt.execute(oSQL)
'
' INSERT INTO句
Dim oSQL2 as String
Dim oValue as String
Dim i as Integer
for i = 1 to 100
oValue = "VALUES(" & i & ",'home', 'Test" & i & "', 'New_OOo3')"
oSQL2 = "INSERT INTO " & oTableName & "(ID, ADRESS, TITLE, NAME)" & " " & oValue
oStmt.executeUpdate(oSQL2)
Next i
'
' Result Set
Dim oSQL3 as String
Dim oRS as Object
oSQL3 = "SELECT * FROM " & oTableName
oRS = oStmt.executeQuery(oSQL3)
'
' Result Setから、TableのColumn情報をMetaDataとして出力
'
Dim oMetaData as Object
Dim oColNum as Long
Dim oOutputTitle() as String
Dim oOutPutData as String
oMetaData = oRS.MetaData
oColNum = oMetaData.getColumnCount()
'
' Title Column情報の取得
Dim oColName, oColLabel as String
Dim oColDisplaySize as Integer
Dim oColType
Dim oColTypeName as String
Dim oColPrecision as Long
Dim oColScale as Long
Dim oColSchemaName, oColTableName as String
Dim oColIsAutoIncr, oColIsCaseSensitive, oColIsCurrency, oColIsNullable as Boolean
'
' Column 情報の取得
oDisp = ""
for i = 1 to oColNum
oDisp = oDisp & "[ 列No => " & i & " ]" & Chr$(10)
oDisp = oDisp & Chr$(9) & "列Name => " & oMetaData.getColumnName(i) & Chr$(10)
oDisp = oDisp & Chr$(9) & "列Label => " & oMetaData.getColumnLabel(i) & Chr$(10)
oDisp = oDisp & Chr$(9) & "列表示幅 => " & oMetaData.getColumnDisplaySize(i) & Chr$(10)
oDisp = oDisp & Chr$(9) & "列Type => " & oMetaData.getColumnType(i) & Chr$(10)
oDisp = oDisp & Chr$(9) & "列TypeName => " & oMetaData.getColumnTypename(i) & Chr$(10)
oDisp = oDisp & Chr$(9) & "列のPrecision => " & oMetaData.getPrecision(i) & Chr$(10)
oDisp = oDisp & Chr$(9) & "列のScale => " & oMetaData.getScale(i) & Chr$(10)
oDisp = oDisp & Chr$(9) & "Schame Name => " & oMetaData.getSchemaName(i) & Chr$(10)
oDisp = oDisp & Chr$(9) & "Table Name => " & oMetaData.getTableName(i) & Chr$(10)
oDisp = oDisp & Chr$(9) & "自動増分設定 => " & oMetaData.isAutoIncrement(i) & Chr$(10)
oDisp = oDisp & Chr$(9) & "CaseSensitive => " & oMetaData.isCaseSensitive(i) & Chr$(10)
oDisp = oDisp & Chr$(9) & "Currency => " & oMetaData.isCurrency(i) & Chr$(10)
oDisp = oDisp & Chr$(9) & "Null値可否 => " & oMetaData.isNullable(i) & Chr$(10)
Next i
'
' ResultSet Close
oRS.close
Set oRS = Nothing
'
' Display
msgbox oDisp,0,"Resultset Service MetaData"
'
oCon.Close()
oCon.dispose
'
' Display
msgbox "Success"
Exit Sub
oBad:
oCon.Close()
oCon.dispose
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
BTRt-)MetaDataとしてColumn情報を取得[For Firebird]
Sub BaseFirbird()
Dim oDoc as Object, oBaseContext as Object
Dim oUser$
Dim oPass$
Dim oTempName as String
oDoc = ThisComponent
oTempName = oDoc.getURL
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource as Object
Dim oCon as Object
oDataSource = oBaseContext.getByName(oTempName)
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt as Object
Dim oSQL as String, oTbName as String
oTbName = "ADDRESS"
oStmt = oCon.createStatement()
'
oSQL = "RECREATE TABLE " & oTbName & "(ID INT NOT NULL PRIMARY KEY, NAME VARCHAR(20) NOT NULL UNIQUE, VERSION VARCHAR(20)); "
oStmt.execute(oSQL)
'
' Insert Into Clause
Dim oSQL2 as String
Dim oValue as String
Dim i as Integer
oStmt = oCon.createStatement() ' Firebird ではTable作成後、再度、oStmｔの作成が必要
for i = 1 to 10
oValue = "VALUES (" & i & " , 'Firebird_" & i & "', 'LO6.2.4.2');"
oSQL2 = "INSERT INTO " & oTbName & " " & oValue
oStmt.executeUpdate(oSQL2)
Next i
' ********** [ 表示 → Tableの更新 ] **********
Dim dispatcher as Object
Dim oFrame as Object
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
oFrame = oDoc.getCurrentController().getFrame()
dispatcher.executeDispatch(oFrame,".uno:DBRefreshTables", "", 0, Array())
' ****************************************
'
'' Result Set
Dim oSQL3 as String
Dim oRS as Object
oSQL3 = "SELECT * FROM " & oTbName
oRS = oStmt.executeQuery(oSQL3)
'
' Result Setから、TableのColumn情報をMetaDataとして出力
'
Dim oMetaData as Object
Dim oColNum as Long
Dim oOutputTitle() as String
Dim oOutPutData as String
oMetaData = oRS.MetaData
oColNum = oMetaData.getColumnCount()
'
' Title Column情報の取得
Dim oColName, oColLabel as String
Dim oColDisplaySize as Integer
Dim oColType
Dim oColTypeName as String
Dim oColPrecision as Long
Dim oColScale as Long
Dim oColSchemaName, oColTableName as String
Dim oColIsAutoIncr, oColIsCaseSensitive, oColIsCurrency, oColIsNullable as Boolean
'
' Column 情報の取得
oDisp = ""
for i = 1 to oColNum
oDisp = oDisp & "[ 列No => " & i & " ]" & Chr$(10)
oDisp = oDisp & Chr$(9) & "列Name => " & oMetaData.getColumnName(i) & Chr$(10)
oDisp = oDisp & Chr$(9) & "列Label => " & oMetaData.getColumnLabel(i) & Chr$(10)
oDisp = oDisp & Chr$(9) & "列表示幅 => " & oMetaData.getColumnDisplaySize(i) & Chr$(10)
oDisp = oDisp & Chr$(9) & "列Type => " & oMetaData.getColumnType(i) & Chr$(10)
oDisp = oDisp & Chr$(9) & "列TypeName => " & oMetaData.getColumnTypename(i) & Chr$(10)
oDisp = oDisp & Chr$(9) & "列のPrecision => " & oMetaData.getPrecision(i) & Chr$(10)
oDisp = oDisp & Chr$(9) & "列のScale => " & oMetaData.getScale(i) & Chr$(10)
oDisp = oDisp & Chr$(9) & "Schame Name => " & oMetaData.getSchemaName(i) & Chr$(10)
oDisp = oDisp & Chr$(9) & "Table Name => " & oMetaData.getTableName(i) & Chr$(10)
oDisp = oDisp & Chr$(9) & "自動増分設定 => " & oMetaData.isAutoIncrement(i) & Chr$(10)
oDisp = oDisp & Chr$(9) & "CaseSensitive => " & oMetaData.isCaseSensitive(i) & Chr$(10)
oDisp = oDisp & Chr$(9) & "Currency => " & oMetaData.isCurrency(i) & Chr$(10)
oDisp = oDisp & Chr$(9) & "Null値可否 => " & oMetaData.isNullable(i) & Chr$(10)
Next i
'
' ResultSet Close
oRS.close
Set oRS = Nothing
'
' Display
msgbox oDisp,0,"Resultset Service MetaData"
'
oCon.Close()
oCon.dispose
msgbox "Success",0,"LO 6.2.4.2 (x64)"
End Sub
[ RowSet Service ]
BTRw-)[Base]RowSet Serviceを用いたParent Name取得[ HSQLDB, Firebird ]
Sub oRowsetService
Dim oDoc as Object
Dim oDBSource as String
oDoc = ThisComponent
oDBSource = oDoc.getURL
'
' ********* [ Rowset利用 ] ***********
' RowSet Service
Dim oRowSet as Object
Dim oTableName as String
oRowSet = createUnoService("com.sun.star.sdb.RowSet")
'
oTableName = "CITY_LIST"
With oRowSet
.DataSourceName = oDBSource
.CommandType = com.sun.star.sdb.CommandType.COMMAND
.Command = "SELECT * FROM " & oTableName
.execute()
End With
'
Dim oParentURL as String
Dim oParentName as String
oParentURL = oRowSet.ActiveConnection.Parent.Name
oParentName = ConvertFromUrl(oParentURL)
'
' Close Rowset
oRowSet.close
set oRowSet = Nothing
'
' ********* [ Rowset利用 ] ***********
'
msgbox oParentName,0,"現在ConnectしているParent Name"
End Sub
'
'
' 上記をRowSetを使用方法しない場合は下記と同様である。
'
' ********* [ Rowset利用しない場合 ] ***********
' Dim oBaseContext as Object 'Global database context.
' oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
'
' Dim oDBName as Object
' Dim oCon as Object
' Dim oParentURL as String
' Dim oParentName as String
'
' oDBName = oBaseContext.getByName(oDBSource(0))
' oCon = oDBName.getConnection("","")
'
' oParentURL = oCon.Parent.Name
' oParentName = ConvertFromUrl(oParentURL)
'
' oCon.Close()
'
' ********* [ Rowset利用しない場合 ] ***********
'
BTRw-)[Base]Current Row No取得[ HSQLDB, Firebird ]
Sub oRowsetNumRow
Dim db As Object
Dim oBase as String
oBase ="Test"
db = connect_to_database(oBase)
table_row(db)
disconnect_from_database(db)
End Sub
'[ Sub Routine1 ]
Sub disconnect_from_database ( db as Object)
db.close
db.dispose()
End Sub
'[ Sub Routine2 ]
Sub table_row(db as Object)
Dim dbTables As Object
Dim dbTableNames As Object
Dim oRowSet As Object
Dim dbTableRow as Long
dbTables=db.getTables
dbTableNames=dbTables.getElementNames
oName_table=join(dbTableNames , chr(10))
oSql = "SELECT * FROM""CITY_LIST"""
oRowSet = createUnoService("com.sun.star.sdb.RowSet")
With oRowSet
.activeConnection = db
.Command = oSql
.execute
End With
dbTableRow=oRowSet.RowCount
'
oRowSet.close
set oRowSet = Nothing
'
msgbox ("接続しているBase Table情報" & chr(10) & "Table名 ： " & oName_table & Chr(10) & "Data数(行数) ： " & dbTableRow,0,"Rowset Service")
End Sub
'[ Function1 ]
Function connect_to_database(dbName as String) as Object
Dim dbContext As Object
Dim oDataSource As Object
dbContext =createUnoService("com.sun.star.sdb.DatabaseContext")
oDataSource= dbContext.getByName(dbName)
connect_to_database=oDataSource.GetConnection("","")
End Function
BTRw-)[Base]Tableの行No.の取得[ HSQLDB, Firebird ]( RowSet )( 最終行 =＞ 1つ前の行 =＞ 最初の行 =＞ 1つ次の行 )
Sub RowSetService()
Dim oBaseContext as Object
Dim oDBSrcName as String
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
If NOT oBaseContext.hasElements() Then
MsgBox( "登録されているDataSourceはありません")
Exit Sub
End If
'
oDBSrcName = "oBaseMacroTest"
'
Dim oDBSource() as String
Dim oFlag as Integer
oFlag = 0
oDBSource = oBaseContext.getElementNames()
'
for i = 0 to UBound(oDBSource)
if oDBSource(i) = oDBSrcName then
oFlag = 777
Exit for
end if
next i
'
if oFlag = 0 then
oDisp = "DataSource : " & oDBSrcName & " は登録されていません。"
msgbox(oDisp,0,"登録されていません。")
Exit Sub
end if
'
' ********* [ Rowset利用 ] ***********
' RowSet Service
Dim oRowSet as Object
Dim oTableName as String
Dim oRecordMax1, oRecordMax2 as Long
Dim oRecordNum1, oRecordNum2 as Long
Dim oLastRowNo, oFirstRowNo, oPreviousRow, oNextRow as Long
'
oRowSet = createUnoService("com.sun.star.sdb.RowSet")
'
oTableName = "ADDRESS"
With oRowSet
.DataSourceName = oDBSrcName
.CommandType = com.sun.star.sdb.CommandType.COMMAND
.Command = "SELECT * FROM " & oTableName
.execute()
End With
'
oDisp = "Table Name = " & oTableName & Chr$(10) & Chr$(10)
'
' 現在取得しているRecord数取得
oRecordMax1 = oRowSet.MaxRows
oRecordNum1 = oRowSet.RowCount
' Last Row へ移動及びRecoed No取得
oRowSet.last()
oLastRowNo = oRowSet.Row
' 1行前のRow へ移動及びRecoed No取得
oRowSet.previous()
oPreviousRow = oRowSet.Row
' First Row へ移動及びRecoed No取得
oRowSet.first()
oFirstRowNo = oRowSet.Row
' 次のRow へ移動及びRecoed No取得
oRowSet.next()
oNextRow = oRowSet.Row
' 現在取得しているRecord数取得
oRecordMax2 = oRowSet.MaxRows
oRecordNum2 = oRowSet.RowCount
'
' Close Rowset
oRowSet.close
set oRowSet = Nothing
' Display
oDisp = oDisp & "最初のMaxRows = " & oRecordMax1 & Chr$(10) & _
"最初のRowCount = " & oRecordNum1 & Chr$(10) & _
"Last Row No = " & oLastRowNo & Chr$(10) & _
"1行前のRow No = " & oPreviousRow & Chr$(10) & _
"First Row No = " & oFirstRowNo & Chr$(10) & _
"次のRow No = " & oNextRow & Chr$(10) & _
"現在のMaxRows = " & oRecordMax2 & Chr$(10) & _
"現在のRowCount = " & oRecordNum2
msgbox(oDisp,0,"Tableの行No")
End Sub
BTRw-)[Base]RowSet で Row追加
Sub oRowSetService
On Error Goto oBad
' ******** [ Rowset で Row追加 ] **********
Dim oRSCity as Object
Dim oAddCity() as String
Dim i as Integer
oRSCity = createUnoService("com.sun.star.sdb.RowSet")
' DataSourceと接続
With oRSCity
.DataSourceName = "Test"
.CommandType = com.sun.star.sdb.CommandType.TABLE
.Command = "CITY_LIST" ' No.1 col : ID( 自動入力 ) / No.2 Col : CITY_NAME の2つのColumnを持つTable で Primary Key 設定が必須
.IgnoreResult = true ' Not interested in result
.execute()
End With
'
' 値追加
oAddCity = Array("Tokyo","New York","Paris","London","Rome","Pflugerville")
'
for i = 0 to UBound(oAddCity)
With oRSCity
.moveToInsertRow()
.UpdateString(2, oAddCity(i))
.insertRow()
End With
next i
'
' Rowset の Close
oRSCity.close
set oRSCity = Nothing
' Display
msgbox "Success"
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
BTRw-)[Base]RowSet で Row削除
Sub oRowSetService
On Error Goto oBad
' ******** [ Rowset で条件に一致するRowを削除 ] **********
Dim oRSCity as Object
Dim oAddCity() as String
Dim i as Integer
oRSCity = createUnoService("com.sun.star.sdb.RowSet")
' DataSourceと接続
With oRSCity
.DataSourceName = "Test"
.CommandType = com.sun.star.sdb.CommandType.TABLE
.Command = "CITY_LIST" ' No.1 col : ID( 自動入力 ) / No.2 Col : CITY_NAME の2つのColumnを持つTable で Primary Key 設定が必須
.IgnoreResult = false ' true にすると oRSCity.next() が常にfalseになり、Do Loopが使えない
.execute()
End With
'
Dim oCityName as Object
Dim oLmtLoop as Long
Dim nn as Long
oLmtLoop = 10
nn = 0
' First Row へ移動及びRecoed No取得
oRSCity.first()
'
Do While oRSCity.next() and nn < oLmtLoop
oCityName = oRSCity.Columns.getByName("CITY_NAME")
if oCityName.String = "Paris" or oCityName.Int = 5 then
oRSCity.deleteRow()
End If
'
nn = nn + 1
if nn > oLmtLoop then
Exit Do
end if
Loop
'
' Rowset の Close
oRSCity.close
set oRSCity = Nothing
' Display
msgbox "Success"
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
BTRw-)[Base]様々なTypeのDataをTableに設定
Sub oTableCreate
On Error Goto oBad
'Create New Base Document
Dim oDoc as Object
Dim oTempName as String
Dim oFlag as Integer
oFlag = 0
oDoc = ThisComponent
oTempName = oDoc.getURL
'
' Connect DB
Dim oBaseContent as Object
Dim oDB as Object
Dim oCon as Object
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDB = oBaseContext.getByName(oTempName)
oCon = oDB.getConnection("", "")
oFlag = 777
'
' Create New Table
Dim oTables as Object
Dim oTableName as String
Dim oTableDescriptor as Object
Dim oCols as Object
Dim oCol as Object
'
oTableName = "CreateTb"
' Access Tables in Connecting DB
oTables = oCon.getTables()
'
' 同名Tableが存在するか?
Dim oTNames() as Object
oTNames = oTables.getElementNames()
for i = 0 to UBound(oTNames)
if oTableName = oTNames(i) then
oDisp = "既に [ " & oTableName & " ] と同じ名前のTableがありますので処理を終了します。"
msgbox oDisp,0,"同名Tableが存在します。"
oCon.close()
oCon.dispose
Exit Sub
end if
next i
'
' Define the Table Property
oTableDescriptor = oTables.createDataDescriptor()
oTableDescriptor.Name = oTableName
' Define the Datas to table Columns( 最低一項目は設定が必要 )
oCols = oTableDescriptor.getColumns()
oCol = oCols.createDataDescriptor()
' INTEGER : 整数
oCol.Name = "ID"
oCol.Type = com.sun.star.sdbc.DataType.INTEGER
' oCol.TypeName = "INTEGER" ' Type は TypeName でも設定可能
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
oCol.Precision = 10 ' max 10
oCol.IsAutoIncrement = true
'
oCol.Description = "Primary Key"
'
oCol.FormatKey = com.sun.star.sdbcx.KeyType.UNIQUE
oCols.appendByDescriptor(oCol)
'
' TIMESTAMP : 日付/時刻
oCol.Name = "TimeStamp"
oCol.Type = com.sun.star.sdbc.DataType.TIMESTAMP
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
oCol.IsAutoIncrement = false
oCols.appendByDescriptor(oCol)
'
' Create Table but not to be able to look the table, because it needs to store Base Document.
oTables.appendByDescriptor(oTableDescriptor)
'
' ******** [ Rowset で Row追加 ( ResultSet は Read-Only なので不可 ) ] **********
Dim oRSCity as Object
Dim oRsCol as Object
oRSCity = createUnoService("com.sun.star.sdb.RowSet")
' DataSourceと接続
With oRSCity
.DataSourceName = oTempName
.CommandType = com.sun.star.sdb.CommandType.TABLE
.Command = oTableName
.IgnoreResult = true ' Not interested in result
.execute()
End With
'
' Insert Row へCursorに移動
oRSCity.moveToInsertRow()
'
' 値設定
Dim oVal as Variant
oVal = now() ' = "2012/0702" / ="12:34:51"/ ="test" / =12.345 / = true / Nullの場合は oValをComment文にする
oRsCol = oRSCity.Columns.getByName("TimeStamp")
'
' Column Typeによって値設定
UpDateCol(oRsCol, oVal)
'
' Row 追加
oRSCity.insertRow()
'
' Rowset の Close
oRSCity.close
set oRSCity = Nothing
'
'Base Document Save
oDB.DatabaseDocument.store()
'
oCon.Close()
oCon.dispose
'
' Display
msgbox "Success"
Exit Sub
oBad:
if oFlag = 777 then
oCon.Close()
oCon.dispose
end if
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
'
Function UpDateCol( oRsCol as Object, oVal as Variant)
if NOT IsNull( oVal ) then
Select Case oRsCol.TypeName
Case "INTEGER","TINYINT","SMALLINT""BIGINT"
oRsCol.updateInt( oVal )
Case "LONG" ' HSQLDB では LONG TYPE は無い
oRsCol.updateLong( oVal )
Case "SHORT" ' HSQLDB では SHORT TYPE は無い
oRsCol.updateShort( oVal )
Case "DOUBLE", "REAL", "NUMERIC","DECIMAL"
oRsCol.updateDouble( oVal )
Case "FLOAT"
oRsCol.updateFloat( oVal )
Case "CHAR", "VARCHAR", "LONGVARCHAR"
oRsCol.updateString( oVal )
Case "DATE"
Dim oDate As New com.sun.star.util.Date
oDate.Year = Year( oVal )
oDate.Month = Month( oVal )
oDate.Day = Day( oVal )
oRsCol.updateDate( oDate )
Case "TIME"
Dim oTime As New com.sun.star.util.Time
oTime.Hours = Hour(oVal)
oTime.Minutes = Minute(oVal)
oTime.Seconds = Second(oVal)
oRsCol.updateTime( oTime )
Case "TIMESTAMP"
Dim oDateTime As New com.sun.star.util.DateTime
oDateTime.Year = Year( oVal )
oDateTime.Month = Month( oVal )
oDateTime.Day = Day( oVal )
oDateTime.Hours = Hour(oVal)
oDateTime.Minutes = Minute(oVal)
oDateTime.Seconds = Second(oVal)
oRsCol.updateTimeStamp( oDateTime )
Case "BOOLEAN"
oRsCol.updateBoolean( oVal )
Case Else
oRsCol.updateString( oVal )
End Select
else
oRsCol.updateNull( oVal )
end if
End Function
BTRw-)[Base]RowSetのGroupBy / Order設定
Sub oRowsetService
On Error Goto oBad
Dim oDoc as Object
Dim oTitle as String
Dim oDBSource() as String
oDoc = ThisComponent
oTitle = oDoc.Title
oDBSource = Split(oTitle, "." )
'
' ********* [ Rowset利用 ] ***********
' RowSet Service
Dim oRowSet as Object
Dim oTableName as String
Dim dbTableRow1 as Long
Dim dbTableRow2 as Long
'
oRowSet = createUnoService("com.sun.star.sdb.RowSet")
'
oTableName = "CITY_LIST"
'
' All Row取得
With oRowSet
.DataSourceName = oDBSource(0)
.CommandType = com.sun.star.sdb.CommandType.COMMAND
.Command = "SELECT * FROM " & oTableName
.Order = "ID"
.execute()
End With
'
dbTableRow1 = oRowSet.RowCount
'
' Close Rowset
oRowSet.close
set oRowset = Nothing
'
'
' Using Group Clause
oRowSet = createUnoService("com.sun.star.sdb.RowSet")
'
With oRowSet
.DataSourceName = oDBSource(0)
.CommandType = com.sun.star.sdb.CommandType.COMMAND
.Command = "SELECT CITY_NAME, COUNTRY FROM " & oTableName
.GroupBy = "CITY_NAME, COUNTRY"
' .HavingClause = "Count(CITY_NAME) > 1" ' HavingClause は使えない? LibreOffice3.5.0
.Order = "CITY_NAME"
.execute()
End With
'
dbTableRow2 = oRowSet.RowCount
'
' Close Rowset
oRowSet.close
set oRowset = Nothing
'
' ********* [ Rowset利用 ] ***********
'
Dim oDisp as String
oDisp = "[ Having Clause を用いたGroup化のRow数 ]" & Chr$(10) & _
"Table の Row数 = " & dbTableRow1 & Chr$(10) & _
"Gr化 and Having条件後 の Row数 = " & dbTableRow2
msgbox(oDisp,0,"Group Clayse及びHaving Clause")
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
BTRw-)[Base]
[ PreparedStatement Service ]
BTPS-)[Base]TableにDataを追加(条件：TableItem設定済み)
Sub oAddDataintoTable
'Create New Base Document
Dim oDoc
Dim Dummy()
Dim oAns
Dim oBaseFile
Dim oBaseURL
oBaseFile = "C:\temp\oBase_Table.odb"
oBaseURL = ConvertToUrl(oBaseFile)
oDoc = StarDesktop.loadComponentFromURL(oBaseURL, "_dedault", 0, Dummy())
oDataSource = oDoc.DataSource
'set to use hsqldb
oDataSource.URL = "sdbc:embedded:hsqldb"
oTempName = oDoc.getURL()
'Load the Tools library
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
'Call methods in the Tools library to parse the path.
Dim oFileName
oFileName = FileNameOutOfPath(oTempName, "/")
'Connect DB
Dim oBaseContent
Dim oDB
Dim oCon
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDB = oBaseContext.getByName(oTempName)
oCon = oDB.getConnection("", "")
'Get the Table Name
Dim oTable
Dim oTNames()
Dim oTableName
oTables=oCon.getTables
oTNames=oTables.getElementNames()
oTableName = oTNames(0)
'File Access
Dim oFileAccess
Dim oStream
oFileAccess = createUnoService( "com.sun.star.ucb.SimpleFileAccess")
oStream = oFileAccess.openFileRead(oTempName)
'Get the File Size[ Bytes ]
Dim oData()
Dim oLen
Dim oFileByte
oLen = oStream.getLength()
oFileByte = CStr(oStream.readBytes(oData(), oLen))
'Prepared statement to insert the data by Query
'[ Note ] : It is not neccessary to set the ID Item because it is an auto-value field.
Dim oSQL As String
Dim oStatement
'Set Inserted Items(NAME, DATA) of the Table. and Defaut TableValue of the Items are Empty.
'[ Note ] : To be define ITemName and Format in the Table before Excuting Macro.
oSQL = "insert into" & " " & oTableName & " " & "(NAME, DATA) values (?, ?)"
oStatement = oCon.PrepareStatement(oSQL)
'Add the TableValues
'oStatement.SetString(Column No , Data)
oStatement.SetString( 1, oFileName)
oStatement.SetString( 2, oFileByte)
'Execute the Query
oStatement.ExecuteUpdate()
oStream.closeInput()
'DataBaseとのConnect切断
oCon.close()
'File Close
oDoc.close(true)
msgbox("Success")
End Sub
BTPS-)[Base]PareparedStatementにてDataを追加
Sub PreparateIntoData
On Error Goto oBad
' ***** [ 現在のBase File にTable作成 ] *****
Dim oBaseContext as Object
Dim oUser$
Dim oPass$
Dim oFlag as Integer
oFlag = 0
oUser$ = ""
oPass$ = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
'
' Connect with the DataSource
Dim oDoc as Object
Dim oBaseSrc as String
Dim oDataSource as Object
Dim oCon as Object
oDoc = ThisComponent
oBaseSrc = oDoc.getURL()
oDataSource = oBaseContext.getByName(oBaseSrc)
oCon = oDataSource.getConnection(oUser, oPass)
oFlag = 777
'
Dim oStmt as Object
Dim oSQL as String
Dim oTbName as String
oTbName = "CREATETB" ' 大文字必須
oStmt = oCon.createStatement()
oSQL = "CREATE TABLE " & oTbName & "(ID INTEGER,NAME VARCHAR(30), Y_N BOOLEAN); "
oStmt.execute(oSQL)
'
' ********** [ 表示 → Tableの更新 ] **********
Dim dispatcher as Object
Dim oFrame as Object
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
oFrame = oDoc.getCurrentController().getFrame()
dispatcher.executeDispatch(oFrame,".uno:DBRefreshTables", "", 0, Array())
'
' ****************************************
'
' Prepared statement で Data 入力
Dim oSqlPre As String
Dim oSrmtPre ' Object では無い
Dim i as Integer
Dim tt, oNameStr as Variant
oSqlPre = "INSERT INTO" & " " & oTbName & " " & "(ID, NAME, Y_N) VALUES (?, ?, ?)" ' 全て大文字
oSrmtPre = oCon.PrepareStatement(oSqlPre)
'
for i = 1 to 6
tt = i
oNameStr = "Test" & CStr(i)
oSetValue( oSrmtPre, 1, tt, "Int")
oSetValue( oSrmtPre, 2, oNameStr , "String")
'
if tt mod 2 <> 0 then
oSetValue( oSrmtPre, 3, true, "Boolean")
else
oSetValue( oSrmtPre, 3, false, "Boolean")
End If
'
' Execute the Query
oSrmtPre.ExecuteUpdate()
next i
'
'Unconnect with the Datasource
oCon.close()
oCon.dispose
'
' Display
msgbox "Success"
Exit Sub
oBad:
if oFlag = 777 then
oCon.Close()
oCon.dispose
end if
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
'
Sub oSetValue( oStatement as Object, oColNo as Long, oVal as Variant, oValType as String)
'
' oStatement.SetString(Column No , Data)
Select case oValType
case "Array"
oStatement.setArry(oColNo, oVal)
case "Blob"
oStatement.setBlob(oColNo, oVal)
case "Boolean"
oStatement.setBoolean(oColNo, oVal)
case "Byte"
oStatement.setByte(oColNo, oVal)
case "Bytes"
oStatement.setBytes(oColNo, oVal)
case "Clob"
oStatement.setClob(oColNo, oVal)
case "Data"
oStatement.setData(oColNo, oVal)
case "Double"
oStatement.setDouble(oColNo, oVal)
case "Float"
oStatement.setFloat(oColNo, oVal)
case "Int"
oStatement.setInt(oColNo, oVal)
case "Long"
oStatement.setLong(oColNo, oVal)
case "Null"
oStatement.setNull(oColNo, oVal)
case "Object"
oStatement.setObject(oColNo, oVal)
case "Ref"
oStatement.setRef(oColNo, oVal)
case "Short"
oStatement.setShort(oColNo, oVal)
case "String"
oStatement.setString(oColNo, oVal)
case "Time"
oStatement.setTime(oColNo, oVal)
case "Timestamp"
oStatement.setTimestamp(oColNo, oVal)
case else
oStatement.setString(oColNo, oVal)
End Select
End Sub
[ createDataDescriptor() ]
BT-)[Base]TableにRecordとDataを追加
Sub oTableCreate
On Error Goto oBad
'Create New Base Document
Dim oDoc
Dim Dummy()
Dim oAns
oDoc = StarDesktop.loadComponentFromURL("private:factory/sdatabase", "_blank", 0, Dummy())
oDataSource = oDoc.DataSource
'
' set to use hsqldb
oDataSource.URL = "sdbc:embedded:hsqldb"
oTempName = ConvertToUrl("c:\temp\oBaseMacroTest.odb")
if FileExists(oTempName) then
oAns = msgbox("同名fileがあります。削除しますか?", 4, "既存fileの削除確認")
if oAns = 6 then
Kill(oTempName)
Else
MsgBox("中断します。")
Exit Sub
End if
end if
oDoc.StoreAsURL(oTempName,Dummy())
'
' Load the Tools library
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
'
' Connect DB
Dim oBaseContent
Dim oDB
Dim oCon
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDB = oBaseContext.getByName(oTempName)
oCon = oDB.getConnection("", "")
'
' Create New Table
Dim oTables
Dim oTableName
Dim oTableDescriptor
' Access Tables in Connecting DB
oTables = oCon.getTables()
' Define the Table Property
oTableDescriptor = oTables.createDataDescriptor()
oTableName = "MACROTESTTABLE"
oTableDescriptor.Name = oTableName
' Define the Datas to table Columns( 最低一項目は設定が必要 )
oCols = oTableDescriptor.getColumns()
oCol = oCols.createDataDescriptor()
oCol.Name = "ID"
oCol.Type = com.sun.star.sdbc.DataType.INTEGER
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
oCol.Precision = 10
oCol.IsAutoIncrement = True
oCol.Description = "Primary Key"
oCols.appendByDescriptor(oCol)
'
oCol.Name = "FIRSTNAME"
oCol.Type = com.sun.star.sdbc.DataType.VARCHAR
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
oCol.Precision = 255
oCol.IsAutoIncrement = false
oCols.appendByDescriptor(oCol)
'
' Create Table but not to be able to look the table, because it needs to store Base Document.
oTables.appendByDescriptor(oTableDescriptor)
'
' Base Document Save
oDB.DatabaseDocument.store()
'
'
Dim oStmt
Dim strSQL as String
oStmt = oCon.createStatement()
strSQL = "INSERT INTO MACROTESTTABLE(ID,FIRSTNAME) VALUES(1,'New_OOo3')"
oStmt.executeUpdate(strSQL)
'
oCon.Close()
oCon.dispose
'
' Display
msgbox "Success"
Exit Sub
oBad:
oCon.Close()
oCon.dispose
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
BT-)[Base]Text FileからTableにDataを追加
Sub oTableCreate
On Error Goto oBad
'Create New Base Document
Dim oDoc
Dim Dummy()
Dim oAns
oDoc = StarDesktop.loadComponentFromURL("private:factory/sdatabase", "_blank", 0, Dummy())
oDataSource = oDoc.DataSource
'
' set to use hsqldb
oDataSource.URL = "sdbc:embedded:hsqldb"
oTempName = ConvertToUrl("c:\temp\oBaseMacroTest.odb")
if FileExists(oTempName) then
oAns = msgbox("同名fileがあります。削除しますか?", 4, "既存fileの削除確認")
if oAns = 6 then
Kill(oTempName)
Else
MsgBox("中断します。")
Exit Sub
End if
end if
oDoc.StoreAsURL(oTempName,Dummy())
'
' Load the Tools library
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
'
' Connect DB
Dim oBaseContent
Dim oDB
Dim oCon
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDB = oBaseContext.getByName(oTempName)
oCon = oDB.getConnection("", "")
'
' Create New Table
Dim oTables
Dim oTableName
Dim oTableDescriptor
' Access Tables in Connecting DB
oTables = oCon.getTables()
' Define the Table Property
oTableDescriptor = oTables.createDataDescriptor()
oTableName = "MACROTESTTABLE"
oTableDescriptor.Name = oTableName
' Define the Datas to table Columns( 最低一項目は設定が必要 )
oCols = oTableDescriptor.getColumns()
oCol = oCols.createDataDescriptor()
Dim oNameID(2) as String
Dim oType(2)
Dim oPrecision(2) as Long
Dim oIsAuto(2)
oNameID(0)="ID" : oNameID(1)="FRUITS" : oNameID(2)="NUMBERS"
oType(0) = com.sun.star.sdbc.DataType.INTEGER : oType(1) = com.sun.star.sdbc.DataType.VARCHAR : oType(2) = com.sun.star.sdbc.DataType.INTEGER
oPrecision(0) = 10 : oPrecision(1) = 255 : oPrecision(2) = 50
oIsAuto(0) = True : oIsAuto(1) = false : oIsAuto(2) = false
for i = 0 to 2
oCol.Name = oNameID(i)
oCol.Type = oType(i)
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
oCol.Precision = oPrecision(i)
oCol.IsAutoIncrement = oIsAuto(i)
If i = 0 then
oCol.Description = "Primary Key"
End If
oCols.appendByDescriptor(oCol)
next i
'
' Create Table but not to be able to look the table, because it needs to store Base Document.
oTables.appendByDescriptor(oTableDescriptor)
'
' Base Document Save
oDB.DatabaseDocument.store()
'
Dim oStmt
oStmt = oCon.createStatement()
' Text File
Dim oTextFile as String
Dim iFile as Integer
Dim oStrValue as String
Dim oSQL as String
iFile = FreeFile
oTextFile = "c:\temp\Fuits.txt"
Open oTextFile For Input As #iFile
m = 0
Do While Not( EOF(iFile)) and m < 5
Line Input #iFile, oStrValue
oSQL = "INSERT INTO " & oTableName & "(" & oNameID(0) & "," & oNameID(1) & "," & oNameID(2) & ") VALUES(" & oStrValue & ")"
oStmt.executeUpdate(oSQL)
m = m + 1
Loop
Close #iFile
'
oCon.Close()
oCon.dispose
'
' Display
msgbox "Success"
Exit Sub
oBad:
oCon.Close()
oCon.dispose
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
Form
[ Form Button ]
BFmBtn-)Text Field値の取得
Sub GetFormValue(Event as Object)
Dim oForm as Object
Dim oFromItem as Object
oForm = Event.Source.Model.Parent
oFormItem = oForm.getByName("txtCOL01")
msgbox "Name = " & oFormItem.Text
End Sub
BFmBtn-)
[ Create / Edit ]
BFm-1)新規Formの追加(Table付き)
Sub oAddForm
Dim oDoc 'Newly created Form document
Dim oDrawPage 'Draw page for the form document.
Dim s$ 'Generic temporary string variable.
Dim oDBDoc 'The Base database document.
Dim oTableName 'The Table Name of the Database
Dim sDBName$ 'Name portion from sDBURL.
Dim sFormURL$ 'URL where the temporary form is stored.
Dim oFormDocs 'Form documents in the Base document.
Dim sFormName$ 'Form name as stored in the Baes form documents.
Dim oDocDef 'Document defition of the form stored in Base.
Dim oDBForm
Dim NoArgs() As new com.sun.star.beans.PropertyValue
Dim oProps(2) as new com.sun.star.beans.PropertyValue
On Error Goto oBad
'Create New Base Document
Dim Dummy()
Dim oAns
oDoc = StarDesktop.loadComponentFromURL("private:factory/sdatabase", "_blank", 0, Dummy())
oDataSource = oDoc.DataSource
'
' set to use hsqldb
oDataSource.URL = "sdbc:embedded:hsqldb"
oDBURL = ConvertToUrl("c:\temp\oBaseMacroTest.odb")
if FileExists(oDBURL) then
oAns = msgbox("同名fileがあります。削除しますか?", 4, "既存fileの削除確認")
if oAns = 6 then
Kill(oDBURL)
Else
MsgBox("中断します。")
Exit Sub
End if
end if
oDoc.StoreAsURL(oDBURL,Dummy())
'
' Load the Tools library
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
'
' Connect DB
Dim oBaseContent
Dim oDB
Dim oCon
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDB = oBaseContext.getByName(oDBURL)
oCon = oDB.getConnection("", "")
'
'Create New Table
Dim oTables
' Dim oTableName
Dim oTableDescriptor
' Access Tables in Connecting DB
oTables = oCon.getTables()
' Define the Table Property
oTableDescriptor = oTables.createDataDescriptor()
oTableName = "MACROTESTTABLE"
oTableDescriptor.Name = oTableName
' Define the Datas to table Columns( 最低一項目は設定が必要 )
oCols = oTableDescriptor.getColumns()
oCol = oCols.createDataDescriptor()
oCol.Name = "ID"
oCol.Type = com.sun.star.sdbc.DataType.INTEGER
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
oCol.IsAutoIncrement = True
oCol.Precision = 10
oCol.Description = "Primary Key"
oCols.appendByDescriptor(oCol)
'
' Create Table but not to be able to look the table, because it needs to store Base Document.
oTables.appendByDescriptor(oTableDescriptor)
'
'Base Document Save
oDB.DatabaseDocument.store()
'
'oTableName = "MACROTESTTABLE"
REM Create a new document for the form.
s$ = "private:factory/swriter"
oDoc = StarDesktop.LoadComponentFromURL(s$, "_default", 0, NoArgs())
REM The form will in edit mode, rather than design mode, by default.
oDoc.ApplyFormDesignMode = False
Dim oViewSettings
oViewSettings = oDoc.CurrentController.ViewSettings
oViewSettings.ShowTableBoundaries = False
oViewSettings.ShowOnlineLayout = True
'Get the document's draw page and force the top level form to exist and be named "Standard".
oDrawPage = oDoc.DrawPage
If oDrawPage.Forms.Count = 0 Then
s$ = "com.sun.star.form.component.Form"
oDBForm = oDoc.CreateInstance(s$)
oDrawpage.Forms.InsertByIndex (0, oDBForm)
Else
oDBForm = oDrawPage.Forms.GetByIndex(0)
End If
oDBForm.Name = "Standard"
'Cause the form to use the table as a datasource.
oDBForm.DataSourceName = oDBURL
oDBForm.Command = oTableName
oDBForm.CommandType = com.sun.star.sdb.CommandType.TABLE'Service names for controls.
'
'The method to Store the Form WithOut Writer document.
'Load the Library named Tools.
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
sDBName = GetFileNameWithoutExtension(oDBURL, "/") ' " GetFileNameWithoutExtension " is one of the Library named " Tools ".
sFormName = "Form_" & oTableName
s$ = DirectoryNameoutofPath(oDBURL, "/") & "/" ' " DirectoryNameoutofPath " is one of the Library named " Tools ".
sFormURL = s$ & "Form_" & sDBName & "_" & sTableName & ".odt"
'Store the form to disk and then close the document.
oDoc.StoreAsUrl(sFormUrl, NoArgs())
oDoc.close(True)
'
'Convert the Form on disk to a document defition and to store it as a Base document.
oDBDoc = oFindComponentWithURL(oDBURL, True)
oFormDocs = oDBDoc.getFormDocuments()
If oFormDocs.hasByName(sFormName) Then
Print "Removing " & sFormName & " from the database"
oFormDocs.removeByName(sFormName)
End If
oProps(0).Name = "Name"
oProps(0).Value = sFormName
oProps(1).Name = "Parent"
oProps(1).Value = oFormDocs()
oProps(2).Name = "URL"
oProps(2).Value = sFormUrl
s$ = "com.sun.star.sdb.DocumentDefinition"
oDocDef = oFormDocs.createInstanceWithArguments(s$, oProps())
oFormDocs.insertbyName(sFormName, oDocDef)
Print "Added " & sFormName & " to the database"
Exit Sub
oBad:
oCon.Close()
oCon.dispose
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
'[ Function1 ]
Function oFindComponentWithURL(sName$, bLoadIfNotFound As Boolean)
Dim oDocs ' Enumeration of the loaded components.
Dim oDoc ' A single enumerated component.
Dim sDocURL$ ' URL of the component that we are checking.
'Use some methods from the Tools library.
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
oDocs = StarDesktop.getComponents().createEnumeration()
Do While oDocs.hasMoreElements()
oDoc = oDocs.nextElement()
sDocURL = oGetDocURL(oDoc)
'Just in case the name contains the full URL. If the name is an Empty string, then return an Unsaved document.
If sName = sDocURL Then
oFindComponentWithURL() = oDoc
Exit Function
End If
'This will only work if the name contains the file extension.
If InStr(sDocURL, "/") > 0 Then
If FileNameoutofPath(sDocURL, "/") = sName Then
oFindComponentWithURL() = oDoc
Exit Function
End If
End If
Loop
'The document was not found perhaps the name did not contain a file extension.
oDocs = StarDesktop.getComponents().createEnumeration()
Do While oDocs.hasMoreElements()
oDoc = oDocs.nextElement()
sDocURL = oGetDocURL(oDoc)
If InStr(sDocURL, "/") > 0 Then
If GetFileNameWithoutExtension(sDocURL, "/") = sName Then
oFindComponentWithURL() = oDoc
Exit Function
End If
End If
Loop
'The name was still not found, check to see if a document exists with the specified URL.
If bLoadIfNotFound AND FileExists(sName) Then
oDoc = StarDesktop.loadComponentFromURL(sName, "_blank", 0, Array())
oFindComponentWithURL() = oDoc
'Else
' FindComponentWithURL = NULL
End If
End Function
'[ Function2 ]
Function CreatePoint(xPos, YPos) as New com.sun.star.awt.Point
Dim oPoint as New com.sun.star.awt.Point
oPoint.X = xPos
oPoint.Y = yPos
CreatePoint() = oPoint
End Function
'[ Function3 ]
Function CreateSize(iWidth, iHeight) As New com.sun.star.awt.Size
Dim oSize As New com.sun.star.awt.Size
oSize.Width = iWidth
oSize.Height = iHeight
CreateSize() = oSize
End Function
'[ Function4 ]
Function oGetDocURL(oDoc) As String
oGetDocURL() = ""
If NOT HasUNOInterfaces(oDoc, "com.sun.star.frame.XStorable") Then 'The OOo help does not support the XStorable interface, but the Basic IDE does.
MsgBox("This Document does not support com.sun.star.frame.XStorable,")
Exit Function
'Else
' If NOT oDoc.hasLocation() Then 'This document has never been saved, so there is no URL to compare against.
' MsgBox("This Document included Not to Support Locale")
' Else
' oGetDocURL() = oDoc.getURL()
' End If
End If
End Function
BFm-1)新規Formの追加[Form名：Form_BINDAT / Table : BINDATA は oBase_Table.odb に作成済み]
Sub oAddForm
Dim oDoc 'Newly created Form document
Dim oDrawPage 'Draw page for the form document.
Dim s$ 'Generic temporary string variable.
Dim oDBDoc 'The Base database document.
Dim oTableName 'The Table Name of the Database
Dim sDBName$ 'Name portion from sDBURL.
Dim sFormURL$ 'URL where the temporary form is stored.
Dim oFormDocs 'Form documents in the Base document.
Dim sFormName$ 'Form name as stored in the Baes form documents.
Dim oDocDef 'Document defition of the form stored in Base.
Dim oDBForm
Dim NoArgs() As new com.sun.star.beans.PropertyValue
Dim oProps(2) as new com.sun.star.beans.PropertyValue
oDBURL = ConvertToUrl("c:\temp\oBase_Table.odb")
oTableName = "BINDATA"
REM Create a new document for the form.
s$ = "private:factory/swriter"
oDoc = StarDesktop.LoadComponentFromURL(s$, "_default", 0, NoArgs())
REM The form will in edit mode, rather than design mode, by default.
oDoc.ApplyFormDesignMode = False
Dim oViewSettings
oViewSettings = oDoc.CurrentController.ViewSettings
oViewSettings.ShowTableBoundaries = False
oViewSettings.ShowOnlineLayout = True
'Get the document's draw page and force the top level form to exist and be named "Standard".
oDrawPage = oDoc.DrawPage
If oDrawPage.Forms.Count = 0 Then
s$ = "com.sun.star.form.component.Form"
oDBForm = oDoc.CreateInstance(s$)
oDrawpage.Forms.InsertByIndex (0, oDBForm)
Else
oDBForm = oDrawPage.Forms.GetByIndex(0)
End If
oDBForm.Name = "Standard"
'Cause the form to use the table as a datasource.
oDBForm.DataSourceName = oDBURL
oDBForm.Command = oTableName
oDBForm.CommandType = com.sun.star.sdb.CommandType.TABLE'Service names for controls.
Dim sLabel$ : sLabel = "com.sun.star.form.component.FixedText"
Dim oControl 'A control to insert into the form.
Dim oShape 'Control's shape in the draw page.
Dim oLControl 'Label control.
Dim oLShape 'Label control's shape in the draw page.
Dim lAnchor As Long
lAnchor = com.sun.star.text.TextContentAnchorType.AT_PARAGRAPH 'Anchor the controls to paragraphs.
'
'Insert the ID Form
'Insert the Label field for ID
'Set the properties of Label field for ID.
oLControl = oDoc.CreateInstance(sLabel$)
oLControl.Label = "ID"
oLControl.Name = "lblID"
'Set a Shape of Label fild for ID.
oLShape = oDoc.CreateInstance("com.sun.star.drawing.ControlShape")
oLShape.Size = createSize(1222, 443)
oLShape.Position = createPoint(1000, 1104)
oLShape.AnchorType = lAnchor
oLShape.control = oLControl
'Insert the Text field to input for ID.
'Set the Properties of Text field for ID.
s$ = "com.sun.star.form.component.FormattedField"
oControl = oDoc.CreateInstance(s$)
oControl.LabelControl = oLControl
oControl.BackgroundColor = 14540253
oControl.Border = 1
oControl.DataField = "ID"
oControl.EffectiveMax = 2147483647
oControl.EffectiveMin = -2147483648
oControl.EnforceFormat = True
oControl.HideInactiveSelection = True
oControl.Name = "fmtID"
oControl.TreatAsNumber = True
'Set a Shape of Text fild for ID.
oShape = oDoc.CreateInstance("com.sun.star.drawing.ControlShape")
oShape.Size = createSize(2150, 651)
oShape.Position = createPoint(2522, 1000)
oShape.AnchorType = lAnchor
oShape.control = oControl
'Drawing ID Form
oDrawpage.Add(oLShape) 'The Position of this Line is Important.
oDrawpage.Add(oShape)
'
'Insert the Name Form
'Insert the Label field for Name.
'Set the Properties of Lavel for Name.
oLControl = oDoc.CreateInstance(sLabel)
oLControl.Label = "NAME"
oLControl.Name = "lblName"
'Set a Shape of Lavel field for Name.
oLShape = oDoc.CreateInstance("com.sun.star.drawing.ControlShape")
oLShape.Size = createSize(1222, 443)
oLShape.Position = createPoint(1000, 1954)
oLShape.AnchorType = lAnchor
oLShape.control = oLControl
'Insert the Text field for Name.
'Set the Properties of Text field for Name.
s$ = "com.sun.star.form.component.TextField"
oControl = oDoc.CreateInstance(s$)
oControl.BackgroundColor = 14540253
oControl.Border = 1
oControl.DataField = "NAME"
oControl.LabelControl = oLControl
oControl.Name = "txtNAME"
'Set a Shape of Text fild for ID.
oShape = oDoc.CreateInstance("com.sun.star.drawing.ControlShape")
oShape.Size = createSize(8026, 651)
oShape.Position = createPoint(2522, 1850)
oShape.AnchorType = lAnchor
oShape.control = oControl
'Drawing Name Form
oDrawpage.Add(oShape) 'The Position of this Line is Important.
oDrawpage.Add(oLShape)
'
'Insert the Image control Form
'Insert the Image control.
'Set the Properties of Image control.
s$ = "com.sun.star.form.component.DatabaseImageControl"
oControl = oDoc.CreateInstance(s$)
oControl.BackgroundColor = 14540253
oControl.Border = 1
oControl.DataField = "DATA"
oControl.Name = "imgDATA"
'Set a Shape of Image control.
oShape = oDoc.CreateInstance("com.sun.star.drawing.ControlShape")
oShape.Size = createSize(10504, 7835)
oShape.Position = createPoint(2522, 3332)
oShape.AnchorType = lAnchor
oShape.control = oControl
'Drawing Image control Form
oDrawpage.Add(oShape)
'
'[ Caution ] : It is Impossible to Store the Stand Alone Form to disk.
' Because we have a Form which is a Writer document.
' So, Use some methods from the Tools library.
'
'The method to Store the Form WithOut Writer document.
'Load the Library named Tools.
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
sDBName = GetFileNameWithoutExtension(oDBURL, "/") ' " GetFileNameWithoutExtension " is one of the Library named " Tools ".
sFormName = "Form_" & oTableName
s$ = DirectoryNameoutofPath(oDBURL, "/") & "/" ' " DirectoryNameoutofPath " is one of the Library named " Tools ".
sFormURL = s$ & "Form_" & sDBName & "_" & sTableName & ".odt"
'Store the form to disk and then close the document.
oDoc.StoreAsUrl(sFormUrl, NoArgs())
oDoc.close(True)
'
'Convert the Form on disk to a document defition and to store it as a Base document.
oDBDoc = oFindComponentWithURL(oDBURL, True)
oFormDocs = oDBDoc.getFormDocuments()
If oFormDocs.hasByName(sFormName) Then
Print "Removing " & sFormName & " from the database"
oFormDocs.removeByName(sFormName)
End If
oProps(0).Name = "Name"
oProps(0).Value = sFormName
oProps(1).Name = "Parent"
oProps(1).Value = oFormDocs()
oProps(2).Name = "URL"
oProps(2).Value = sFormUrl
s$ = "com.sun.star.sdb.DocumentDefinition"
oDocDef = oFormDocs.createInstanceWithArguments(s$, oProps())
oFormDocs.insertbyName(sFormName, oDocDef)
Print "Added " & sFormName & " to the database"
End Sub
'[ Function1 ]
Function oFindComponentWithURL(sName$, bLoadIfNotFound As Boolean)
Dim oDocs ' Enumeration of the loaded components.
Dim oDoc ' A single enumerated component.
Dim sDocURL$ ' URL of the component that we are checking.
'Use some methods from the Tools library.
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
oDocs = StarDesktop.getComponents().createEnumeration()
Do While oDocs.hasMoreElements()
oDoc = oDocs.nextElement()
sDocURL = oGetDocURL(oDoc)
'Just in case the name contains the full URL. If the name is an Empty string, then return an Unsaved document.
If sName = sDocURL Then
oFindComponentWithURL() = oDoc
Exit Function
End If
'This will only work if the name contains the file extension.
If InStr(sDocURL, "/") > 0 Then
If FileNameoutofPath(sDocURL, "/") = sName Then
oFindComponentWithURL() = oDoc
Exit Function
End If
End If
Loop
'The document was not found perhaps the name did not contain a file extension.
oDocs = StarDesktop.getComponents().createEnumeration()
Do While oDocs.hasMoreElements()
oDoc = oDocs.nextElement()
sDocURL = oGetDocURL(oDoc)
If InStr(sDocURL, "/") > 0 Then
If GetFileNameWithoutExtension(sDocURL, "/") = sName Then
oFindComponentWithURL() = oDoc
Exit Function
End If
End If
Loop
'The name was still not found, check to see if a document exists with the specified URL.
If bLoadIfNotFound AND FileExists(sName) Then
oDoc = StarDesktop.loadComponentFromURL(sName, "_blank", 0, Array())
oFindComponentWithURL() = oDoc
'Else
' FindComponentWithURL = NULL
End If
End Function
'[ Function2 ]
Function CreatePoint(xPos, YPos) as New com.sun.star.awt.Point
Dim oPoint as New com.sun.star.awt.Point
oPoint.X = xPos
oPoint.Y = yPos
CreatePoint() = oPoint
End Function
'[ Function3 ]
Function CreateSize(iWidth, iHeight) As New com.sun.star.awt.Size
Dim oSize As New com.sun.star.awt.Size
oSize.Width = iWidth
oSize.Height = iHeight
CreateSize() = oSize
End Function
'[ Function4 ]
Function oGetDocURL(oDoc) As String
oGetDocURL() = ""
If NOT HasUNOInterfaces(oDoc, "com.sun.star.frame.XStorable") Then 'The OOo help does not support the XStorable interface, but the Basic IDE does.
MsgBox("This Document does not support com.sun.star.frame.XStorable,")
Exit Function
'Else
' If NOT oDoc.hasLocation() Then 'This document has never been saved, so there is no URL to compare against.
' MsgBox("This Document included Not to Support Locale")
' Else
' oGetDocURL() = oDoc.getURL()
' End If
End If
End Function
BFm-)既存Formを開く(ReadOnly)
Sub oOpenFormInDB1main
Dim oDoc
Dim sDBURL$
Dim oForms
Dim sFormName$
Dim s$
Dim Dummy()
Dim x()
oBaseFileName = "c:\temp\oBase_Table.odb"
sDBURL = ConvertToUrl(oBaseFileName)
oDoc = StarDesktop.loadComponentFromURL(sDBURL, "_default", 0, Dummy())
'Check to Exist theFile
If IsNULL(oDoc) OR IsEmpty(oDoc) Then
Print "The document was not found"
Exit Sub
End If
'Choose a form to open!
oForms = oDoc.getFormDocuments()
If oForms.getCount() < 1 Then
Print "The database contains no forms"
Else
If oForms.getCount() = 1 Then
'If there is ONLY one form, then open the one form!
x() = oForms.getElementNames()
sFormName = x(0)
Else
s$ = "Choose A Form To Open"
sFormName = DialogSelectItem(oForms.getElementNames(), s$)
End If
End If
If sFormName = "" Then Exit Sub
oOpenFormInDB1(sDBURL$, sFormName$, oDoc)
End Sub
'[ Sub Routing1 ]
Sub oOpenFormInDB1(sDBURL$, sFormName$, Optional oDoc)
Dim oDBDoc 'The database document that contains the form.
Dim oFormDef 'com.sun.star.sdb.DocumentDefinition of the form.
Dim oFormDocs 'The form documents container.
Dim oFormDoc 'The actual form document.
Dim oCon 'Database connection.
Dim oParms(1) As New com.sun.star.beans.PropertyValue
Dim oBaseContext 'Global database context service.
Dim oDataBase 'Database obtained from the database context.
'Check to Exist the File
oDBDoc = oDoc
If IsNULL(oDBDoc) OR IsEmpty(oDBDoc) Then
Print "The document was not found"
Exit Sub
End If
oFormDocs = oDBDoc.getFormDocuments()
If NOT oFormDocs.hasByName(sFormName) Then
Print "The database does not have a form named " & sFormName
Exit Sub
End If
oFormDef = oDBDoc.getFormDocuments().getByName(sFormName)
'Without this, the form opens and then disappears!
'This is a bug that will hopefully be fixed in OOo version 2.0.1. oDummyFormDef is defined in the main module.
oDummyFormDef = oFormDef
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDataBase = oBaseContext.getByName(sDBURL)
oCon = oDataBase.getConnection("", "")
'OpenMode is rumored to support "open", "openDesign" and "openForMail"
oAppendProperty(oParms(0), "OpenMode", "open") ' View Mode( Readonly)
'oAppendProperty(oParms(0), "OpenMode", "openDesign") '
oAppendProperty(oParms(1), "ActiveConnection", oCon)
oFormDoc = oFormDocs.loadComponentFromURL(sFormName, "", 0, oParms())
End Sub
'[ Sub Routing2 ]
Sub oAppendProperty(oProperties(), sName As String, ByVal oValue)
oAppendToArray(oProperties(), oCreateProperty(sName, oValue))
End Sub
'[ Function1 ]
Function oAppendToArray(oData(), ByVal x)
Dim oData()
Dim iUB As Integer 'The upper bound of the array.
Dim iLB As Integer 'The lower bound of the array.
iUB = UBound(oData()) + 1
iLB = LBound(oData())
ReDim Preserve oData(iLB To iUB)
oData(iUB) = x
End Function
'[ Function2 ]
Function oCreateProperty(sName$, oValue) As com.sun.star.beans.PropertyValue
Dim oProperty As New com.sun.star.beans.PropertyValue
oProperty.Name = sName
oProperty.Value = oValue
oCreateProperty() = oProperty
End Function
BFm-)既存Formを開く(Design Mode)
Sub oOpenFormInDB2main
Dim oDoc
Dim sDBURL$
Dim oForms
Dim sFormName$
Dim s$
Dim Dummy()
Dim x()
oBaseFileName = "c:\temp\oBase_Table.odb"
sDBURL = ConvertToUrl(oBaseFileName)
oDoc = StarDesktop.loadComponentFromURL(sDBURL, "_default", 0, Dummy())
'Check to Exist theFile
If IsNULL(oDoc) OR IsEmpty(oDoc) Then
Print "The document was not found"
Exit Sub
End If
'Choose a form to open!
oForms = oDoc.getFormDocuments()
If oForms.getCount() < 1 Then
Print "The database contains no forms"
Else
If oForms.getCount() = 1 Then
'If there is ONLY one form, then open the one form!
x() = oForms.getElementNames()
sFormName = x(0)
Else
s$ = "Choose A Form To Open"
sFormName = DialogSelectItem(oForms.getElementNames(), s$)
End If
End If
If sFormName = "" Then Exit Sub
oOpenFormInDB2(sDBURL$, sFormName$, oDoc)
End Sub
'[ Function1 ]
Function oOpenFormInDB2(sDBURL$, sFormName$, Optional oDoc)
Dim oDBDoc 'The database document that contains the form.
Dim oFormDef 'com.sun.star.sdb.DocumentDefinition of the form.
Dim oFormDocs 'The form documents container.
Dim oFormDoc 'The actual form document.
Dim oBaseContext 'Global database context service.
Dim oDataBase 'Database obtained from the database context.
Dim oCon 'Database connection.
Dim oParms() As New com.sun.star.beans.PropertyValue
'Check to Exist the File
oDBDoc = oDoc
If IsNULL(oDBDoc) OR IsEmpty(oDBDoc) Then
Print "The document was not found"
Exit Function
End If
oFormDocs = oDBDoc.getFormDocuments()
If NOT oFormDocs.hasByName(sFormName) Then
Print "The database does not have a form named " & sFormName
Exit Function
End If
oFormDef = oDBDoc.getFormDocuments().getByName(sFormName)
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDataBase = oBaseContext.getByName(sDBURL)
oCon = oDataBase.getConnection("", "")
oAppendProperty(oParms(), "ActiveConnection", oCon)
Dim identifier as Long
identifier = oFormDef.createCommandIdentifier()
Dim UcbCommand as new com.sun.star.ucb.Command
UcbCommand.Name = "openDesign" 'Or "open" or "openForMail"
Dim Arguments as new com.sun.star.ucb.OpenCommandArgument2
Arguments.Mode = com.sun.star.ucb.OpenMode.DOCUMENT
UcbCommand.Argument = Arguments
Dim environment as Object
oFormDoc = oFormDef.execute( UcbCommand, identifier, environment )
oOpenFormInDB2() = oFormDoc
End Function
'[ Sub Routing1 ]
Sub oAppendProperty(oProperties(), sName As String, ByVal oValue)
oAppendToArray(oProperties(), oCreateProperty(sName, oValue))
End Sub
'[ Function2 ]
Function oAppendToArray(oData(), ByVal x)
Dim oData()
Dim iUB As Integer 'The upper bound of the array.
Dim iLB As Integer 'The lower bound of the array.
iUB = UBound(oData()) + 1
iLB = LBound(oData())
ReDim Preserve oData(iLB To iUB)
oData(iUB) = x
End Function
'[ Function3 ]
Function oCreateProperty(sName$, oValue) As com.sun.star.beans.PropertyValue
Dim oProperty As New com.sun.star.beans.PropertyValue
oProperty.Name = sName
oProperty.Value = oValue
oCreateProperty() = oProperty
End Function
BFm-)Current fileのFormを開く(ReadOnly)
Sub oOpenForm3
Dim args(0) As New com.sun.star.beans.PropertyValue
Dim aFormName as string
oDoc = ThisDatabaseDocument ' oDoc = ThisComponent でもOK
oFormDocs = oDoc.getFormDocuments()
aFormName = oFormDocs.getByIndex(0).Name
args(0).Name = "OpenMode"
args(0).Value = "open"
oFormDocs.loadComponentFromURL(aFormName,"_blank",0,args())
End Sub
BFm-)Current fileのFormを開く[その2](ReadOnly)
Sub oCreateForm2
Dim oController as Object
oController = ThisDatabaseDocument.CurrentController
If ( Not oController.isConnected() ) Then
oController.connect()
End If
oFormName = "TestFormForMacro"
oController.loadComponent(com.sun.star.sdb.application.DatabaseObject.FORM, oFormName,FALSE )
End Sub
BFm-)Current fileのFormを開く[その3](Design Mode)
Sub oCreateForm3
Dim oController
oController = ThisDatabaseDocument.CurrentController
If ( Not oController.isConnected() ) Then
oController.connect()
End If
oFormName = "TestFormForMacro"
oController.loadComponent(com.sun.star.sdb.application.DatabaseObject.FORM, oFormName,TRUE )
End Sub
BFm-)Formを含むかのCheck[file名：oBase_Table.odb]
Sub oCheckExistFormInDB
Dim oDoc
Dim sDBURL$
Dim oForms
Dim sFormName$
Dim s$
Dim Dummy()
oBaseFileName = "c:\temp\oBase_Table.odb"
sDBURL = ConvertToUrl(oBaseFileName)
oDoc = StarDesktop.loadComponentFromURL(sDBURL, "_default", 0, Dummy())
'Check to Exist a form for opened!
oForms = oDoc.getFormDocuments()
If oForms.getCount() < 1 Then
Print "The database contains no forms"
End If
End Sub
BFm-)Form数の取得
Sub oCountForms
Dim oDoc
Dim oForms
Dim oFormName as string
oDoc = ThisDatabaseDocument
oForms = oDoc.getFormDocuments()
oCount = oForms.getCount()
MsgBox("本Database fileのForm数は ： " & oCount & " です。")
End Sub
BFm-)Form名の取得
Sub oGetFormName
Dim oFormName as string
oDoc = ThisDatabaseDocument
oForms = oDoc.getFormDocuments()
If oForms.getCount() < 1 Then
Print "The database contains no forms"
Else
If oForms.getCount() = 1 Then
x() = oForms.getElementNames()
sFormName = x(0)
Else
s$ = "Choose A Form To Open"
sFormName = DialogSelectItem(oForms.getElementNames(), s$)
End If
End If
MsgBox("Formの名前は " & sFormName & " です。")
End Sub
BFm-)ImputBox( FormattedField ) in Form作成
Sub CrTb_and_Form
On Error Goto oBad
Dim oDoc as Object
Dim oTempName as String
Dim oFlag as Integer
oFlag = 0
oDoc = ThisComponent
oTempName = oDoc.getURL
'
' Connect DB
Dim oBaseContent as Object
Dim oDB as Object
Dim oCon as Object
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDB = oBaseContext.getByName(oTempName)
oCon = oDB.getConnection("", "")
oFlag = 777
'
' Form と関連付けるTable作成( Queryでの作成はNG )
Dim oTables as Object
Dim oTableName as String
Dim oTableDescriptor as Object
Dim oCols as Object
Dim oCol as Object
'
oTableName = "CreateTb"
' Access Tables in Connecting DB
oTables = oCon.getTables()
'
' 同名Tableが存在するか?
Dim oTNames() as Object
oTNames = oTables.getElementNames()
for i = 0 to UBound(oTNames)
if oTableName = oTNames(i) then
oDisp = "既に [ " & oTableName & " ] と同じ名前のTableがありますので処理を終了します。"
msgbox oDisp,0,"同名Tableが存在します。"
oCon.close()
oCon.dispose
Exit Sub
end if
next i
'
' Define the Table Property
oTableDescriptor = oTables.createDataDescriptor()
oTableDescriptor.Name = oTableName
' Define the Datas to table Columns( 最低一項目は設定が必要 )
oCols = oTableDescriptor.getColumns()
oCol = oCols.createDataDescriptor()
' INTEGER : 整数
oCol.Name = "ID"
oCol.Type = com.sun.star.sdbc.DataType.INTEGER
' oCol.TypeName = "INTEGER" ' Type は TypeName でも設定可能
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
oCol.Precision = 10 ' max 10
oCol.IsAutoIncrement = True
'
oCol.Description = "Primary Key"
'
oCol.FormatKey = com.sun.star.sdbcx.KeyType.UNIQUE
oCols.appendByDescriptor(oCol)
'
' VARCHAR : テキスト
oCol.Name = "Varchar"
oCol.Type = com.sun.star.sdbc.DataType.VARCHAR
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
oCol.Precision = 255 ' max
oCol.IsAutoIncrement = false
oCols.appendByDescriptor(oCol)
'
' Create Table but not to be able to look the table, because it needs to store Base Document.
oTables.appendByDescriptor(oTableDescriptor)
'
'Base Document Save
oDB.DatabaseDocument.store()
'
'
' ##### [ Create Form ] #####
Dim oApp as String
Dim NoArgs() As new com.sun.star.beans.PropertyValue
Dim oFormDoc as Object
oApp = "private:factory/swriter"
oFormDoc = StarDesktop.LoadComponentFromURL(oApp, "_default", 0, NoArgs())
'
oFormDoc.ApplyFormDesignMode = False
'
Dim oViewSettings as Object
oViewSettings = oFormDoc.CurrentController.ViewSettings
oViewSettings.ShowTableBoundaries = False
oViewSettings.ShowOnlineLayout = True
'
Dim oDrawPage as Object
Dim oDBForm as Object
oDrawPage = oFormDoc.DrawPage
'
If oDrawPage.Forms.Count = 0 Then
oDBForm = oFormDoc.CreateInstance("com.sun.star.form.component.Form")
oDrawpage.Forms.InsertByIndex (0, oDBForm)
Else
oDBForm = oDrawPage.Forms.GetByIndex(0)
End If
'
' Form 設定
with oDBForm
.Name = "Standard" ' Form Name
.DataSourceName = oTempName ' Database Name
.Command = oTableName ' Table Name
.CommandType = com.sun.star.sdb.CommandType.TABLE 'Service names for controls.
end with
'
Dim oControl as Object 'A control to insert into the form.
Dim oShape as Object 'Control's shape in the draw page.
Dim oAnchor As Long
'
oAnchor = com.sun.star.text.TextContentAnchorType.AT_PARAGRAPH 'Anchor the controls to paragraphs.
'
'[[ Varchar Column用のForm作成 ]]
' 入力BoxのControl Propertyの設定
oControl = oFormDoc.CreateInstance("com.sun.star.form.component.FormattedField")
with oControl
.BackgroundColor = 14540253
.Border = 1
.DataField = "Varchar" ' Table の Varchar 項
.EffectiveMax = 2147483647
.EffectiveMin = -2147483648
.EnforceFormat = True
.HideInactiveSelection = True
.Name = "fmtID"
.TreatAsNumber = True
end with
'
' 入力Boxの位置設定
Dim oPoint as New com.sun.star.awt.Point
oPoint.X = 2522
oPoint.Y = 1000
' 入力BoxのSize設定
Dim oSize As New com.sun.star.awt.Size
oSize.Width = 2150
oSize.Height = 651
'
' Input BoxのPropertyを設定
oShape = oFormDoc.CreateInstance("com.sun.star.drawing.ControlShape")
with oShape
.Size = oSize
.Position = oPoint
.AnchorType = oAnchor
.control = oControl
end with
'
' Form に描画
oDrawpage.Add(oShape)
'
'
'Load the Library named Tools.( DirectoryNameoutofPath を使う為のGlobl Library 'Tools' をLoad )
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
'
' 一時的にWriter File として保存
Dim oWriterDir as String
Dim oFormName as String
Dim oTempURL as String
oFormName = "Form_" & oTableName
oWriterDir = DirectoryNameoutofPath(oTempName, "/") & "/"
oTempURL = oWriterDir & oFormName & ".odt"
'
oFormDoc.StoreAsUrl(oTempURL, NoArgs())
oFormDoc.close(True)
'
'$$$$$ [ Writer FIileから Form に変換 ] $$$$$
'
' 同名Formの削除
Dim oFormDocument as Object
oFormDocument = oDoc.getFormDocuments()
If oFormDocument.hasByName(oFormName) Then
Print "Removing " & oFormName & " from the database"
oFormDocument.removeByName(oFormName)
End If
'
Dim oProps(2) as new com.sun.star.beans.PropertyValue
oProps(0).Name = "Name"
oProps(0).Value = oFormName
oProps(1).Name = "Parent"
oProps(1).Value = oFormDocument()
oProps(2).Name = "URL"
oProps(2).Value = oTempURL
'
oDocDef = oFormDocument.createInstanceWithArguments("com.sun.star.sdb.DocumentDefinition", oProps())
oFormDocument.insertbyName(oFormName, oDocDef)
'
' Con Close
oCon.Close()
oCon.dispose
'
'
' 一時Witer Fileの削除
If FileExists(oTempURL) then
Kill(oTempURL)
end if
'
' Display
msgbox "Success"
Exit Sub
oBad:
if oFlag = 777 then
oCon.Close()
oCon.dispose
end if
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
BFm-)ImputBox( TextField ) in Form作成
Sub CrTb_and_Form
On Error Goto oBad
Dim oDoc as Object
Dim oTempName as String
Dim oFlag as Integer
oFlag = 0
oDoc = ThisComponent
oTempName = oDoc.getURL
'
' Connect DB
Dim oBaseContent as Object
Dim oDB as Object
Dim oCon as Object
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDB = oBaseContext.getByName(oTempName)
oCon = oDB.getConnection("", "")
oFlag = 777
'
' Form と関連付けるTable作成( Queryでの作成はNG )
Dim oTables as Object
Dim oTableName as String
Dim oTableDescriptor as Object
Dim oCols as Object
Dim oCol as Object
'
oTableName = "CreateTb"
'
' Access Tables in Connecting DB
oTables = oCon.getTables()
'
' 同名Tableが存在するか?
Dim oTNames() as Object
oTNames = oTables.getElementNames()
for i = 0 to UBound(oTNames)
if oTableName = oTNames(i) then
oDisp = "既に [ " & oTableName & " ] と同じ名前のTableがありますので処理を終了します。"
msgbox oDisp,0,"同名Tableが存在します。"
oCon.close()
oCon.dispose
Exit Sub
end if
next i
'
' Define the Table Property
oTableDescriptor = oTables.createDataDescriptor()
oTableDescriptor.Name = oTableName
' Define the Datas to table Columns( 最低一項目は設定が必要 )
oCols = oTableDescriptor.getColumns()
oCol = oCols.createDataDescriptor()
' INTEGER : 整数
oCol.Name = "ID"
oCol.Type = com.sun.star.sdbc.DataType.INTEGER
' oCol.TypeName = "INTEGER" ' Type は TypeName でも設定可能
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
oCol.Precision = 10 ' max 10
oCol.IsAutoIncrement = True
'
oCol.Description = "Primary Key"
'
oCol.FormatKey = com.sun.star.sdbcx.KeyType.UNIQUE
oCols.appendByDescriptor(oCol)
'
' VARCHAR : テキスト
oCol.Name = "Varchar"
oCol.Type = com.sun.star.sdbc.DataType.VARCHAR
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
oCol.Precision = 255 ' max
oCol.IsAutoIncrement = false
oCols.appendByDescriptor(oCol)
'
' Create Table but not to be able to look the table, because it needs to store Base Document.
oTables.appendByDescriptor(oTableDescriptor)
'
'Base Document Save
oDB.DatabaseDocument.store()
'
'
' ##### [ Create Form ] #####
Dim oApp as String
Dim NoArgs() As new com.sun.star.beans.PropertyValue
Dim oFormDoc as Object
oApp = "private:factory/swriter"
oFormDoc = StarDesktop.LoadComponentFromURL(oApp, "_default", 0, NoArgs())
'
oFormDoc.ApplyFormDesignMode = False
'
Dim oViewSettings as Object
oViewSettings = oFormDoc.CurrentController.ViewSettings
oViewSettings.ShowTableBoundaries = False
oViewSettings.ShowOnlineLayout = True
'
Dim oDrawPage as Object
Dim oDBForm as Object
oDrawPage = oFormDoc.DrawPage
'
If oDrawPage.Forms.Count = 0 Then
oDBForm = oFormDoc.CreateInstance("com.sun.star.form.component.Form")
oDrawpage.Forms.InsertByIndex (0, oDBForm)
Else
oDBForm = oDrawPage.Forms.GetByIndex(0)
End If
'
' Form 設定
with oDBForm
.Name = "Standard" ' Form Name
.DataSourceName = oTempName ' Database Name
.Command = oTableName ' Table Name
.CommandType = com.sun.star.sdb.CommandType.TABLE 'Service names for controls.
end with
'
Dim oControl as Object 'A control to insert into the form.
Dim oShape as Object 'Control's shape in the draw page.
Dim oAnchor As Long
'
oAnchor = com.sun.star.text.TextContentAnchorType.AT_PARAGRAPH 'Anchor the controls to paragraphs.
'
'[[ Varchar Column用のForm作成 ]]
' 入力BoxのControl Propertyの設定
oControl = oFormDoc.CreateInstance("com.sun.star.form.component.TextField")
with oControl
.BackgroundColor = 14540253
.Border = 1
.DataField = "Varchar" ' Table の Varchar 項
.Name = "fmtID"
end with
'
' 入力Boxの位置設定
Dim oPoint as New com.sun.star.awt.Point
oPoint.X = 2000
oPoint.Y = 1000
' 入力BoxのSize設定
Dim oSize As New com.sun.star.awt.Size
oSize.Width = 4000
oSize.Height = 700
'
' Input BoxのPropertyを設定
oShape = oFormDoc.CreateInstance("com.sun.star.drawing.ControlShape")
with oShape
.Size = oSize
.Position = oPoint
.AnchorType = oAnchor
.control = oControl
end with
'
' Form に描画
oDrawpage.Add(oShape)
'
'
'Load the Library named Tools.( DirectoryNameoutofPath を使う為のGlobl Library 'Tools' をLoad )
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
'
' 一時的にWriter File として保存
Dim oWriterDir as String
Dim oFormName as String
Dim oTempURL as String
oFormName = "Form_" & oTableName
oWriterDir = DirectoryNameoutofPath(oTempName, "/") & "/"
oTempURL = oWriterDir & oFormName & ".odt"
'
oFormDoc.StoreAsUrl(oTempURL, NoArgs())
oFormDoc.close(True)
'
'$$$$$ [ Writer FIileから Form に変換 ] $$$$$
'
' 同名Formの削除
Dim oFormDocument as Object
oFormDocument = oDoc.getFormDocuments()
If oFormDocument.hasByName(oFormName) Then
Print "Removing " & oFormName & " from the database"
oFormDocument.removeByName(oFormName)
End If
'
Dim oProps(2) as new com.sun.star.beans.PropertyValue
oProps(0).Name = "Name"
oProps(0).Value = oFormName
oProps(1).Name = "Parent"
oProps(1).Value = oFormDocument()
oProps(2).Name = "URL"
oProps(2).Value = oTempURL
'
oDocDef = oFormDocument.createInstanceWithArguments("com.sun.star.sdb.DocumentDefinition", oProps())
oFormDocument.insertbyName(oFormName, oDocDef)
'
' Con Close
oCon.Close()
oCon.dispose
'
'
' 一時Witer Fileの削除
If FileExists(oTempURL) then
Kill(oTempURL)
end if
'
' Display
msgbox "Success"
Exit Sub
oBad:
if oFlag = 777 then
oCon.Close()
oCon.dispose
end if
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
BFm-)ImputBox( ComboBox ) in Form作成
Sub CrTb_and_Form
On Error Goto oBad
Dim oDoc as Object
Dim oTempName as String
Dim oFlag as Integer
oFlag = 0
oDoc = ThisComponent
oTempName = oDoc.getURL
'
' Connect DB
Dim oBaseContent as Object
Dim oDB as Object
Dim oCon as Object
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDB = oBaseContext.getByName(oTempName)
oCon = oDB.getConnection("", "")
oFlag = 777
'
' Form と関連付けるTable作成( Queryでの作成はNG )
Dim oTables as Object
Dim oTableName as String
Dim oTableDescriptor as Object
Dim oCols as Object
Dim oCol as Object
'
oTableName = "CreateTb"
'
' Access Tables in Connecting DB
oTables = oCon.getTables()
'
' 同名Tableが存在するか?
Dim oTNames() as Object
oTNames = oTables.getElementNames()
for i = 0 to UBound(oTNames)
if oTableName = oTNames(i) then
oDisp = "既に [ " & oTableName & " ] と同じ名前のTableがありますので処理を終了します。"
msgbox oDisp,0,"同名Tableが存在します。"
oCon.close()
oCon.dispose
Exit Sub
end if
next i
'
' Define the Table Property
oTableDescriptor = oTables.createDataDescriptor()
oTableDescriptor.Name = oTableName
' Define the Datas to table Columns( 最低一項目は設定が必要 )
oCols = oTableDescriptor.getColumns()
oCol = oCols.createDataDescriptor()
' INTEGER : 整数
oCol.Name = "ID"
oCol.Type = com.sun.star.sdbc.DataType.INTEGER
' oCol.TypeName = "INTEGER" ' Type は TypeName でも設定可能
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
oCol.Precision = 10 ' max 10
oCol.IsAutoIncrement = True
'
oCol.Description = "Primary Key"
'
oCol.FormatKey = com.sun.star.sdbcx.KeyType.UNIQUE
oCols.appendByDescriptor(oCol)
'
' VARCHAR : テキスト
oCol.Name = "Varchar"
oCol.Type = com.sun.star.sdbc.DataType.VARCHAR
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
oCol.Precision = 255 ' max
oCol.IsAutoIncrement = false
oCols.appendByDescriptor(oCol)
'
' Create Table but not to be able to look the table, because it needs to store Base Document.
oTables.appendByDescriptor(oTableDescriptor)
'
'Base Document Save
oDB.DatabaseDocument.store()
'
'
' ##### [ Create Form ] #####
Dim oApp as String
Dim NoArgs() As new com.sun.star.beans.PropertyValue
Dim oFormDoc as Object
oApp = "private:factory/swriter"
oFormDoc = StarDesktop.LoadComponentFromURL(oApp, "_default", 0, NoArgs())
'
oFormDoc.ApplyFormDesignMode = False
'
Dim oViewSettings as Object
oViewSettings = oFormDoc.CurrentController.ViewSettings
oViewSettings.ShowTableBoundaries = False
oViewSettings.ShowOnlineLayout = True
'
Dim oDrawPage as Object
Dim oDBForm as Object
oDrawPage = oFormDoc.DrawPage
'
If oDrawPage.Forms.Count = 0 Then
oDBForm = oFormDoc.CreateInstance("com.sun.star.form.component.Form")
oDrawpage.Forms.InsertByIndex (0, oDBForm)
Else
oDBForm = oDrawPage.Forms.GetByIndex(0)
End If
'
' Form 設定
with oDBForm
.Name = "Standard" ' Form Name
.DataSourceName = oTempName ' Database Name
.Command = oTableName ' Table Name
.CommandType = com.sun.star.sdb.CommandType.TABLE 'Service names for controls.
end with
'
Dim oControl as Object 'A control to insert into the form.
Dim oShape as Object 'Control's shape in the draw page.
Dim oAnchor As Long
'
oAnchor = com.sun.star.text.TextContentAnchorType.AT_PARAGRAPH 'Anchor the controls to paragraphs.
'
'[[ Varchar Column用のForm作成 ]]
' 入力BoxのControl Propertyの設定
'
Dim oList(5) as String
oList(0) = "Zero"
oList(1) = "One"
oList(2) = "Two"
oList(3) = "Three"
oList(4) = "Four"
oList(5) = "Five"
'
oControl = oFormDoc.CreateInstance("com.sun.star.form.component.ComboBox")
with oControl
.BackgroundColor = 14540253
.Border = 1
.DataField = "Varchar" ' Table の Varchar 項
.Name ="NumberSelection"
.Text = "Zero"
.Dropdown = True
.StringItemList = oList()
end with
'
'
' 入力Boxの位置設定
Dim oPoint as New com.sun.star.awt.Point
oPoint.X = 2000
oPoint.Y = 1000
' 入力BoxのSize設定
Dim oSize As New com.sun.star.awt.Size
oSize.Width = 4000
oSize.Height = 700
'
' Input BoxのPropertyを設定
oShape = oFormDoc.CreateInstance("com.sun.star.drawing.ControlShape")
with oShape
.Size = oSize
.Position = oPoint
.AnchorType = oAnchor
.control = oControl
end with
'
' Form に描画
oDrawpage.Add(oShape)
'
'
'Load the Library named Tools.( DirectoryNameoutofPath を使う為のGlobl Library 'Tools' をLoad )
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
'
' 一時的にWriter File として保存
Dim oWriterDir as String
Dim oFormName as String
Dim oTempURL as String
oFormName = "Form_" & oTableName
oWriterDir = DirectoryNameoutofPath(oTempName, "/") & "/"
oTempURL = oWriterDir & oFormName & ".odt"
'
oFormDoc.StoreAsUrl(oTempURL, NoArgs())
oFormDoc.close(True)
'
'$$$$$ [ Writer FIileから Form に変換 ] $$$$$
'
' 同名Formの削除
Dim oFormDocument as Object
oFormDocument = oDoc.getFormDocuments()
If oFormDocument.hasByName(oFormName) Then
Print "Removing " & oFormName & " from the database"
oFormDocument.removeByName(oFormName)
End If
'
Dim oProps(2) as new com.sun.star.beans.PropertyValue
oProps(0).Name = "Name"
oProps(0).Value = oFormName
oProps(1).Name = "Parent"
oProps(1).Value = oFormDocument()
oProps(2).Name = "URL"
oProps(2).Value = oTempURL
'
oDocDef = oFormDocument.createInstanceWithArguments("com.sun.star.sdb.DocumentDefinition", oProps())
oFormDocument.insertbyName(oFormName, oDocDef)
'
' Con Close
oCon.Close()
oCon.dispose
'
'
' 一時Witer Fileの削除
If FileExists(oTempURL) then
Kill(oTempURL)
end if
'
' Display
msgbox "Success"
Exit Sub
oBad:
if oFlag = 777 then
oCon.Close()
oCon.dispose
end if
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
BFm-)ImputBox( ListBox ) in Form作成
Sub CrTb_and_Form
On Error Goto oBad
Dim oDoc as Object
Dim oTempName as String
Dim oFlag as Integer
oFlag = 0
oDoc = ThisComponent
oTempName = oDoc.getURL
'
' Connect DB
Dim oBaseContent as Object
Dim oDB as Object
Dim oCon as Object
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDB = oBaseContext.getByName(oTempName)
oCon = oDB.getConnection("", "")
oFlag = 777
'
' Form と関連付けるTable作成( Queryでの作成はNG )
Dim oTables as Object
Dim oTableName as String
Dim oTableDescriptor as Object
Dim oCols as Object
Dim oCol as Object
'
oTableName = "CreateTb"
'
' Access Tables in Connecting DB
oTables = oCon.getTables()
'
' 同名Tableが存在するか?
Dim oTNames() as Object
oTNames = oTables.getElementNames()
for i = 0 to UBound(oTNames)
if oTableName = oTNames(i) then
oDisp = "既に [ " & oTableName & " ] と同じ名前のTableがありますので処理を終了します。"
msgbox oDisp,0,"同名Tableが存在します。"
oCon.close()
oCon.dispose
Exit Sub
end if
next i
'
' Define the Table Property
oTableDescriptor = oTables.createDataDescriptor()
oTableDescriptor.Name = oTableName
' Define the Datas to table Columns( 最低一項目は設定が必要 )
oCols = oTableDescriptor.getColumns()
oCol = oCols.createDataDescriptor()
' INTEGER : 整数
oCol.Name = "ID"
oCol.Type = com.sun.star.sdbc.DataType.INTEGER
' oCol.TypeName = "INTEGER" ' Type は TypeName でも設定可能
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
oCol.Precision = 10 ' max 10
oCol.IsAutoIncrement = True
'
oCol.Description = "Primary Key"
'
oCol.FormatKey = com.sun.star.sdbcx.KeyType.UNIQUE
oCols.appendByDescriptor(oCol)
'
' VARCHAR : テキスト
oCol.Name = "Varchar"
oCol.Type = com.sun.star.sdbc.DataType.VARCHAR
oCol.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
oCol.Precision = 255 ' max
oCol.IsAutoIncrement = false
oCols.appendByDescriptor(oCol)
'
' Create Table but not to be able to look the table, because it needs to store Base Document.
oTables.appendByDescriptor(oTableDescriptor)
'
'Base Document Save
oDB.DatabaseDocument.store()
'
'
' ##### [ Create Form ] #####
Dim oApp as String
Dim NoArgs() As new com.sun.star.beans.PropertyValue
Dim oFormDoc as Object
oApp = "private:factory/swriter"
oFormDoc = StarDesktop.LoadComponentFromURL(oApp, "_default", 0, NoArgs())
'
oFormDoc.ApplyFormDesignMode = False
'
Dim oViewSettings as Object
oViewSettings = oFormDoc.CurrentController.ViewSettings
oViewSettings.ShowTableBoundaries = False
oViewSettings.ShowOnlineLayout = True
'
Dim oDrawPage as Object
Dim oDBForm as Object
oDrawPage = oFormDoc.DrawPage
'
If oDrawPage.Forms.Count = 0 Then
oDBForm = oFormDoc.CreateInstance("com.sun.star.form.component.Form")
oDrawpage.Forms.InsertByIndex (0, oDBForm)
Else
oDBForm = oDrawPage.Forms.GetByIndex(0)
End If
'
' Form 設定
with oDBForm
.Name = "Standard" ' Form Name
.DataSourceName = oTempName ' Database Name
.Command = oTableName ' Table Name
.CommandType = com.sun.star.sdb.CommandType.TABLE 'Service names for controls.
end with
'
Dim oControl as Object 'A control to insert into the form.
Dim oShape as Object 'Control's shape in the draw page.
Dim oAnchor As Long
'
oAnchor = com.sun.star.text.TextContentAnchorType.AT_PARAGRAPH 'Anchor the controls to paragraphs.
'
'[[ Varchar Column用のForm作成 ]]
' 入力BoxのControl Propertyの設定
'
Dim oList(5) as String
oList(0) = "Zero"
oList(1) = "One"
oList(2) = "Two"
oList(3) = "Three"
oList(4) = "Four"
oList(5) = "Five"
'
oControl = oFormDoc.CreateInstance("com.sun.star.form.component.ListBox")
with oControl
' List Box 固有の設定
.reset()
.commit()
.refresh()
.DropDown = false ' DropDown表示 MultiSelect = trueならば、必ずfalseにする
.Enabled = True
.MultiSelection = false ' Tableと関係付けている時は、TableへのData入力は1つなので複数選択は false にする
.FontHeight = 12
.FontWeight = com.sun.star.awt.FontWeight.BOLD
.LineCount = 6 ' 表示する項目数
'
.BackgroundColor = &HC8FFB9 'verdolino
.Border = 1
.DataField = "Varchar" ' Table の Varchar 項
.Name ="NumberSelection"
end with
'
'
' 入力Boxの位置設定
Dim oPoint as New com.sun.star.awt.Point
oPoint.X = 2000
oPoint.Y = 1000
' 入力BoxのSize設定
Dim oSize As New com.sun.star.awt.Size
oSize.Width = 2000
oSize.Height = 4000
'
' Input BoxのPropertyを設定
oShape = oFormDoc.CreateInstance("com.sun.star.drawing.ControlShape")
with oShape
.Size = oSize
.Position = oPoint
.AnchorType = oAnchor
.control = oControl
end with
'
' Form に描画
oDrawpage.Add(oShape)
'
'
' Add thelist items to the listbox
Dim frm as Object
Dim oListBoxModel as Object
Dim ctrl as Object
Dim oListBoxView as Object
frm = oDrawpage.Forms.getByIndex(0)
oListBoxModel = frm.getByName("NumberSelection")
ctrl = oFormDoc.CurrentController
oListBoxView = ctrl.getControl(oListBoxModel)
oListBoxView.addItems(oList, 0, 1, 2, 3, 4, 5)
oListBoxView.selectItemPos(0,false)
'
'
'Load the Library named Tools.( DirectoryNameoutofPath を使う為のGlobl Library 'Tools' をLoad )
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
'
' 一時的にWriter File として保存
Dim oWriterDir as String
Dim oFormName as String
Dim oTempURL as String
oFormName = "Form_" & oTableName
oWriterDir = DirectoryNameoutofPath(oTempName, "/") & "/"
oTempURL = oWriterDir & oFormName & ".odt"
'
oFormDoc.StoreAsUrl(oTempURL, NoArgs())
oFormDoc.close(True)
'
'$$$$$ [ Writer FIileから Form に変換 ] $$$$$
'
' 同名Formの削除
Dim oFormDocument as Object
oFormDocument = oDoc.getFormDocuments()
If oFormDocument.hasByName(oFormName) Then
Print "Removing " & oFormName & " from the database"
oFormDocument.removeByName(oFormName)
End If
'
Dim oProps(2) as new com.sun.star.beans.PropertyValue
oProps(0).Name = "Name"
oProps(0).Value = oFormName
oProps(1).Name = "Parent"
oProps(1).Value = oFormDocument()
oProps(2).Name = "URL"
oProps(2).Value = oTempURL
'
oDocDef = oFormDocument.createInstanceWithArguments("com.sun.star.sdb.DocumentDefinition", oProps())
oFormDocument.insertbyName(oFormName, oDocDef)
'
' Con Close
oCon.Close()
oCon.dispose
'
'
' 一時Witer Fileの削除
If FileExists(oTempURL) then
Kill(oTempURL)
end if
'
' Display
msgbox "Success"
Exit Sub
oBad:
if oFlag = 777 then
oCon.Close()
oCon.dispose
end if
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
BFm-)
