File
DataSource
Connect with DataSource
Table
[ ResultSet Service ]
[ RowSet Service ]
[ PreparedStatement Service ]
[ createDataDescriptor() ]
SQL / Query[Base]
Form
[ Form Button ]
[ Create / Edit ]
･その他[Base]
MySQL[Base]
[ Table ]
MS-ACCESS[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
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
Sub BaseIntoCalc()
Dim db As Object
Dim oBase as String
oBase ="oBase_test"
db = connect_to_database(oBase)
oLoad_Calc(db)
disconnect_from_database(db)
End Sub
'
Sub disconnect_from_database ( db as Object)
db.close
db.dispose()
End Sub
'
Sub oLoad_Calc(db as Object)
Dim Dummy()
Dim oArray(4) 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"
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))
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_3= oSheet.getCellByPosition(3,i)
oCell_4= oSheet.getCellByPosition(4,i)
oCell_0.String = oRowSet.getString(1)
oCell_1.String = oRowSet.getString(2)
oCell_2.String = oRowSet.getString(3)
oCell_3.String = oRowSet.getString(4)
oCell_4.String = oRowSet.getString(5)
wend
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
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
Sub oCheck_Exit
Dim oURL
Dim bVerbose
oDoc = "c:\temp\oBase1.odb"
oURL = ConvertToUrl(oDoc)
a=bVerbose(oURL)
print a
End Sub
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
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
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()
Do While oEnum.hasMoreElements()
oDataSource = oEnum.nextElement()
Loop
MsgBox("Success")
End Sub
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")
End Sub
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
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
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
Sub RegisterDB_Source()
Dim oDBContext As Object
Dim oDBNames() as String
Dim i As Integer
Dim oRgstrDB As String
Dim oFlag as Integer
oDBContext =createUnoService("com.sun.star.sdb.DatabaseContext")
oDBNames = oDBContext.getElementNames()
'
oFlag = 0
oRgstrDB = "oBaseMacroTest"
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)
oDB = StarDesktop.loadComponentFromURL( oUrlDb, "_blank",0,oDummy())
oDBContext.registerObject(oRgstrDB,oDB.DataSource)
'
' Display
msgbox "登録完了"
End Sub
Sub oRevokeDataSource
Dim oBaseContext 'Global database context.
Dim oDBName
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oDBName = "MemTest"
'Revoke DataSorce Resistered DataSource at List
oBaseContext.revokeObject(oDBName)
'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 = 0 Then
MsgBox( "Success !!" & Chr$(10) & oDBName & "は削除されています。", 0, "DataSourceの登録削除確認")
Exit Sub
else
MsgBox(oDBName & "の削除は失敗しました。", 0, "DataSourceの登録削除確認")
End If
End Sub
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
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
･Connect with DataSource[Base]
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
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
Sub oSupportedDBDrivers
Dim oManager 'Connection driver manager.
Dim oEnum 'Enumeration of supported drivers.
Dim oDriver 'An indiviual driver.
Dim oDriverNames
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")
End Sub
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]
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
[ ResultSet Service ]
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
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
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
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
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
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
[ RowSet Service ]
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利用しない場合 ] ***********
'
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
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
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
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
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
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
[ PreparedStatement Service ]
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
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() ]
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
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
SQL / Query
Sub oSQL
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 = "CITY_LIST"
oStmt = oCon.createStatement()
oSQL = "CREATE TABLE " & oTbName & "(ID INTEGER,CITY_NAME VARCHAR(30)); "
oStmt.execute(oSQL)
'
'Unconnect with the Datasource
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:
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 oBase_Query1
Dim db As Object
Dim oBase as String
oBase ="oBase_test"
db = connect_to_database(oBase)
simple_query(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 simple_query(db as Object)
Dim oSql As String
Dim i As Integer
Dim oRowSet As Object
Dim oResult As String
oSql = "SELECT * FROM""table1"""
oRowSet = createUnoService("com.sun.star.sdb.RowSet")
With oRowSet
.activeConnection = db
.Command = oSql
.execute
End With
While oRowSet.Next
oResult = oResult & oRowset.getString(1) & " " _
& capitalize(oRowset.getString(2) ) & " " _
& capitalize(oRowset.getString(3) ) & " " _
& capitalize(oRowset.getString(4) ) & " " _
& oRowset.getString(5) &chr(13)
wend
msgbox oResult,,"Macro_Query"
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
'[ Function2 ]
Function capitalize(iName As String) As String
Dim wordStart As String
Dim wordEnd As String
wordStart = UCase(Mid(iName,1,1))
wordEnd = LCase(Mid(iName,2))
capitalize = wordStart & wordEnd
End Function
Sub oBase_Query2
Dim db As Object
Dim oBase as String
oBase ="oBase_test"
db = connect_to_database(oBase)
simple_query(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 simple_query(db as Object)
Dim oSql As String
Dim i As Integer
Dim oRowSet As Object
Dim oResult As String
oSql = "SELECT " & " " & "title,author,published" & " " & "FROM" & " " & "table1"
oRowSet = createUnoService("com.sun.star.sdb.RowSet")
With oRowSet
.activeConnection = db
.Command = oSql
.execute
End With
While oRowSet.Next
oResult = oResult & oRowset.getString(1) & " " _
& oRowset.getString(2) & " " _
& oRowset.getString(3) & " " _
&chr(13)
wend
msgbox oResult,,"Macro_Query"
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
'Option Base1
Sub oBase_Query3
Dim db As Object
Dim oBase as String
oBase ="oBase_test"
db = connect_to_database(oBase)
simple_query(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 simple_query(db as Object)
Dim oSql As String
Dim i As Integer
Dim oRowSet As Object
Dim oResult As String
oSql = "SELECT " & " " & "title,publish,published" & " " & "FROM" & " " & "table1" & " " & "WHERE" & " " & "publish = 'oPublish1' and title = 'test1' ;"
oRowSet = createUnoService("com.sun.star.sdb.RowSet")
With oRowSet
.activeConnection = db
.Command = oSql
.execute
End With
While oRowSet.Next
oResult = oResult & oRowset.getString(1) & " " _
& oRowset.getString(2) & " " _
& oRowset.getString(3) & " " _
& oRowset.getString(4) & " " _
&chr(13)
wend
msgbox oResult,,"Macro_Query"
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
Sub oSQL
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 oTableName as String
oTableName = "TEST" ' 大文字
oStmt = oCon.createStatement()
' 既存Tableがあると削除する
oSQL1 = "DROP TABLE " & oTableName & " IF EXISTS; "
oStmt.execute(oSQL1)
'
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
Sub oSQL
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 = "TEST" ' 大文字
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
'
' 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
Sub oSQL
On Error Goto oBad
Dim oDoc as Object
Dim oFlag as Integer
Dim oTempName as String
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 TABLE句
Dim oStmt as Object
Dim oTableName as String
oTableName = "CR_TB" ' 大文字
oStmt = oCon.createStatement()
' Delete same name table.
Dim oSQL1 as String
oSQL1 = "DROP TABLE " & oTableName & " IF EXISTS; "
oStmt.execute(oSQL1)
' Create Table
Dim oSQL2 as String
oSQL2 = "CREATE TABLE " & oTableName & "(ID INTEGER IDENTITY, COL01 TINYINT, COL02 SMALLINT, COL03 BIGINT" & _
", COL04 FLOAT, COL05 DOUBLE, COL06 REAL, COL07 NUMERIC, COL08 DECIMAL, COL09 FLOAT" & _
", COL10 CHAR(255), COL11 VARCHAR(255), COL12 LONGVARCHAR" & _
", COL13 DATE, COL14 TIME, COL15 TIMESTAMP" & _
", COL16 BINARY, COL17 VARBINARY, COL18 LONGVARBINARY" & _
", COL19 BOOLEAN" & _
", COL20 OTHER" & _
", PRIMARY KEY (ID)) "
oStmt.execute(oSQL2)
' Refresh Tb
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())
'
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 oSQL
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
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
'
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 oSQL
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
Dim oSQL as String
Dim oTableName as String
oTableName = "DateTable" ' 大文字
oStmt = oCon.createStatement()
oSQL = "CREATE TABLE " & oTableName & "(ID INTEGER IDENTITY, oDate Date, 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 & ",'2011-05-05')" ' HSQLDBが受け付けるのはyyyy-mm-ddだけ
oSQL2 = "INSERT INTO " & oTableName & "(ID, oDate)" & " " & oValue
oStmt.executeUpdate(oSQL2)
Next i
'
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 oSQL
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
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
'
' SELECT句
Dim oSQL3 as String
Dim oTableName2 as String
oTableName2 = "SELECT_ADRESS"
oSQL3 = "SELECT * INTO " & oTableName2 & " FROM " & oTableName
oStmt.execute(oSQL3)
'
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 oSQL
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
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
'
' SELECT句
Dim oSQL3 as String
Dim oTableName2 as String
oTableName2 = "SELECT_ADRESS"
oSQL3 = "SELECT TITLE, NAME INTO " & oTableName2 & " FROM " & oTableName
oStmt.execute(oSQL3)
'
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 oSQL
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
Dim oSQL as String
Dim oTableName as String
oTableName = "ADRESS" ' 大文字
oStmt = oCon.createStatement()
oSQL = "CREATE TABLE " & oTableName & "(ID INTEGER IDENTITY,ADRESS varchar(20),TITLE varchar(20),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" & i & "', 'Test" & i & "', 'New_OOo3')"
oSQL2 = "INSERT INTO " & oTableName & "(ID, ADRESS, TITLE, NAME)" & " " & oValue
oStmt.executeUpdate(oSQL2)
Next i
'
' WHERE句
Dim oWhere as String
oWhere = " WHERE ADRESS='home3' and TITLE='Test3'"
' SELECT句
Dim oSQL3 as String
Dim oTableName2 as String
oTableName2 = "SELECT_ADRESS"
oSQL3 = "SELECT * INTO " & oTableName2 & " FROM " & oTableName & oWhere
oStmt.execute(oSQL3)
'
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 oSQL
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
Dim oSQL as String
Dim oTableName as String
oTableName = "ADRESS" ' 大文字
oStmt = oCon.createStatement()
oSQL = "CREATE TABLE " & oTableName & "(ID INTEGER IDENTITY,ADRESS varchar(20),TITLE varchar(20),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" & i & "', 'Test" & i & "', 'New_OOo3" & "_" & i & "')"
oSQL2 = "INSERT INTO " & oTableName & "(ID, ADRESS, TITLE, NAME)" & " " & oValue
oStmt.executeUpdate(oSQL2)
Next i
'
' WHERE句
Dim oWhere as String
oWhere = " WHERE ( (" & oTableName & ".ADRESS = 'home3' AND " & oTableName & ".TITLE = 'Test3') OR (" & oTableName & ".ID = 10 AND " & oTableName & ".NAME = 'New_OOo3_10' ))"
' SELECT句
Dim oSQL3 as String
Dim oTableName2 as String
oTableName2 = "SELECT_ADRESS"
oSQL3 = "SELECT * INTO " & oTableName2 & " FROM " & oTableName & oWhere
oStmt.execute(oSQL3)
'
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 oSQL
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
Dim oSQL as String
Dim oTableName as String
oTableName = "ADRESS" ' 大文字
oStmt = oCon.createStatement()
oSQL = "CREATE TABLE " & oTableName & "(ID INTEGER IDENTITY,ADRESS varchar(20),TITLE varchar(20),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" & i & "', 'Test" & i & "', 'New_OOo3" & "_" & i & "')"
oSQL2 = "INSERT INTO " & oTableName & "(ID, ADRESS, TITLE, NAME)" & " " & oValue
oStmt.executeUpdate(oSQL2)
Next i
'
' WHERE句
Dim oWhere as String
oWhere = " WHERE ( (" & oTableName & ".ADRESS Like 'home%' AND " & oTableName & ".TITLE Like '%10') OR (" & oTableName & ".ID=30 AND " & oTableName & ".NAME Like '%OOo3_%' ))"
' SELECT句
Dim oSQL3 as String
Dim oTableName2 as String
oTableName2 = "SELECT_ADRESS"
oSQL3 = "SELECT * INTO " & oTableName2 & " FROM " & oTableName & oWhere
oStmt.execute(oSQL3)
'
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 oSQL
'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
Dim oSQL as String
Dim oTableName as String
oTableName = "ADRESS" ' 大文字
oStmt = oCon.createStatement()
oSQL = "CREATE TABLE " & oTableName & "(ID INTEGER IDENTITY,ADRESS varchar(20),TITLE varchar(20),NAME varchar(30), PRIMARY KEY (ID)) "
oStmt.execute(oSQL)
'
' ALTER句
Dim oAlart as String
for i = 1 to 5
oAlter ="ALTER TABLE " & oTableName & " ADD ADDFIELD" & i & " VARCHAR(30)"
oStmt.executeUpdate(oAlter)
next i
'
oCon.Close()
oCon.dispose
'
' Display
msgbox "Success"
End Sub
Sub oSQL
'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
oStmt = oCon.createStatement()
' First Table
Dim oSQL11 as String
Dim oTableName1 as String
oTableName1 = "ADRESS" ' 大文字
oSQL11 = "CREATE TABLE " & oTableName1 & "(ID INTEGER IDENTITY,ADRESS varchar(20),TITLE varchar(20),NAME varchar(30), PRIMARY KEY (ID)) "
oStmt.execute(oSQL11)
'
' INSERT INTO句
Dim oSQL12 as String
Dim oValue1 as String
Dim i as Integer
for i = 1 to 100
oValue1 = "VALUES(" & i & ",'home" & i & "', 'Test" & i & "', 'New_OOo3" & "_" & i & "')"
oSQL12 = "INSERT INTO " & oTableName1 & "(ID, ADRESS, TITLE, NAME)" & " " & oValue1
oStmt.executeUpdate(oSQL12)
Next i
'
' Seconds Table
Dim oStmt2
oStmt2 = oCon.createStatement()
Dim oSQL21 as String
Dim oTableName2 as String
oTableName2 = "TEL" ' 大文字
oSQL21 = "CREATE TABLE " & oTableName2 & "(ID INTEGER IDENTITY,NAME varchar(30),TEL varchar(30)) "
oStmt2.execute(oSQL21)
'
' INSERT INTO句
Dim oSQL22 as String
Dim oValue2 as String
Dim oTel, oTail as String
for i = 1 to 100
If i < 10 then
oTail = "000" & i
else
If i < 100 then
oTail = "00" & i
else
oTail = "0" & i
End If
End If
oTel = "090-1234-" & oTail
oValue2 = "VALUES(" & i & ", 'New_OOo3" & "_" & i & "','" & oTel & "')"
oSQL22 = "INSERT INTO " & oTableName2 & "(ID, NAME, TEL)" & " " & oValue2
oStmt2.executeUpdate(oSQL22)
Next i
'
' JOIN
Dim oStm3 as String
oStmt3 = oCon.createStatement()
Dim oTableJoin as String
oTableJoin = "JOIN_TABLE"
' SELECT句
Dim oSelJoin as String
oSelJoin = "SELECT " & oTableName1 & ".ADRESS, " & oTableName1 & ".NAME, " & oTableName2 & ".TEL"
' FROM句
Dim oFromJoin as String
oFromJoin = " FROM " & oTableName1 & " LEFT JOIN " & oTableName2 & " ON " & oTableName1 & ".NAME = " & oTableName2 & ".NAME"
' SQL句
Dim oSQLJoin as String
oSQLJoin = oSelJoin & " INTO " & oTableJoin & oFromJoin
' SQL実行
oStmt3.execute(oSQLJoin)
'
oCon.Close()
oCon.dispose
'
' Display
msgbox "Success"
End Sub
' 連番(0から始まります。)はPrimary Keyにする必要があります。
Sub oSQL
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
Dim oSQL as String
Dim oTableName as String
oTableName = "ADRESS" ' 大文字
oStmt = oCon.createStatement()
oSQL = "CREATE TABLE " & oTableName & "(ADRESS varchar(5),TITLE varchar(10),NAME varchar(30)) "
oStmt.execute(oSQL)
'
' INSERT INTO句
Dim oSQL2 as String
Dim oValue as String
Dim i as Integer
for i = 1 to 100
oValue = "VALUES('home', 'Test" & i & "', 'New_OOo3')"
oSQL2 = "INSERT INTO " & oTableName & "(ADRESS, TITLE, NAME)" & " " & oValue
oStmt.executeUpdate(oSQL2)
Next i
'
' ALTER句
Dim oALTER as String
oAlter ="ALTER TABLE " & oTableName & " ADD NO INTEGER IDENTITY PRIMARY KEY"
oStmt.execute(oAlter)
'
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 oSQL
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
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
'
' SELECT句
Dim oSQL3 as String
Dim oTableName2 as String
oTableName2 = "NEW_ADDR"
oSQL3 = "SELECT *,ID + 10 as ID2 INTO " & oTableName2 & " FROM " & oTableName
oStmt.execute(oSQL3)
'
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 oColumnCount
On Error Goto oBad
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("Test")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt
Dim oSQL as String
Dim Result as Object
Dim oColNum as Long
oStmt = oCon.createStatement()
oSQL = "SELECT * FROM table1;" ' Table名は大文字/小文字を区別する。
oResult = oStmt.executeQuery(oSQL)
oColNum = oResult.getMetaData().ColumnCount
oDisp = "「table1」のColumn数(列数)は" & Chr$(10) & " " & oColNum & Chr$(10) & "です。"
msgbox(oDisp,0,"Column数の取得")
'
'Unconnect with the Datasource
oCon.close()
oCon.dispose
'
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 oSQL
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
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
'
' DELETE句
Dim oSQL3 as String
oSQL3 = "DELETE FROM " & oTableName & " WHERE ID IN( 31,32,35,37)"
oStmt.executeUpdate(oSQL3)
'
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 oSQL
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
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
'
' 任意の別Tableの作成
Dim oSQL3 as String
Dim oTableName2 as String
oTableName2 = "SELECT_ADRESS"
oSQL3 = "SELECT ID,NAME INTO " & oTableName2 & " FROM " & oTableName & " WHERE ID IN( 30,32,34,36,38)"
oStmt.execute(oSQL3)
'
' DELETE句
Dim oSQL4 as String
oSQL4 = "DELETE FROM " & oTableName & " WHERE ID IN(SELECT ID FROM " & oTableName2 & ")"
oStmt.executeUpdate(oSQL4)
'
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 oSQL
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
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
'
' DROP Column
Dim oSQL3 as String
oSQL3 = "ALTER TABLE " & oTableName & " ADD NEWCLOUMN varchar(20)"
oStmt.executeUpdate(oSQL3)
'
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 oSQL
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
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
'
' DROP Column
Dim oSQL3 as String
oSQL3 = "ALTER TABLE " & oTableName & " DROP TITLE"
oStmt.executeUpdate(oSQL3)
'
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 oSQL
On Error Goto oBad
'Create New Base Document
' HSQLDBの設定
Dim oDoc as Object
Dim oHsqlDbURL as String
oDoc = ThisComponent
oHsqlDbURL = oDoc.getURL()
'
' Connect DB
Dim oBaseContext as Object
Dim oHsqlDB as Object
Dim oHsqlCon as Object
Dim oStmt as Object
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oHsqlDB = oBaseContext.getByName(oHsqlDbURL)
oHsqlCon = oHsqlDB.getConnection("", "")
'
oStmt = oHsqlCon.createStatement()
'
' CREATE TABLE句
Dim oSQL1 as String
Dim oSQL2 as String
Dim oHsqlTb as String
' 既存Tableがあると削除する
oHsqlTb = "TEST"
oSQL1 = "DROP TABLE " & oHsqlTb & " IF EXISTS; "
oStmt.execute(oSQL1)
'
oSQL2 = "CREATE TABLE " & oHsqlTb & "(NO varchar(10), NAME varchar(50)) "
oStmt.execute(oSQL2)
'
' INSERT INTO句
Dim oSQL3 as String
Dim oValue as String
Dim i as Long
for i = 1 to 100
oValue = "VALUES(" & CStr(i) & ",'new_OOo3_" & i & "')"
oSQL3 = "INSERT INTO " & oHsqlTb & "(NO, NAME)" & " " & oValue
oStmt.executeUpdate(oSQL3)
Next i
'
' Export
Dim oCsvFile as String
Dim oSQLExpot as String
oCsvFile = "ExportTb3" ' Base Fileと同じDirectory( c:\temp ) に出力
'
' Export
oSQLExpot = "SELECT * INTO TEXT " & oCsvFile & " FROM " & oHsqlTb
oStmt.execute(oSQLExpot)
'
oHsqlCon.Close()
'
' Display
msgbox "Success"
Exit Sub
'
oBad:
oHsqlCon.Close()
'
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 oSQL_Export
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
Dim oTableName as String
oTableName = "ADRESS_TB" ' 大文字
oStmt = oCon.createStatement()
'
' Drop Tb
' Delete same name table.
Dim oSQL_Drop as String
oSQL_Drop = "DROP TABLE " & oTableName & " IF EXISTS; "
oStmt.execute(oSQL_Drop)
'
' Create Tb
Dim oSQL as String
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
'
' Export
Dim oCsvFile as String
Dim oSQLExpot as String
oCsvFile = "EXPORT_TB" ' Base Fileと同じDirectory( c:\temp ) に出力
'
' Export
' Delete same name table.
Dim oSQL_Drop02 as String
oSQL_Drop02 = "DROP TABLE " & oCsvFile & " IF EXISTS; "
oStmt.execute(oSQL_Drop02)
'
' Export Text Tb用のTemp Tb 作成
Dim oSQL_TmpCSV as String
oSQL_TmpCSV = "CREATE TEXT TABLE " & oCsvFile & "(ID INTEGER IDENTITY,ADRESS varchar(5),TITLE varchar(10),NAME varchar(30));"
oStmt.execute(oSQL_TmpCSV)
'
' Local の Text Tb と関連付けて Export
Dim oSetCSV as String
Dim oSQLExport as String
oSetCSV = "SET TABLE """ & oCsvFile & """ SOURCE """ & oCsvFile & ".csv;fs=\t;encoding='UTF-8'"""
oSQLExport = "INSERT INTO """ & oCsvFile & """ SELECT * FROM """ & oTableName & """;"
oStmt.execute(oSetCSV)
oStmt.execute(oSQLExport)
'
' Temp Tb の削除
oStmt.execute(oSQL_Drop02)
'
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
'
' [ 区切り文字 ]
' , : Comma
' | : 「 | 」
' \semi : semicolon
' \quote : single-quote
' \space : space character
' \apos : apostrophe
' \n : newline - Used as an end anchor (like $ in regular expressions)
' \r : carriage return
' \t : tab
' \\ : backslash
' \u#### : a Unicode character specified in hexadecimal
Sub oSQL_Import
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
Dim oTableName as String
oTableName = "IMPORT_TB" ' 大文字
oStmt = oCon.createStatement()
'
' Drop Tb
' Delete same name table.
Dim oSQL_Drop as String
oSQL_Drop = "DROP TABLE " & oTableName & " IF EXISTS; "
oStmt.execute(oSQL_Drop)
'
' Create Tb
Dim oSQL as String
oSQL = "CREATE TABLE " & oTableName & "(ID INTEGER IDENTITY,ADRESS varchar(5),TITLE varchar(10),NAME varchar(30), PRIMARY KEY (ID)) "
oStmt.execute(oSQL)
'
' Import
Dim oCsvFile as String
Dim oSQLExpot as String
oCsvFile = "TEMP_TB" ' Base Fileと同じDirectory( c:\temp ) に出力
'
' Imprt元のText Tbの有無確認
Dim oChkTxtFile as String
oChkTxtFile = "c:\temp\" & oCsvFile & ".csv"
If NOT FileExists(oChkTxtFile) then
oDisp = "Import元 Tb " & oChkTxtFile & "がありません"
msgbox oDisp,0,"Text Tb有無Check"
oCon.Close()
oCon.dispose
Exit Sub
end if
'
' Delete same name table.
Dim oSQL_Drop02 as String
oSQL_Drop02 = "DROP TABLE " & oCsvFile & " IF EXISTS; "
oStmt.execute(oSQL_Drop02)
'
' Import Text Tb用のTemp Tb 作成
Dim oSQL_TmpCSV as String
oSQL_TmpCSV = "CREATE TEXT TABLE " & oCsvFile & "(ID INTEGER IDENTITY,ADRESS varchar(5),TITLE varchar(10),NAME varchar(30));"
oStmt.execute(oSQL_TmpCSV)
'
' Local の Text Tb と関連付けて Import
Dim oSetCSV as String
Dim oSQLImprot as String
oSetCSV = "SET TABLE """ & oCsvFile & """ SOURCE """ & oCsvFile & ".csv;fs=\t;encoding='UTF-8'"""
oSQLImprot = "INSERT INTO """ & oTableName & """ SELECT * FROM """ & oCsvFile & """;"
oStmt.execute(oSetCSV)
oStmt.execute(oSQLImprot)
'
' Temp Tb の削除
oStmt.execute(oSQL_Drop02)
'
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 oSQL
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
'
' ****** [ Defrag ] ******
Dim oStmt as Object
Dim oSQLDefrag as String
oStmt = oCon.createStatement()
oSQLDefrag = "CHECKPOINT DEFRAG"
oStmt.execute(oSQLDefrag)
' *********************
'
'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
Form
[ Form Button ]
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
[ Create / Edit ]
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
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
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
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
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
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
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
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
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
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
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
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
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
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
Other
Sub oDatabaseVer
On Error Goto oBad
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("Test")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oVersion as String
oVersion = oCon.getMetaData().getDatabaseProductVersion()
oDisp = "本BaseのHSQLDBのVersionは" & Chr$(10) & " ver." & oVersion & Chr$(10) & "です。"
msgbox(oDisp,0,"HSQLDB Version")
'
'Unconnect with the Datasource
oCon.close()
oCon.dispose
'
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 oMySQL
On Error Goto oBad
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oVersion as String
oVersion = oCon.getMetaData().getDatabaseProductVersion()
oDisp = "本BaseのMySQLのVersionは" & Chr$(10) & " ver." & oVersion & Chr$(10) & "です。"
msgbox(oDisp,0,"MySQL Version")
'
'Unconnect with the Datasource
oCon.close()
oCon.dispose
'
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 Main
oForm = ThisComponent.DrawPage.Forms.getByName("MainForm")
oDoc = ThisComponent
oFrames = oDoc.getTextFrames()
oGraphics=oDoc.getGraphicObjects()
oFrame = oFrames.getByName( "枠1" )
oFrameCursor = oFrame.createTextCursor()
oFrameCursor.gotoStart( False )
'イメージコントロールとは異なり、現在表示されている画像を消す必要がある。
If oGraphics.hasByName( "グラフィックス1" ) Then
oGraphic=oGraphics.getByName( "グラフィックス1" )
oFrameCursor.text.removeTextContent(oGraphic)
EndIf
oGraphic = oDoc.createInstance("com.sun.star.text.GraphicObject")
oTxtbox = oForm.GetByName("txtFileName")
oPath = oForm.GetByName("Path")
oGraphic.GraphicURL= "file:///" + oPath.text + oTxtbox.text
oFrameCursor.text.insertTextContent(oFrameCursor, oGraphic, False)
oButton = oForm.GetByName("PushButton")
oButton.TargetURL = oGraphic.GraphicURL
End Sub
Sub oImageDataintoTable '(未完成)
'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"
'Get File URL
oTempName = oDoc.getURL()
'Load the Tools library
If NOT GlobalScope.BasicLibraries.isLibraryLoaded("Tools") Then
GlobalScope.BasicLibraries.LoadLibrary("Tools")
End If
'Pickup the FileName without 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(1)
'File Access
Dim oFileAccess
Dim oStream
oFileAccess = createUnoService( "com.sun.star.ucb.SimpleFileAccess")
oStream = oFileAccess.openFileRead(oTempName)
'Get Image Files and File Size[ Bytes ]
Dim oData
Dim oImageDir
Dim oImageFileName
Dim oLen
oImageDir = "c:\Temp\ImageForMacroTest\"
oImageDirURL = ConvertToURL(oImageDir)
oImageFileName = dir(oImageDirURL)
oData = StarDesktop(oImageDirURL & oImageFileName, "_defalut", 0, Dummy)
oData.dispose
'Document Change
oDoc.getCurrentController()
oLen = oStream.getLength()
oStream.readBytes(oData, oLen)
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
'Define Setted Items(ID, ImageFileName, FileSize, Image) in the Table. and Defaut TableValue of the Items are Empty.
'[ Note ] : To be define ITem Name and Format in the Table before Excuting Macro.
oSQL = "insert into" & " " & oTableName & " " & "(FILENAME, SIZE, IMAGE ) values (?, ?, ?)"
oStatement = oCon.PrepareStatement(oSQL)
'Add the TableValues
' oStatement.SetString(Column No , DataValue)
oIData = oImageDir & dir(oImageDirURL)
oStatement.setString( 1, oImageFileName)
oStatement.setString( 2, oFileByte)
oStatement.setBytes(3, oData, oLen)
'Execute the Query
oStatement.ExecuteUpdate()
oStream.closeInput()
'DataBaseとのConnect切断
oCon.close()
oDoc.close(true)
msgbox("Success")
End Sub
'
'[ Caution ] : TABLENAME And ITEM To be Capital Charactor!!.
MySQL[Base]
[ Table ]
Sub oMySQL
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt
Dim oSQL as String
oStmt = oCon.createStatement()
oSQL = "CREATE TABLE ADDRESS(ID INT(3),NAME VARCHAR(5),TITLE VARCHAR(10),PRIMARY KEY (ID)); "
oStmt.execute(oSQL)
msgbox "Success"
'Unconnect with the Datasource
oCon.close()
oCon.dispose
End Sub
Sub oMySQL
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt
Dim oSQL as String
oStmt = oCon.createStatement()
oSQL = "INSERT INTO ADDRESS(ID,NAME,TITLE) VALUE(1,'new_OOo3','MySQL_Base_Test'); "
oStmt.execute(oSQL)
msgbox "Success"
'Unconnect with the Datasource
oCon.close()
oCon.dispose
End Sub
Sub oMySQL
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt
Dim oSQL as String
Dim oValue as String
oStmt = oCon.createStatement()
oValue = "VALUE(2,'new_OOo3_2','MySQL_Base_Test_2'),(3,'new_OOo3_3','MySQL_Base_Test_3')"
oSQL = "INSERT INTO ADDRESS(ID,NAME,TITLE) " & oValue & "; "
oStmt.execute(oSQL)
msgbox "Success"
'Unconnect with the Datasource
oCon.close()
oCon.dispose
End Sub
Sub oMySQL
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt
Dim oSQL as String
oStmt = oCon.createStatement()
oSQL = "DELETE FROM ADDRESS; "
oStmt.execute(oSQL)
msgbox "Success"
'Unconnect with the Datasource
oCon.close()
oCon.dispose
End Sub
Note : Delete Fromとの違いはTableを一度破棄した後に再作成する。
トランザクションがActiveな場合はErrorになる。
Sub oMySQL
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt
Dim oSQL as String
oStmt = oCon.createStatement()
oSQL = "TRUNCATE name_table; "
oStmt.execute(oSQL)
msgbox "Success"
'Unconnect with the Datasource
oCon.close()
oCon.dispose
End Sub
Sub oMySQL
On Error Goto oBad
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt
Dim oSQL as String
oStmt = oCon.createStatement()
oSQL = "DELETE FROM ADDRESS WHERE ID IN(2,5,6,9); "
oStmt.execute(oSQL)
msgbox "Success"
'Unconnect with the Datasource
oCon.close()
oCon.dispose
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 oMySQL
On Error Goto oBad
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
'
' 抽出して新しいTableを作成
Dim oStmt
Dim oNewTable as String
Dim oField as String
Dim oFrom as String
Dim oSQLTable as String
oStmt = oCon.createStatement()
oNewTable = "NAME_TABLE"
oField = " AS SELECT ID, NAME"
oFrom = " FROM ADDRESS WHERE (ID LIKE '2%');"
oSQLTable = "CREATE TABLE " & oNewTable & oField & oFrom
oStmt.execute(oSQLTable)
'
' 新規に抽出･作成したTableを利用してDataを削除
Dim oSQL2 as String
oSQL2 = "DELETE FROM ADDRESS WHERE ID IN(SELECT ID FROM " & oNewTable & "); "
oStmt.execute(oSQL2)
'
msgbox "Success"
'Unconnect with the Datasource
oCon.close()
oCon.dispose
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 oMySQL
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt
Dim oSQL as String
oStmt = oCon.createStatement()
oSQL = "LOAD DATA LOCAL INFILE 'C:/Temp/MySQL_CSV.csv' INTO TABLE ADDRESS FIELDS TERMINATED BY ',' LINES TERMINATED BY '\r\n'; "
oStmt.execute(oSQL)
msgbox "Success"
'Unconnect with the Datasource
oCon.close()
oCon.dispose
End Sub
Sub oMySQL
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt
Dim oNewTable as String
Dim oField as String
Dim oSQLTable, oSQLSelect as String
oStmt = oCon.createStatement()
oNewTable = "NAME_TABLE"
oField = "(NAME VARCHAR(30));"
oSQLTable = "CREATE TABLE " & oNewTable & oField
oStmt.execute(oSQLTable)
'
oSQLSelect = "INSERT INTO " & oNewTable & " SELECT NAME FROM ADDRESS; "
oStmt.execute(oSQLSelect)
msgbox "Success"
'Unconnect with the Datasource
oCon.close()
oCon.dispose
End Sub
Sub oMySQL
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt
Dim oNewTable as String
Dim oField as String
Dim oFrom as String
Dim oSQLTable as String
oStmt = oCon.createStatement()
oNewTable = "NAME_TABLE"
oField = " AS SELECT NAME, TITLE"
oFrom = " FROM ADDRESS WHERE (NAME LIKE '%20');"
oSQLTable = "CREATE TABLE " & oNewTable & oField & oFrom
oStmt.execute(oSQLTable)
'
msgbox "Success"
'Unconnect with the Datasource
oCon.close()
oCon.dispose
End Sub
Sub oMySQL
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt
Dim oSQL as String
oStmt = oCon.createStatement()
oSQL = "DROP TABLE IF EXISTS NAME_TABLE; "
oStmt.execute(oSQL)
msgbox "Success"
'Unconnect with the Datasource
oCon.close()
oCon.dispose
End Sub
Sub oMySQL
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt
Dim oSQL as String
oStmt = oCon.createStatement()
oSQL = "ALTER TABLE ADDRESS ADD TEL varchar(30); "
oStmt.execute(oSQL)
msgbox "Success"
'Unconnect with the Datasource
oCon.close()
oCon.dispose
End Sub
Sub oMySQL
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt
Dim oSQL as String
oStmt = oCon.createStatement()
oSQL = "ALTER TABLE ADDRESS ADD FIRSTCOL varchar(30) FIRST; "
oStmt.execute(oSQL)
msgbox "Success"
'Unconnect with the Datasource
oCon.close()
oCon.dispose
End Sub
Sub oMySQL
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt
Dim oSQL as String
oStmt = oCon.createStatement()
oSQL = "ALTER TABLE ADDRESS ADD AGE INT AFTER NAME; "
oStmt.execute(oSQL)
msgbox "Success"
'Unconnect with the Datasource
oCon.close()
oCon.dispose
End Sub
Sub oMySQL
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt
Dim oSQL as String
oStmt = oCon.createStatement()
oSQL = "ALTER TABLE ADDRESS ADD 性別 VARCHAR(5) NOT Null Default '男' AFTER AGE; "
oStmt.execute(oSQL)
msgbox "Success"
'Unconnect with the Datasource
oCon.close()
oCon.dispose
End Sub
Sub oMySQL
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt
Dim oSQL as String
oStmt = oCon.createStatement()
oSQL = "ALTER TABLE ADDRESS DROP COLUMN FIRSTCOL; "
oStmt.execute(oSQL)
msgbox "Success"
'Unconnect with the Datasource
oCon.close()
oCon.dispose
End Sub
Sub oMySQL
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt
Dim oNewTable as String
Dim oField as String
Dim oSQLTable, oSQLSelect as String
oStmt = oCon.createStatement()
oNewTable = "DISTINCT_TABLE"
oField = "(NAME VARCHAR(30), 性別 VARCHAR(5));"
oSQLTable = "CREATE TABLE " & oNewTable & oField
oStmt.execute(oSQLTable)
'
oSQLSelect = "INSERT INTO " & oNewTable & " SELECT DISTINCT NAME, 性別 FROM ADDRESS; "
oStmt.execute(oSQLSelect)
msgbox "Success"
'Unconnect with the Datasource
oCon.close()
oCon.dispose
End Sub
Sub oMySQL
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
' First Table
Dim oStmt1
oStmt1 = oCon.createStatement()
Dim oSQL11 as String
Dim oTableName1 as String
oTableName1 = "ADRESS" ' 大文字
oSQL11 = "CREATE TABLE " & oTableName1 & "(ID INT(3),ADRESS varchar(20),TITLE varchar(20),NAME varchar(30),PRIMARY KEY (ID)); "
oStmt1.execute(oSQL11)
'
' INSERT INTO句
Dim oSQL12 as String
Dim oValue1 as String
Dim i as Integer
for i = 1 to 100
oValue1 = "VALUE(" & i & ",'home" & i & "', 'Test" & i & "', 'New_OOo3" & "_" & i & "');"
oSQL12 = "INSERT INTO " & oTableName1 & "(ID, ADRESS, TITLE, NAME)" & " " & oValue1
oStmt1.executeUpdate(oSQL12)
Next i
' Seconds Table
Dim oStmt2
oStmt2 = oCon.createStatement()
Dim oSQL21 as String
Dim oTableName2 as String
oTableName2 = "TEL" ' 大文字
oSQL21 = "CREATE TABLE " & oTableName2 & "(ID INT(3),NAME varchar(30),TEL varchar(30)) "
oStmt2.execute(oSQL21)
' INSERT INTO句
Dim oSQL22 as String
Dim oValue2 as String
Dim oTel, oTail as String
for i = 1 to 100
If i < 10 then
oTail = "000" & i
else
If i < 100 then
oTail = "00" & i
else
oTail = "0" & i
End If
End If
oTel = "090-1234-" & oTail
oValue2 = "VALUE(" & i & ", 'New_OOo3" & "_" & i & "','" & oTel & "');"
oSQL22 = "INSERT INTO " & oTableName2 & "(ID, NAME, TEL)" & " " & oValue2
oStmt2.executeUpdate(oSQL22)
Next i
' JOIN Ｔａｂｌｅ
Dim oStmt3
oStmt3 = oCon.createStatement()
Dim oSQL31 as String
Dim oTableName3 as String
oTableName3 = "JOIN_TABLE" ' 大文字
oSQL31 = "CREATE TABLE " & oTableName3 & "(ID INT(3),NAME varchar(30),TEL varchar(30)) "
oStmt3.execute(oSQL31)
' SELECT句
Dim oSelJoin as String
oSelJoin = " SELECT " & oTableName1 & ".ID," & oTableName1 & ".NAME, " & oTableName2 & ".TEL"
' FROM句
Dim oFromJoin as String
oFromJoin = " FROM " & oTableName1 & " LEFT JOIN " & oTableName2 & " ON " & oTableName1 & ".NAME = " & oTableName2 & ".NAME;"
' SQL句
Dim oSQLJoin as String
oSQLJoin = "INSERT INTO " & oTableName3 & oSelJoin & oFromJoin
' SQL実行
oStmt3.execute(oSQLJoin)
msgbox "Success"
'Unconnect with the Datasource
oCon.close()
oCon.dispose
End Sub
Sub oMySQL
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt
Dim oNewTable as String
Dim oField as String
Dim oSQLTable, oSQLSelect as String
Dim oWhere as String
oStmt = oCon.createStatement()
oNewTable = "NAME_TABLE"
oField = "(ID INT(3),NAME VARCHAR(30),TITLE VARCHAR(30));"
oSQLTable = "CREATE TABLE " & oNewTable & oField
oStmt.execute(oSQLTable)
'
oWhere = " WHERE NAME = 'new_OOo3_10' and ID = 10 ORDER BY ID;"
oSQLSelect = "INSERT INTO " & oNewTable & " SELECT ADDRESS.ID, ADDRESS.NAME, ADDRESS.TITLE FROM ADDRESS" & oWhere
oStmt.execute(oSQLSelect)
msgbox "Success"
'Unconnect with the Datasource
oCon.close()
oCon.dispose
End Sub
Sub oMySQL
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt
Dim oNewTable as String
Dim oField as String
Dim oSQLTable, oSQLSelect as String
Dim oWhere as String
oStmt = oCon.createStatement()
oNewTable = "NAME_TABLE"
oField = "(ID INT(3),NAME VARCHAR(30),TITLE VARCHAR(30));"
oSQLTable = "CREATE TABLE " & oNewTable & oField
oStmt.execute(oSQLTable)
'
oWhere = " WHERE (NAME = 'new_OOo3_10' and ID = 10) or (ID = 20) ORDER BY ID;"
oSQLSelect = "INSERT INTO " & oNewTable & " SELECT ADDRESS.ID, ADDRESS.NAME, ADDRESS.TITLE FROM ADDRESS" & oWhere
oStmt.execute(oSQLSelect)
msgbox "Success"
'Unconnect with the Datasource
oCon.close()
oCon.dispose
End Sub
Sub oMySQL
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt
Dim oNewTable as String
Dim oField as String
Dim oSQLTable, oSQLSelect as String
Dim oWhere as String
oStmt = oCon.createStatement()
oNewTable = "NAME_TABLE"
oField = "(ID INT(3),NAME VARCHAR(30),TITLE VARCHAR(30));"
oSQLTable = "CREATE TABLE " & oNewTable & oField
oStmt.execute(oSQLTable)
'
oWhere = " WHERE (NAME LIKE '%20') or (TITLE LIKE '%Base_1%') ORDER BY ID;"
oSQLSelect = "INSERT INTO " & oNewTable & " SELECT ADDRESS.ID, ADDRESS.NAME, ADDRESS.TITLE FROM ADDRESS" & oWhere
oStmt.execute(oSQLSelect)
msgbox "Success"
'Unconnect with the Datasource
oCon.close()
oCon.dispose
End Sub
Sub oMySQL
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt
Dim oNewTable1, oNewTable2 as String
Dim oField as String
Dim oFrom1, oFrom2 as String
Dim oSQLTable1, oSQLTable2 as String
oStmt = oCon.createStatement()
oNewTable1 = "NAME_TABLE1"
oField = " AS SELECT NAME, TITLE"
oFrom1 = " FROM ADDRESS WHERE (NAME LIKE '%2%');"
oSQLTable1 = "CREATE TABLE " & oNewTable1 & oField & oFrom1
oStmt.execute(oSQLTable1)
'
oNewTable2 = "NAME_TABLE2"
oField = " AS SELECT NAME, TITLE"
oFrom2 = " FROM ADDRESS WHERE (NAME LIKE '%20');"
oSQLTable2 = "CREATE TABLE " & oNewTable2 & oField & oFrom2
oStmt.execute(oSQLTable2)
' UNION句
Dim oCraeteUnion as String
Dim oUnionTable as String
Dim oUnionField as String
Dim oFromUnion as String
Dim oSQLUnion as String
oUnionTable = "UnionTable"
oUnionField = "(NAME VARCHAR(30), TITLE VARCHAR(30));"
oCraeteTable = "CREATE TABLE " & oUnionTable & oUnionField
oStmt.execute(oCraeteTable)
'
oFromUnion = " SELECT NAME, TITLE FROM " & oNewTable1 & " UNION SELECT NAME, TITLE FROM " & oNewTable2 & ";"
oSQLUnion = "INSERT INTO " & oUnionTable & oFromUnion
oStmt.execute(oSQLUnion)
msgbox "Success"
'Unconnect with the Datasource
oCon.close()
oCon.dispose
End Sub
Sub oMySQL
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt
Dim oNewTable1, oNewTable2 as String
Dim oField as String
Dim oFrom1, oFrom2 as String
Dim oSQLTable1, oSQLTable2 as String
oStmt = oCon.createStatement()
oNewTable1 = "NAME_TABLE1"
oField = " AS SELECT NAME, TITLE"
oFrom1 = " FROM ADDRESS WHERE (NAME LIKE '%2%');"
oSQLTable1 = "CREATE TABLE " & oNewTable1 & oField & oFrom1
oStmt.execute(oSQLTable1)
'
oNewTable2 = "NAME_TABLE2"
oField = " AS SELECT NAME, TITLE"
oFrom2 = " FROM ADDRESS WHERE (NAME LIKE '%20');"
oSQLTable2 = "CREATE TABLE " & oNewTable2 & oField & oFrom2
oStmt.execute(oSQLTable2)
' UNION句
Dim oCraeteUnion as String
Dim oUnionTable as String
Dim oUnionField as String
Dim oFromUnion as String
Dim oSQLUnion as String
oUnionTable = "UnionTable"
oUnionField = "(NAME VARCHAR(30), TITLE VARCHAR(30));"
oCraeteTable = "CREATE TABLE " & oUnionTable & oUnionField
oStmt.execute(oCraeteTable)
'
oFromUnion = " SELECT NAME, TITLE FROM " & oNewTable1 & " UNION ALL SELECT NAME, TITLE FROM " & oNewTable2 & ";"
oSQLUnion = "INSERT INTO " & oUnionTable & oFromUnion
oStmt.execute(oSQLUnion)
msgbox "Success"
'Unconnect with the Datasource
oCon.close()
oCon.dispose
End Sub
Note : 追加するColumnはPrimary Keyである必要がある。
Sub oMySQL
Dim oBaseContext
Dim oUser$
Dim oPass$
oUser = ""
oPass = ""
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
' Connect with the DataSource
Dim oDataSource
Dim oCon
oDataSource = oBaseContext.getByName("MySQL_local")
oCon = oDataSource.getConnection(oUser, oPass)
Dim oStmt
Dim oSQL as String
oStmt = oCon.createStatement()
oSQL = "ALTER TABLE ADDRESS ADD NO int8 unsigned not null auto_increment primary key; "
oStmt.execute(oSQL)
msgbox "Success"
'Unconnect with the Datasource
oCon.close()
oCon.dispose
End Sub
Sub oBase_TableName
Dim db As Object
Dim oBase as String
oBase ="MySQL_ooobase"
db = connect_to_database(oBase)
omysql(db, oBase)
disconnect_from_database(db)
End Sub
'[ Sub Routine1 ]
Sub disconnect_from_database ( db as Object)
db.close
db.dispose()
End Sub
'[ Sub Routine2 ]
Sub omysql(db as Object, oBName)
Dim dbTables As Object
Dim dbTableNames
Dim opText As String
Dim oLen
Dim oDBLen
Dim oDBName
Dim oPreDB
Dim oTableName
Globalscope.BasicLibraries.LoadLibrary( "MRILib" )
dbTables=db.getTables
dbTableNames=dbTables.getElementNames
oDBName = ""
oTableName =""
oPreDB = ""
oDisp = "Base File Name => " & oBName & ".odb" & Chr$(10) & Chr$(10)
for i = 0 to UBound(dbTableNames)
'DB Name と Table Nameの分離
oLen = Len(dbTableNames(i))
oDBLen = InStr(1, dbTableNames(i), ".")
oDBName = Left(dbTableNames(i), oDBLen-1)
oTableName = Right(dbTableNames(i), oLen-oDBLen)
If oDBName <> oDBName then
oDisp = oDisp & " MySQL Table Name => " & oTableName
else
oDisp = oDisp & "MySQL DB Name => " & oDBName & Chr$(10) & _
" MySQL Table Name => " & oTableName
End If
next i
msgbox (oDisp, 0, "Base - MySQL")
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
MS-ACCESS[Base]
Sub oMsAccess
On Error Goto oBad
Dim oDriveManager
Dim oCon
Dim oURL as String
Dim oAccessFile, oAccessURL as String
oAccessFile = "c:\temp\ACCESS_SQL2003.mdb"
'
oAccessURL = ConvertToUrl(oAccessFile)
If NOT FileExists(oAccessURL) then
MsgBox( oAccessFile & " は存在しません", 0, "Caution !!")
Exit Sub
End If
'
oURL = "sdbc:ado:PROVIDER=Microsoft.Jet.OLEDB.4.0;DATA SOURCE=" & oAccessFile
'
oDriverManager = CreateUnoService("com.sun.star.sdbc.DriverManager")
oCon = oDriverManager.getConnection(oURL)
'
oCon.Close
'
' Display
oDisp = "File Name => " & oAccessFile & Chr$(10) & "への接続に成功しました。"
msgbox oDisp,0,"Base-Access"
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
End Sub
Sub oMsAccess
On Error Goto oBad
Dim oDriveManager
Dim oCon
Dim oURL as String
Dim oAccessFile, oAccessURL as String
oAccessFile = "c:\temp\ACCESS_SQL.accdb" ' <= MS-Access2007形式
'
oAccessURL = ConvertToUrl(oAccessFile)
If NOT FileExists(oAccessURL) then
MsgBox( oAccessFile & " は存在しません", 0, "Caution !!")
Exit Sub
End If
'
oURL = "sdbc:ado:PROVIDER=Microsoft.ACE.OLEDB.12.0;DATA SOURCE=" & oAccessFile
'
oDriverManager = CreateUnoService("com.sun.star.sdbc.DriverManager")
oCon = oDriverManager.getConnection(oURL)
'
oCon.Close
'
' Display
oDisp = "File Name => " & oAccessFile & Chr$(10) & "への接続に成功しました。"
msgbox oDisp,0,"Base-Access"
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
End Sub
Sub oMsAccess
On Error Goto oBad
Dim oDriveManager
Dim oDriver
Dim oCon
Dim oURL as String
Dim oAccessFile, oAccessURL as String
Dim oParams(0) as New com.sun.star.beans.PropertyValue
Dim oAccessTables
Dim oDisp as String
'
oAccessFile = "c:\temp\ACCESS_SQL2003.mdb"
'
oAccessURL = ConvertToUrl(oAccessFile)
If NOT FileExists(oAccessURL) then
MsgBox( oAccessFile & " は存在しません", 0, "Caution !!")
Exit Sub
End If
'
oParams(0).Name = ""
oParams(0).Value = ""
'
oURL = "sdbc:ado:PROVIDER=Microsoft.Jet.OLEDB.4.0;DATA SOURCE=" & oAccessFile
'
oDriverManager = CreateUnoService("com.sun.star.sdbc.DriverManager")
'
oDriver = oDriverManager.getDriverByURL(oURL)
oAccessTables= oDriver.getDataDefinitionByURL(oURL, oParams()).Tables
'
If oAccessTables.Count = 0 then
oDisp = "File Name => " & oAccessFile & Chr$(10) & "にはTableがありません。"
msgbox oDisp,0,"Tableがありません"
Exit Sub
End If
'
Dim oTable as Object
oDisp = "[ File Name ]" & Chr$(10) & oAccessFile & Chr$(10) & Chr$(10) & "** [ 含まれるTable Name ] **" & Chr$(10)
for i= 0 to oAccessTables.Count-1
oTable = oAccessTables.getByIndex(i)
oDisp = oDisp & i+1 & ")" & oTable.Name & Chr$(10)
next i
'
' Display
msgbox oDisp,0,"Base-Access"
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
End Sub
Sub oMsAccess2007
On Error Goto oBad
Dim oDriveManager
Dim oDriver
Dim oCon
Dim oURL as String
Dim oAccessFile, oAccessURL as String
Dim oParams(0) as New com.sun.star.beans.PropertyValue
Dim oAccessTables
Dim oDisp as String
'
oAccessFile = "c:\temp\ACCESS_SQL.accdb"
'
oAccessURL = ConvertToUrl(oAccessFile)
If NOT FileExists(oAccessURL) then
MsgBox( oAccessFile & " は存在しません", 0, "Caution !!")
Exit Sub
End If
'
oParams(0).Name = ""
oParams(0).Value = ""
'
oURL = "sdbc:ado:PROVIDER=Microsoft.ACE.OLEDB.12.0;DATA SOURCE=" & oAccessFile
'
oDriverManager = CreateUnoService("com.sun.star.sdbc.DriverManager")
'
oDriver = oDriverManager.getDriverByURL(oURL)
oAccessTables= oDriver.getDataDefinitionByURL(oURL, oParams()).Tables
'
If oAccessTables.Count = 0 then
oDisp = "File Name => " & oAccessFile & Chr$(10) & "にはTableがありません。"
msgbox oDisp,0,"Tableがありません"
Exit Sub
End If
'
Dim oTable as Object
oDisp = "[ File Name ]" & Chr$(10) & oAccessFile & Chr$(10) & Chr$(10) & "** [ 含まれるTable Name ] **" & Chr$(10)
for i= 0 to oAccessTables.Count-1
oTable = oAccessTables.getByIndex(i)
oDisp = oDisp & i+1 & ")" & oTable.Name & Chr$(10)
next i
'
' Display
msgbox oDisp,0,"Base-Access"
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
End Sub
Sub oMsAccess
On Error Goto oBad
Dim oDriveManager
Dim oDriver
Dim oURL as String
Dim oAccessFile, oAccessURL as String
Dim oParams(0) as New com.sun.star.beans.PropertyValue
Dim oAccessTables
Dim oDisp as String
'
oAccessFile = "c:\temp\ACCESS_SQL2003.mdb"
'
oAccessURL = ConvertToUrl(oAccessFile)
If NOT FileExists(oAccessURL) then
MsgBox( oAccessFile & " は存在しません", 0, "Caution !!")
Exit Sub
End If
'
oParams(0).Name = ""
oParams(0).Value = ""
'
oURL = "sdbc:ado:PROVIDER=Microsoft.Jet.OLEDB.4.0;DATA SOURCE=" & oAccessFile
'
oDriverManager = CreateUnoService("com.sun.star.sdbc.DriverManager")
'
oDriver = oDriverManager.getDriverByURL(oURL)
oAccessTables= oDriver.getDataDefinitionByURL(oURL, oParams()).Tables
'
Dim oTable as Object
Dim oTableName as String
oTable = oAccessTables.getByIndex(0)
oTableName = oTable.Name
'
' Connect
Dim oCon as Object
Dim oStmt as Object
oCon = oDriverManager.getConnection(oURL)
oStmt = oCon.createStatement()
'
' ResultSet
Dim oSQL1 as String
Dim oRS as Object
Dim oLastRowNo, oFirstRowNo, oPreviousRow, oNextRow as Long
'
oStmt.ResultSetType = com.sun.star.sdbc.ResultSetType.SCROLL_INSENSITIVE
oSQL1 = "SELECT * FROM " & oTableName
oRS = oStmt.executeQuery(oSQL1)
'
oDisp = "File Name : " & oAccessFile & Chr$(10) & "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
'
' Close
oCon.close
'
oDisp = oDisp & "最後のRow No => " & oLastRowNo & Chr$(10) & _
"前のRow No => " & oPreviousRow & Chr$(10) & _
"最初のRow No => " & oFirstRowNo & Chr$(10) & _
"次のRow No => " & oNextRow
' Display
msgbox oDisp,0,"Tableの行No"
'
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
End Sub
Sub oMsAccess
On Error Goto oBad
Dim oDriveManager
Dim oDriver
Dim oURL as String
Dim oAccessFile, oAccessURL as String
Dim oParams(0) as New com.sun.star.beans.PropertyValue
Dim oAccessTables
Dim oDisp as String
'
oAccessFile = "c:\temp\ACCESS_SQL.accdb"
'
oAccessURL = ConvertToUrl(oAccessFile)
If NOT FileExists(oAccessURL) then
MsgBox( oAccessFile & " は存在しません", 0, "Caution !!")
Exit Sub
End If
'
oParams(0).Name = ""
oParams(0).Value = ""
'
oURL = "sdbc:ado:PROVIDER=Microsoft.ACE.OLEDB.12.0;DATA SOURCE=" & oAccessFile
'
oDriverManager = CreateUnoService("com.sun.star.sdbc.DriverManager")
'
oDriver = oDriverManager.getDriverByURL(oURL)
oAccessTables= oDriver.getDataDefinitionByURL(oURL, oParams()).Tables
'
Dim oTable as Object
Dim oTableName as String
oTable = oAccessTables.getByIndex(0)
oTableName = oTable.Name
'
' Connect
Dim oCon as Object
Dim oStmt as Object
oCon = oDriverManager.getConnection(oURL)
oStmt = oCon.createStatement()
'
' ResultSet
Dim oSQL1 as String
Dim oRS as Object
Dim oLastRowNo, oFirstRowNo, oPreviousRow, oNextRow as Long
'
oStmt.ResultSetType = com.sun.star.sdbc.ResultSetType.SCROLL_INSENSITIVE
oSQL1 = "SELECT * FROM " & oTableName
oRS = oStmt.executeQuery(oSQL1)
'
oDisp = "File Name : " & oAccessFile & Chr$(10) & "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
'
' Close
oCon.close
'
oDisp = oDisp & "最後のRow No => " & oLastRowNo & Chr$(10) & _
"前のRow No => " & oPreviousRow & Chr$(10) & _
"最初のRow No => " & oFirstRowNo & Chr$(10) & _
"次のRow No => " & oNextRow
' Display
msgbox oDisp,0,"Tableの行No"
'
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
End Sub
Sub oMsAccess
On Error Goto oBad
Dim oDriveManager
Dim oDriver
Dim oURL as String
Dim oAccessFile, oAccessURL as String
Dim oParams(0) as New com.sun.star.beans.PropertyValue
Dim oAccessTables
Dim oDisp as String
'
oAccessFile = "c:\temp\ACCESS_SQL2003.mdb"
'
oAccessURL = ConvertToUrl(oAccessFile)
If NOT FileExists(oAccessURL) then
MsgBox( oAccessFile & " は存在しません", 0, "Caution !!")
Exit Sub
End If
'
oParams(0).Name = ""
oParams(0).Value = ""
'
oURL = "sdbc:ado:PROVIDER=Microsoft.Jet.OLEDB.4.0;DATA SOURCE=" & oAccessFile
'
oDriverManager = CreateUnoService("com.sun.star.sdbc.DriverManager")
'
oDriver = oDriverManager.getDriverByURL(oURL)
oAccessTables= oDriver.getDataDefinitionByURL(oURL, oParams()).Tables
'
Dim oTable as Object
Dim oTableName as String
oTable = oAccessTables.getByIndex(0)
oTableName = oTable.Name
'
' Connect
Dim oCon as Object
Dim oStmt as Object
oCon = oDriverManager.getConnection(oURL)
oStmt = oCon.createStatement()
'
' ResultSet
Dim oSQL1 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
oSQL1 = "SELECT * FROM " & oTableName
oRS = oStmt.executeQuery(oSQL1)
'
oDisp = "File : " & oAccessFile & Chr$(10) & "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(5)
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(-2)
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
'
' Display
msgbox(oDisp,0,"ResultSet Service")
'
oCon.Close()
'
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
End Sub
Sub oMsAccess
On Error Goto oBad
Dim oDriveManager
Dim oDriver
Dim oURL as String
Dim oAccessFile, oAccessURL as String
Dim oParams(0) as New com.sun.star.beans.PropertyValue
Dim oAccessTables
Dim oDisp as String
'
oAccessFile = "c:\temp\ACCESS_SQL.accdb"
'
oAccessURL = ConvertToUrl(oAccessFile)
If NOT FileExists(oAccessURL) then
MsgBox( oAccessFile & " は存在しません", 0, "Caution !!")
Exit Sub
End If
'
oParams(0).Name = ""
oParams(0).Value = ""
'
oURL = "sdbc:ado:PROVIDER=Microsoft.ACE.OLEDB.12.0;DATA SOURCE=" & oAccessFile
'
oDriverManager = CreateUnoService("com.sun.star.sdbc.DriverManager")
'
oDriver = oDriverManager.getDriverByURL(oURL)
oAccessTables= oDriver.getDataDefinitionByURL(oURL, oParams()).Tables
'
Dim oTable as Object
Dim oTableName as String
oTable = oAccessTables.getByIndex(0)
oTableName = oTable.Name
'
' Connect
Dim oCon as Object
Dim oStmt as Object
oCon = oDriverManager.getConnection(oURL)
oStmt = oCon.createStatement()
'
' ResultSet
Dim oSQL1 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
oSQL1 = "SELECT * FROM " & oTableName
oRS = oStmt.executeQuery(oSQL1)
'
oDisp = "File : " & oAccessFile & Chr$(10) & "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(5)
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(-2)
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
'
' Display
msgbox(oDisp,0,"ResultSet Service")
'
oCon.Close()
'
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
End Sub
Sub oMsAccess
On Error Goto oBad
Dim oDriveManager
Dim oDriver
Dim oURL as String
Dim oAccessFile, oAccessURL as String
Dim oParams(0) as New com.sun.star.beans.PropertyValue
Dim oAccessTables
Dim oDisp as String
'
oAccessFile = "c:\temp\ACCESS_SQL2003.mdb"
'
oAccessURL = ConvertToUrl(oAccessFile)
If NOT FileExists(oAccessURL) then
MsgBox( oAccessFile & " は存在しません", 0, "Caution !!")
Exit Sub
End If
'
oParams(0).Name = ""
oParams(0).Value = ""
'
oURL = "sdbc:ado:PROVIDER=Microsoft.Jet.OLEDB.4.0;DATA SOURCE=" & oAccessFile
'
oDriverManager = CreateUnoService("com.sun.star.sdbc.DriverManager")
'
oDriver = oDriverManager.getDriverByURL(oURL)
oAccessTables= oDriver.getDataDefinitionByURL(oURL, oParams()).Tables
'
Dim oTable as Object
Dim oTableName as String
oTable = oAccessTables.getByIndex(0)
oTableName = oTable.Name
'
' Connect
Dim oCon as Object
Dim oStmt as Object
oCon = oDriverManager.getConnectionWithInfo(oURL,oParams())
oStmt = oCon.createStatement()
'
Dim oMetaData as Object
Dim oStrQuote as String
oMetaData = oCon.getMetaData()
oStrQuote = oMetaData.getIdentifierQuoteString() ' <= 「 ' 」を取得
'
Dim oSQL1 as String
Dim oRS as Object
oSQL1 = "SELECT * FROM " & oStrQuote & oTableName & oStrQuote
oRS = oStmt.executeQuery(oSQL1)
'
Dim oTableMeta as Object
Dim oColNum as Long
oTableMeta = oRS.getMetaData()
oColNum = oTableMeta.ColumnCount()
oDisp =""
for i = 1 to oColNum
oDisp = oDisp & "[ Column No." & i & " ]" & Chr$(10)
oDisp = oDisp & "Column Name => " & Chr$(9) & oTableMeta.getColumnName(i) & Chr$(10)
oDisp = oDisp & "Column Label =>" & Chr$(9) & oTableMeta.getColumnLabel(i) & Chr$(10)
oDisp = oDisp & "DisplaySize =>" & Chr$(9) & oTableMeta.getColumnDisplaySize(i) & Chr$(10)
oDisp = oDisp & "ColumnType =>" & Chr$(9) & oTableMeta.getColumnType(i) & Chr$(10)
oDisp = oDisp & "ColumnTypeName =>" & Chr$(9) & oTableMeta.getColumnTypeName(i) & Chr$(10)
oDisp = oDisp & "Precision =>" & Chr$(9) & oTableMeta.getPrecision(i) & Chr$(10)
oDisp = oDisp & "Scale =>" & Chr$(9) & oTableMeta.getScale(i) & Chr$(10)
oDisp = oDisp & "Table Name =>" & Chr$(9) & oTableMeta.getTableName(i) & Chr$(10)
oDisp = oDisp & "SchemaName =>" & Chr$(9) & oTableMeta.getSchemaName(i) & Chr$(10)
oDisp = oDisp & "IsAutoIncrement =>" & Chr$(9) & oTableMeta.isAutoIncrement(i) & Chr$(10)
oDisp = oDisp & "IsCaseSensitive =>" & Chr$(9) & oTableMeta.isCaseSensitive(i) & Chr$(10)
oDisp = oDisp & "IsCurrency =>" & Chr$(9) & oTableMeta.isCurrency(i) & Chr$(10)
oDisp = oDisp & "IsNullable =>" & Chr$(9) & oTableMeta.isNullable(i) & Chr$(10)
oDisp = oDisp & Chr$(10)
next i
msgbox oDisp,0,"Column情報"
'
oRS = Nothing
'
oCon.Close
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
End Sub
Sub oMsAccess
On Error Goto oBad
Dim oDriveManager
Dim oDriver
Dim oURL as String
Dim oAccessFile, oAccessURL as String
Dim oParams(0) as New com.sun.star.beans.PropertyValue
Dim oAccessTables
Dim oDisp as String
Dim oProvider as String
'
oAccessFile = "c:\temp\ACCESS_SQL2003.mdb"
'
oAccessURL = ConvertToUrl(oAccessFile)
If NOT FileExists(oAccessURL) then
MsgBox( oAccessFile & " は存在しません", 0, "Caution !!")
Exit Sub
End If
'
oParams(0).Name = ""
oParams(0).Value = ""
'
oProvider = "PROVIDER=Microsoft.Jet.OLEDB.4.0;DATA SOURCE="
oURL = "sdbc:ado:" & oProvider & oAccessFile
'
oDriverManager = CreateUnoService("com.sun.star.sdbc.DriverManager")
'
oDriver = oDriverManager.getDriverByURL(oURL)
oAccessTables= oDriver.getDataDefinitionByURL(oURL, oParams()).Tables
'
Dim oTable as Object
Dim oTableName as String
oTable = oAccessTables.getByIndex(0)
oTableName = oTable.Name
'
' Connect
Dim oADOCon as Object
Dim oADOURL as String
Dim oRS as Object
Dim adSchemaPrimaryKeys
adSchemaPrimaryKeys = 28
'
oADOCon = CreateObject("ADODB.Connection")
oADOURL = oProvider & oAccessFile & ";"
oADOCon.Open(oADOURL)
oRS = oADOCon.OpenSchema(adSchemaPrimaryKeys, Array(,,oTableName))
IF oRS.EOF Then
oDisp = "Primary Keyは設定されていません"
Else
n = 0
Do while NOT oRS.EOF
ReDim Preserve sKeyNames(n) As string
sKeyNames(n) = oRS.Fields.Item("COLUMN_NAME").value
oRS.MoveNext
n = n + 1
Loop
oDisp = "Table Name => " & oTableName & Chr$(10) & Chr$(9) & "Primary Key Column Name => " & sKeyNames(n-1)
End IF
'
msgbox oDisp,0,"Column Name of Primary Key for MS-ACCESS Table"
'
oRS.Close
oADOCon.Close
oRS = Nothing
oADOCon = Nothing
'
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")
'
oRS.Close
oADOCon.Close
oRS = Nothing
oADOCon = Nothing
End Sub
Sub oMsAccess
On Error Goto oBad
Dim oDriveManager
Dim oDriver
Dim oURL as String
Dim oAccessFile, oAccessURL as String
Dim oParams(0) as New com.sun.star.beans.PropertyValue
Dim oAccessTables
Dim oDisp as String
Dim oProvider as String
'
oAccessFile = "c:\temp\ACCESS_SQL2007.accdb"
'
oAccessURL = ConvertToUrl(oAccessFile)
If NOT FileExists(oAccessURL) then
MsgBox( oAccessFile & " は存在しません", 0, "Caution !!")
Exit Sub
End If
'
oParams(0).Name = ""
oParams(0).Value = ""
'
oProvider = "PROVIDER=Microsoft.ACE.OLEDB.12.0;DATA SOURCE="
oURL = "sdbc:ado:" & oProvider & oAccessFile
'
oDriverManager = CreateUnoService("com.sun.star.sdbc.DriverManager")
'
oDriver = oDriverManager.getDriverByURL(oURL)
oAccessTables= oDriver.getDataDefinitionByURL(oURL, oParams()).Tables
'
Dim oTable as Object
Dim oTableName as String
oTable = oAccessTables.getByIndex(0)
oTableName = oTable.Name
'
' Connect
Dim oADOCon as Object
Dim oADOURL as String
Dim oRS as Object
Dim adSchemaPrimaryKeys
adSchemaPrimaryKeys = 28
'
oADOCon = CreateObject("ADODB.Connection")
oADOURL = oProvider & oAccessFile & ";"
oADOCon.Open(oADOURL)
oRS = oADOCon.OpenSchema(adSchemaPrimaryKeys, Array(,,oTableName))
IF oRS.EOF Then
oDisp = "Primary Keyは設定されていません"
Else
n = 0
Do while NOT oRS.EOF
ReDim Preserve sKeyNames(n) As string
sKeyNames(n) = oRS.Fields.Item("COLUMN_NAME").value
oRS.MoveNext
n = n + 1
Loop
oDisp = "Table Name => " & oTableName & Chr$(10) & Chr$(9) & "Primary Key Column Name => " & sKeyNames(n-1)
End IF
'
msgbox oDisp,0,"Column Name of Primary Key for MS-ACCESS Table"
'
oRS.Close
oADOCon.Close
oRS = Nothing
oADOCon = Nothing
'
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")
'
oRS.Close
oADOCon.Close
oRS = Nothing
oADOCon = Nothing
End Sub
Sub oMsAccess
On Error Goto oBad
Dim oAccessFile, oAccessURL as String
Dim oDisp as String
Dim oProvider as String
'
oAccessFile = "c:\temp\Macro_Database2.accdb"
'
oAccessURL = ConvertToUrl(oAccessFile)
If NOT FileExists(oAccessURL) then
MsgBox( oAccessFile & " は存在しません", 0, "Caution !!")
Exit Sub
End If
'
oProvider = "PROVIDER=Microsoft.ACE.OLEDB.12.0;DATA SOURCE="
'
' Connect
Dim oADOCon as Object
Dim oADOURL as String
Dim oRS as Object
Dim oTbName as String
'
' ADO Connection
oADOCon = CreateObject("ADODB.Connection")
oADOURL = oProvider & oAccessFile & ";"
oADOCon.Open(oADOURL)
' Recordset
oRS = CreateObject("ADODB.Recordset")
oTbName = "AccessTb"
'
' RecordsetによるTable open
oRS.Open oTbName, oADOCon, adOpenKeyset, adLockOptimistic
'
' Colose Recordset
oRS.Close
oRS = Nothing
' MS-Accessとの接続Close
oADOCon.Close
oADOCon = Nothing
'
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")
'
oRS.Close
oADOCon.Close
oRS = Nothing
oADOCon = Nothing
End Sub
Sub oMsAccess
On Error Goto oBad
Dim oAccessFile, oAccessURL as String
Dim oDisp as String
Dim oProvider as String
'
oAccessFile = "c:\temp\Macro_Database2.accdb"
'
oAccessURL = ConvertToUrl(oAccessFile)
If NOT FileExists(oAccessURL) then
MsgBox( oAccessFile & " は存在しません", 0, "Caution !!")
Exit Sub
End If
'
oProvider = "PROVIDER=Microsoft.ACE.OLEDB.12.0;DATA SOURCE="
'
' Connect
Dim oADOCon as Object
Dim oADOURL as String
Dim oRS as Object
Dim oTbName as String
Dim oSQL as String
'
' ADO Connection
oADOCon = CreateObject("ADODB.Connection")
oADOURL = oProvider & oAccessFile & ";"
oADOCon.Open(oADOURL)
' Recordset
oRS = CreateObject("ADODB.Recordset")
oTbName = "AccessTb"
oSQL = "SELECT [" & oTbName & "].* FROM [" & oTbName & "] WHERE([" & oTbName & "].[No] > 30);" ' <= MS-AccessのSQL構文
'
' RecordsetによるTable open
oRS.Open oSQL, oADOCon, adOpenKeyset, adLockOptimistic
'
' Colose Recordset
oRS.Close
oRS = Nothing
' MS-Accessとの接続Close
oADOCon.Close
oADOCon = Nothing
'
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")
'
oRS.Close
oADOCon.Close
oRS = Nothing
oADOCon = Nothing
End Sub
Sub oMsAccess
On Error Goto oBad
' HSQLDBの設定
Dim oDoc as Object
Dim oHsqlDbURL as String
oDoc = ThisComponent
oHsqlDbURL = oDoc.getURL()
'
Dim oBaseContext as Object
Dim oHsqlDB as Object
Dim oHsqlCon as Object
Dim oStmt as Object
oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
oHsqlDB = oBaseContext.getByName(oHsqlDbURL)
oHsqlCon = oHsqlDB.getConnection("", "")
'
oStmt = oHsqlCon.createStatement()
'
' CREATE TABLE句
Dim oSQL1 as String
Dim oSQL2 as String
Dim oHsqlTb as String
' 既存Tableがあると削除する
oHsqlTb = "TEST"
oSQL1 = "DROP TABLE " & oHsqlTb & " IF EXISTS; "
oStmt.execute(oSQL1)
'
oSQL2 = "CREATE TABLE " & oHsqlTb & "(NO varchar(10), NAME varchar(50)) "
oStmt.execute(oSQL2)
'
'
' MS-Access
Dim oAccessFile, oAccessURL as String
Dim oDisp as String
Dim oProvider as String
'
oAccessFile = "c:\temp\Macro_Database2.accdb"
'
oAccessURL = ConvertToUrl(oAccessFile)
If NOT FileExists(oAccessURL) then
MsgBox( oAccessFile & " は存在しません", 0, "Caution !!")
Exit Sub
End If
'
oProvider = "PROVIDER=Microsoft.ACE.OLEDB.12.0;DATA SOURCE="
'
' Connect
Dim oADOCon as Object
Dim oADOURL as String
Dim oRS as Object
Dim oTbName as String
Dim oSQL as String
'
' ADO Connection
oADOCon = CreateObject("ADODB.Connection")
oADOURL = oProvider & oAccessFile & ";"
oADOCon.Open(oADOURL)
' Recordset
oRS = CreateObject("ADODB.Recordset")
oTbName = "AccessTb"
oSQL = "SELECT [" & oTbName & "].* FROM [" & oTbName & "];" ' MS-AccessのSQL構文
'
' RecordsetによるTable open
oRS.Open oSQL, oADOCon, adOpenKeyset, adLockOptimistic
'
'
' MS-Access DataをHSQLDBへ
Dim oValue as String
Dim oSqlData as String
Dim nn as Long
Dim oLimit as Long
Dim oFieldTmp01 as String
Dim oFieldTmp02 as String
oLimit = 1000
'
nn = 0
oRS.MoveFirst
Do Until oRS.EOF or nn > oLimit
' RecordsetからData取得
oFieldTmp01 = CStr(oRS.Fields.Item("No").value)
oFieldTmp02 = CStr(oRS.Fields.Item("Name").value)
'
' HSQLDBへInsert
oValue = "VALUES('" & oFieldTmp01 & "','" & oFieldTmp02 & "');"
oSqlData = "INSERT INTO " & oHsqlTb & "(NO, NAME)" & " " & oValue
oStmt.executeUpdate(oSqlData)
'
oRS.MoveNext
'
nn = nn + 1
If nn > oLimit then
Exit Do
End If
Loop
'
'
' Colose Recordset
oRS.Close
oRS = Nothing
' MS-Accessとの接続Close
oADOCon.Close
oADOCon = Nothing
'
'
' HSQLDBのClose
oHsqlCon.close()
'
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")
'
oRS.Close
oADOCon.Close
oRS = Nothing
oADOCon = Nothing
'
oHsqlCon.close()
End Sub
Sub oMsAccess
On Error Goto oBad
' MS-Access
Dim oAccessFile, oAccessURL as String
Dim oDisp as String
Dim oProvider as String
'
oAccessFile = "c:\temp\Macro_Database2.accdb"
'
oAccessURL = ConvertToUrl(oAccessFile)
If NOT FileExists(oAccessURL) then
MsgBox( oAccessFile & " は存在しません", 0, "Caution !!")
Exit Sub
End If
'
oProvider = "PROVIDER=Microsoft.ACE.OLEDB.12.0;DATA SOURCE="
'
' Connect
Dim oADOCon as Object
Dim oADOURL as String
Dim oRS as Object
Dim oTbName as String
Dim oSQL as String
'
' ADO Connection
oADOCon = CreateObject("ADODB.Connection")
oADOURL = oProvider & oAccessFile & ";"
oADOCon.Open(oADOURL)
' Recordset
oRS = CreateObject("ADODB.Recordset")
oTbName = "AccessTb"
oSQL = "SELECT Count(*) as [Cnt] FROM [" & oTbName & "];" ' MS-AccessのSQL構文
'
' RecordsetによるTable open
oRS.Open oSQL, oADOCon, adOpenStatic, 1
'
' Record数Coout
Dim oRecordNum as Long
'oRecordNum = oRS.RecordCount ' returnが -1 になる。
oRecordNum = oRS.Fields.Item("Cnt").value + 1 ' 最初のRecordが0とCountされる為 + 1
'
msgbox(oRecordNum,0,"MS-AccessのRecord数")
' Colose Recordset
oRS.Close
oRS = Nothing
' MS-Accessとの接続Close
oADOCon.Close
oADOCon = Nothing
'
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")
'
oRS.Close
oADOCon.Close
oRS = Nothing
oADOCon = Nothing
'
oHsqlCon.close()
End Sub
