何度も同じようなコードをインターネットから探しては
自分のルールに沿ってクラス化してきたが、
何度もやるのはめんどくさくなったから、
頻度の高いところをまとめる。
できるならば、クラスをそのまま貼り付ける。
' 一時ファイル名取得用 API の宣言 Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" _ (ByVal lpszPath As String, ByVal lpPrefixString As String, _ ByVal wUnique As Long, ByVal lpTempFileName As String) As Long ' 一時ファイル名の取得 Public Function udGetTempFileName(argPath) As String Dim lngRet As Long Dim strFileName As String * 255 lngRet = GetTempFileName(argPath, "acc", 0&, strFileName) udGetTempFileName = Left(strFileName, InStr(strFileName, vbNullChar) - 1) End Function
Option Compare Database Option Explicit
'Sub main()
'getSnap "YOSHIN", "YOSHIN3", "DSN=TKOTRIP2_DEV; UID=TKOTRIP2_DEV; PWD=TKOTRIP2_DEV;"
'LoadData "DSN=TKOTRIP2; UID=TKOTRIP2; PWD=TKOTRIP2;", "YOSHIN", "YOSHIN3" 'getSnap "USER_INFO", "DSN=TKOTRIP2_DEV; UID=TKOTRIP2_DEV; PWD=TKOTRIP2_DEV;" 'p "main 終了"
'End Sub
'テーブルの構成をコピーする
'文字情報として保存する
'テーブル名の先頭には"T+タイムスタンプ+_"をつけてスキーマとの対応を保全する
'時系列で保存する
'テーブル構成のスナップを保存する Public Sub getSnap(tablename As String, savename As String, strDSN As String)
'テーブル作成の準備 'テーブルの情報を集める Dim con As New clsConnection con.setDSN strDSN '"DSN=TKOTRIP2_DEV; UID=TKOTRIP2_DEV; PWD=TKOTRIP2_DEV;" Dim tableList As clsTableList Set tableList = con.getTableList 'スキーマを検索 'tableList.getItem(tablename).getColumnScheme.save savename & "_SCHEME" '主キーを調べる 'tableList.getItem(tablename).getPKColumnRecordset.save savename & "_KEY" Dim cNotNull As clsCollection Set cNotNull = tableList.getItem(tablename).getNotNullList Set tableList = con.getTableList 'データを格納 tableList.getItem(tablename).toRecordset.save savename, cNotNull 'PKやNOTNULLの設定 con.addPKToMDB tablename, savename
End Sub
'エンティティ定義書を元にテーブル作成 Public Sub createTable(wb As Workbook, tablename As String, strDSN As String)
Dim ws As Worksheet Dim con As New clsConnection Dim found As Boolean found = False Dim sqlCommandList As Variant Dim intSqlCommandListCount As Integer For Each ws In wb.Sheets DoEvents If ws.Cells(6, 30).value = tablename Then Debug.Print tablename & "テーブルを作成" found = True Dim strSQL As String strSQL = subTabelSqlOut(wb, ws.name) con.setDSN strDSN '"DSN=TKOTRIP2_DEV; UID=TKOTRIP2_DEV; PWD=TKOTRIP2_DEV;" con.adoCON.BeginTrans On Error GoTo ROLLBACK sqlCommandList = Split(strSQL, ";") For intSqlCommandListCount = 0 To UBound(sqlCommandList) '1文字はコマンドではないとみなす。 If Len(sqlCommandList(intSqlCommandListCount)) > 2 Then If InStr(1, sqlCommandList(intSqlCommandListCount), "DROP ") = 0 Then con.adoCON.execute sqlCommandList(intSqlCommandListCount) Else 'DROP文はOracle側に存在しない場合も想定し無視する。 On Error Resume Next con.adoCON.execute sqlCommandList(intSqlCommandListCount) On Error GoTo ROLLBACK End If End If Next con.adoCON.CommitTrans On Error GoTo 0 Debug.Print tablename & "テーブル作成完了" Exit For End If Next If Not found Then MsgBox "定義書内に" & tablename & "は見つかりませんでした" End If Exit Sub
ROLLBACK:
MsgBox "エンティティ定義書を見直してください。" & Chr(10) & wb.path & Chr(10) & strSQL & Chr(10) & Err.Description Debug.Print Chr(10) & wb.path & Chr(10) & strSQL & Chr(10) & Err.Description On Error Resume Next con.adoCON.RollbackTrans Dim yesno As Long p strSQL yesno = MsgBox("処理を続けますか?", vbYesNo, "確認") If yesno = vbNo Then End End If
End Sub
'メッセージを表示 Private Sub p(message As Variant)
Debug.Print message
End Sub
Public Sub LoadData?(strDSN As String, strTablename As String, strTablenameMDB As String, log As clsLog)
'Oracleに接続 Dim cCon As New clsConnection cCon.setDSN strDSN Dim cTableList As clsTableList Set cTableList = cCon.getTableList If Not cTableList.isExist(strTablename) Then MsgBox "コピー元となるテーブル:" & strTablename & "がOracle側に存在しません。処理を停止します。" Exit Sub End If 'MDBに接続 Dim cDB As New clsDB cDB.OpenDB If Not cDB.isExistTable(strTablenameMDB) Then 'MsgBox "コピー元となるテーブル:" & strTablenameMDB & "がAccess側に存在しません。処理を停止します。" Exit Sub End If 'MDBのデータを読み込みます。 cDB.getTableList.getItem(strTablenameMDB).toRecordset.saveToOracle cCon, strTablename, log
End Sub
Public Sub LoadDataTimeStamp?(strDSN As String, strTablename As String, strTablenameMDB As String, log As clsLog)
'Oracleに接続 Dim cCon As New clsConnection cCon.setDSN strDSN Dim cTableList As clsTableList Set cTableList = cCon.getTableList If Not cTableList.isExist(strTablename) Then 'MsgBox "コピー元となるテーブル:" & strTablename & "がOracle側に存在しません。処理を停止します。" Exit Sub End If 'MDBに接続 Dim cDB As New clsDB cDB.OpenDB If Not cDB.isExistTable(strTablenameMDB) Then 'MsgBox "コピー元となるテーブル:" & strTablenameMDB & "がAccess側に存在しません。処理を停止します。" Exit Sub End If 'MDBのデータを読み込みます。 cDB.getTableList.getItem(strTablenameMDB).toRecordset.saveToOracleTimeStamp cCon, strTablename, log
End Sub
Option Compare Database Option Explicit
'参考:
'シートごとのテーブルCreate文を作成する Public Function subTabelSqlOut?(wb As Workbook, strSheetNm? As String) As String
Dim intPk As Integer 'プライマリーキー Dim intId As Integer 'ID(カラム名) Dim intName As Integer 'データ項目名称 Dim intType As Integer 'タイプ Dim intLen As Integer '長さ Dim intLen2 As Integer '小数点 Dim intNull As Integer 'Null許可 Dim intDef As Integer 'デフォルト値 Dim intStart As Integer '項目開始行
Dim strSchema As String 'スキーマ名 Dim strTbNm As String 'テーブル名 Dim strTbId As String 'テーブルID Dim strEx As String 'テーブル説明
Dim strSQL As String '出力するSQL文 Dim strSQLComment As String '出力するCommentSQL文 Dim intCnt As Integer 'カウンター '初期値設定(レイアウトに合わせて修正) intPk = 4 intName = 6 intId = 14 intType = 24 intLen = 28 intLen2 = 30 intNull = 32 intDef = 34
Dim sh As Worksheet Set sh = wb.Sheets(strSheetNm) 'スキーマ名を取得 On Error Resume Next strSchema = Trim(sh.Range("出力スキーマ")) On Error GoTo 0 If strSchema <> "" Then strSchema = strSchema & "." 'テーブル内容を取得 strTbNm = sh.Cells(6, 7) strTbId = sh.Cells(6, 30) strEx = sh.Cells(7, 7)
intStart = 12 ' セル内改行除去 strEx = Replace(strEx, Chr(10), " ", 1, -1, vbBinaryCompare) 'コメント文生成 'テーブル名称 'strSQL = "--テーブル名称:" & strTbNm & vbNewLine 'テーブルID 'strSQL = strSQL & "--テーブルID:" & strTbId & vbNewLine '説明 'strSQL = strSQL & "--説明 " & ":" & strEx & vbNewLine & vbNewLine
'SQL文作成開始 strSQL = strSQL & "DROP TABLE " & strSchema & Trim(strTbId) & ";" & vbNewLine strSQL = strSQL & "CREATE TABLE " & strSchema & Trim(strTbId) & "(" & vbNewLine
'各項目 Dim i As Integer Dim j As Integer i = intStart Do While sh.Cells(i, intId) <> ""
'2行名以降はカンマを設定 If i <> intStart Then strSQL = strSQL & "," Else strSQL = strSQL & " " End If 'ID strSQL = strSQL & sh.Cells(i, intId) & " " '文字位置調整(TAB文字) j = (27 - Len(sh.Cells(i, intId))) / 4 If j <> Int(j) Then j = Int(j) + 1 End If Dim h As Integer For h = 1 To j strSQL = strSQL & vbTab Next 'タイプ strSQL = strSQL & sh.Cells(i, intType) '長さ Select Case sh.Cells(i, intType) Case "DATE", "TIMESTAMP", "CLOB" '長さの出力は不要 Case Else strSQL = strSQL & "(" & Format(sh.Cells(i, intLen), "00") If sh.Cells(i, intLen2) <> "" Then strSQL = strSQL & "," & sh.Cells(i, intLen2) End If strSQL = strSQL & ")" End Select 'デフォルト値 If sh.Cells(i, intDef) <> "" Then strSQL = strSQL & vbTab & vbTab & "DEFAULT " & sh.Cells(i, intDef) End If 'NULL If sh.Cells(i, intNull) <> "" Then strSQL = strSQL & vbTab & vbTab & "NOT NULL" End If strSQL = strSQL & vbNewLine
'コメント strSQLComment = strSQLComment & "COMMENT ON COLUMN " strSQLComment = strSQLComment & strSchema & strTbId strSQLComment = strSQLComment & "." strSQLComment = strSQLComment & sh.Cells(i, intId) strSQLComment = strSQLComment & " IS '" strSQLComment = strSQLComment & sh.Cells(i, intName) strSQLComment = strSQLComment & "';" strSQLComment = strSQLComment & vbCrLf '出力最終行を保持 intCnt = i i = i + 1 Loop
'プライマリーキー i = intStart Dim flg As Integer flg = 0 For i = intStart To intCnt If flg = 0 Then If sh.Cells(i, intPk) = "PK" Then strSQL = strSQL & ",CONSTRAINT " & Trim(strTbId) & "_KEY " & "PRIMARY KEY(" & sh.Cells(i, intId) flg = 1 End If Else If sh.Cells(i, intPk) = "PK" Then strSQL = strSQL & "," & sh.Cells(i, intId) End If End If Next If flg = 1 Then strSQL = strSQL & ")" & vbNewLine End If
'終了文字列 strSQL = strSQL & ");" & vbNewLine
'列の和名を設定 strSQL = strSQL & strSQLComment strSQL = strSQL & "" strSQL = strSQL & "COMMENT ON TABLE " strSQL = strSQL & strSchema & strTbId strSQL = strSQL & " IS '" strSQL = strSQL & strTbNm strSQL = strSQL & "';" strSQL = strSQL & vbCrLf '実行文字列 'strSQL = strSQL & "/" & vbNewLine
'txtファイル出力 'Dim lngFileNo As Long 'lngFileNo = FreeFile 'Open Excel.ActiveWorkbook.Path & "\" & Trim(strTbId) & ".sql" For Output As #lngFileNo ' Print #lngFileNo, strSQL 'Close #lngFileNo subTabelSqlOut = strSQL
End Function
Option Compare Database
Public mCol As Collection
Private Sub Class_Initialize()
Set mCol = New Collection
End Sub
Public Function getStringItem?(index As Variant) As String
getStringItem = mCol.Item(index)
End Function
Public Function count() As Long
count = mCol.count
End Function
Public Sub addByCommmaString?(strCommaString? As String)
Dim ary() As String ary = Split(strCommaString, ",") Dim i As Integer For i = 0 To UBound(ary) mCol.Add ary(i) Next
End Sub
Public Function getItem(index As Variant) As String
getItem = mCol.Item(index)
End Function
Public Function getReduceList?(pattern As String) As clsCollection
Dim reg As New RegExp Dim ret As New clsCollection reg.pattern = pattern reg.Multiline = False Dim i As Integer For i = 1 To count If Not reg.test(getItem(i)) Then ret.addItem getItem(i) End If Next Set getReduceList = ret
End Function
'同じ要素を含む配列を返す Public Function matchAnd(list As clsCollection) As clsCollection
Dim uniqList As clsCollection Set uniqList = list.uniq Dim ret As New clsCollection Dim i As Integer For i = 1 To count If uniqList.isExist(getItem(i)) Then ret.addItem (getItem(i)) End If Next Set matchAnd = ret
End Function
Public Sub addItem(value As String)
mCol.Add value
End Sub
Public Function uniq() As clsCollection
Dim ret As New clsCollection Dim i As Integer On Error Resume Next For i = 1 To count ret.mCol.Add getItem(i), getItem(i) Next Set uniq = ret
End Function
Public Function isExist(index As Variant) As Boolean
On Error GoTo noHave Dim dummy As String dummy = getItem(index) isExist = True Exit Function
noHave:
isExist = False
End Function
Public Sub p()
Dim i As Integer For i = 1 To count Debug.Print getItem(i) Next
End Sub
Public Sub clearAll()
Dim i As Integer For i = count To 1 Step -1 mCol.Remove i Next
End Sub
Private Sub test()
Idx = MsCombSortI(A)
End Sub
'コムソート '参考:http://hp.vector.co.jp/authors/VA033788/kowaza.html#0046 Public Function sort() As clsCollection
'昇順インデックスを返す '配列引数mColは1次元限定 Dim Idx() As Long 'Dim L As Long .. 1 'Dim U As Long .. mCol.count Dim i As Long Dim gap As Long Dim Temp As Long Dim F As Boolean 'U = UBound(mCol) 'インデックス初期設定 ReDim Idx(mCol.count) For i = 1 To mCol.count Idx(i) = i Next gap = mCol.count - 1 F = True Dim intConpareResult As Integer '並べ替え Do While gap > 1 Or F = True gap = Int(gap / 1.3) If gap = 9 Or gap = 10 Then gap = 11 ElseIf gap < 1 Then gap = 1 End If F = False For i = 1 To mCol.count - gap intConpareResult = compare(mCol(Idx(i)), mCol(Idx(i + gap))) ' -1..0..1 If intConpareResult = 1 Then '降順時は < Temp = Idx(i) Idx(i) = Idx(i + gap) Idx(i + gap) = Temp F = True ElseIf intConpareResult = 0 Then If Idx(i) > Idx(i + gap) Then '昇順降順変更しても変更の必要なし Temp = Idx(i) Idx(i) = Idx(i + gap) Idx(i + gap) = Temp F = True End If End If Next Loop '順番を元にソート Dim ret As New clsCollection For i = 1 To mCol.count ret.addItem getItem(Idx(i)) Next Set sort = ret
End Function
Private Function compare(str1 As String, str2 As String)
compare = StrComp(str1, str2, vbTextCompare)
End Function
Private Sub セル範囲並べ替え()
Const 列 As Integer = 1 Dim A As Variant Dim B As Variant Dim C As Variant Dim myRange As Range Dim Idx As Variant Dim L As Long Dim U As Long Dim L2 As Long Dim U2 As Long Dim i As Long Dim j As Long Set myRange = ActiveCell.CurrentRegion A = myRange.value L = LBound(A) U = UBound(A) L2 = LBound(A, 2) U2 = UBound(A, 2) '2次元⇒1次元 ReDim B(L To U) For i = L To U B(i) = A(i, 列) Next '並べ替えインデックスを得る Idx = MsCombSortI(B) '配列内で並べ替え ReDim C(L To U, L2 To U2) For i = L To U For j = L2 To U2 C(i, j) = A(Idx(i), j) Next Next 'セルに書き戻し myRange.value = C Set myRange = Nothing
End Sub
Public Function toUpperCase?() As clsCollection
Dim ret As New clsCollection Dim i As Integer For i = 1 To count ret.addItem (UCase(getItem(i))) Next Set toUpperCase = ret
End Function
Public Function toLowerCase?() As clsCollection
Dim ret As New clsCollection Dim i As Integer For i = 1 To count ret.addItem (LCase(getItem(i))) Next Set toLowerCase = ret
End Function
Public Function join(delimiter As String) As String
Dim i As Integer Dim ret As String For i = 1 To count If i <> 1 Then ret = ret & delimiter End If ret = ret & getItem(i) Next join = ret
End Function
Public Function addWithKey?(key As String, value As String)
mCol.Add value, key
End Function
Public Sub prin()
Dim i As Integer For i = 0 To count Debug.Print getItem(i) Next
End Sub
Option Compare Database Option Explicit
Public mColumn As ADOX.column
Const TYPE_adBigInt? = "adBigInt?" Const TYPE_adBinary = "adBinary" Const TYPE_adBoolean = "adBoolean" Const TYPE_adBSTR = "adBSTR" Const TYPE_adChapter = "adChapter" Const TYPE_adChar = "adChar" Const TYPE_adCurrency = "adCurrency" Const TYPE_adDate = "adDate" Const TYPE_adDBTime = "adDBTime" Const TYPE_adDBTimeStamp? = "adDBTimeStamp?" Const TYPE_adDecimal = "adDecimal" Const TYPE_adDouble = "adDouble" Const TYPE_adEmpty = "adEmpty" Const TYPE_adError = "adError" Const TYPE_adFileTime? = "adFileTime?" Const TYPE_adGUID = "adGUID" Const TYPE_adIDispatch = "adIDispatch" Const TYPE_adInteger = "adInteger" Const TYPE_adIUnknown = "adIUnknown" Const TYPE_adLongVarBinary? = "adLongVarBinary?" Const TYPE_adLongVarChar? = "adLongVarChar?" Const TYPE_adLongVarWChar = "adLongVarWChar" Const TYPE_adNumeric = "adNumeric" Const TYPE_adPropVariant? = "adPropVariant?" Const TYPE_adSingle = "adSingle" Const TYPE_adSmallInt? = "adSmallInt?" Const TYPE_adTinyInt? = "adTinyInt?" Const TYPE_adUnsignedBigInt? = "adUnsignedBigInt?" Const TYPE_adUnsignedInt? = "adUnsignedInt?" Const TYPE_adUnsignedSmallInt? = "adUnsignedSmallInt?" Const TYPE_adUnsignedTinyInt? = "adUnsignedTinyInt?" Const TYPE_adUserDefined? = "adUserDefined?" Const TYPE_adVarBinary? = "adVarBinary?" Const TYPE_adVarChar? = "adVarChar?" Const TYPE_adVariant = "adVariant" Const TYPE_adVarNumeric? = "adVarNumeric?" Const TYPE_adWChar = "adWChar"
Const DEFAULT_FORMAT = "@"
Public mDataType? As String Public mNullable As String
Public Function setColumn(column As ADOX.column) As column
Set mColumn = column
End Function
Public Function getTypeName?() As String
Select Case mColumn.Type Case adBigInt getTypeName = TYPE_adBigInt Case adBinary getTypeName = TYPE_adBinary Case adBoolean getTypeName = TYPE_adBoolean Case adBSTR getTypeName = TYPE_adBSTR Case adChapter getTypeName = TYPE_adChapter Case adChar getTypeName = TYPE_adChar Case adCurrency getTypeName = TYPE_adCurrency Case adDate getTypeName = TYPE_adDate Case adDBTime getTypeName = TYPE_adDBTime Case adDBTimeStamp getTypeName = TYPE_adDBTimeStamp Case adDecimal getTypeName = TYPE_adDecimal Case adDouble getTypeName = TYPE_adDouble Case adEmpty getTypeName = TYPE_adEmpty Case adError getTypeName = TYPE_adError Case adFileTime getTypeName = TYPE_adFileTime Case adGUID getTypeName = TYPE_adGUID Case adIDispatch getTypeName = TYPE_adIDispatch Case adInteger getTypeName = TYPE_adInteger Case adIUnknown getTypeName = TYPE_adIUnknown Case adLongVarBinary getTypeName = TYPE_adLongVarBinary Case adLongVarChar getTypeName = TYPE_adLongVarChar Case adLongVarWChar getTypeName = TYPE_adLongVarWChar Case adNumeric getTypeName = TYPE_adNumeric Case adPropVariant getTypeName = TYPE_adPropVariant Case adSingle getTypeName = TYPE_adSingle Case adSmallInt getTypeName = TYPE_adSmallInt Case adTinyInt getTypeName = TYPE_adTinyInt Case adUnsignedBigInt getTypeName = TYPE_adUnsignedBigInt Case adUnsignedInt getTypeName = TYPE_adUnsignedInt Case adUnsignedSmallInt getTypeName = TYPE_adUnsignedSmallInt Case adUnsignedTinyInt getTypeName = TYPE_adUnsignedTinyInt Case adUserDefined getTypeName = TYPE_adUserDefined Case adVarBinary getTypeName = TYPE_adVarBinary Case adVarChar getTypeName = TYPE_adVarChar Case adVariant getTypeName = TYPE_adVariant Case adVarNumeric getTypeName = TYPE_adVarNumeric Case adWChar getTypeName = TYPE_adWChar Case Else p "error_at_getTypeName :" & mColumn.Type End Select
End Function
Public Function getNumberFormatLocal?() As String
Select Case mColumn.Type Case adBigInt getNumberFormatLocal = DEFAULT_FORMAT Case adBinary getNumberFormatLocal = DEFAULT_FORMAT Case adBoolean getNumberFormatLocal = DEFAULT_FORMAT Case adBSTR getNumberFormatLocal = DEFAULT_FORMAT Case adChapter getNumberFormatLocal = DEFAULT_FORMAT Case adChar getNumberFormatLocal = "@" Case adCurrency getNumberFormatLocal = DEFAULT_FORMAT Case adDate getNumberFormatLocal = "yyyy/m/d" Case adDBTime getNumberFormatLocal = DEFAULT_FORMAT Case adDBTimeStamp If mDataType = "DATE" Then getNumberFormatLocal = "yyyy/m/d" Else getNumberFormatLocal = "yyyy/mm/dd hh:mm:ss.000" End If Case adDecimal getNumberFormatLocal = DEFAULT_FORMAT Case adDouble getNumberFormatLocal = DEFAULT_FORMAT Case adEmpty getNumberFormatLocal = DEFAULT_FORMAT Case adError getNumberFormatLocal = DEFAULT_FORMAT Case adFileTime getNumberFormatLocal = DEFAULT_FORMAT Case adGUID getNumberFormatLocal = DEFAULT_FORMAT Case adIDispatch getNumberFormatLocal = DEFAULT_FORMAT Case adInteger getNumberFormatLocal = DEFAULT_FORMAT Case adIUnknown getNumberFormatLocal = DEFAULT_FORMAT Case adLongVarBinary getNumberFormatLocal = DEFAULT_FORMAT Case adLongVarChar getNumberFormatLocal = DEFAULT_FORMAT Case adLongVarWChar getNumberFormatLocal = DEFAULT_FORMAT Case adNumeric If mColumn.NumericScale <> 0 Then getNumberFormatLocal = "0." & Left("0000000000000000000000000", mColumn.NumericScale) & "_ " '"0.000000_ " Else getNumberFormatLocal = "0_ " End If Case adPropVariant getNumberFormatLocal = DEFAULT_FORMAT Case adSingle getNumberFormatLocal = DEFAULT_FORMAT Case adSmallInt getNumberFormatLocal = DEFAULT_FORMAT Case adTinyInt getNumberFormatLocal = DEFAULT_FORMAT Case adUnsignedBigInt getNumberFormatLocal = DEFAULT_FORMAT Case adUnsignedInt getNumberFormatLocal = DEFAULT_FORMAT Case adUnsignedSmallInt getNumberFormatLocal = DEFAULT_FORMAT Case adUnsignedTinyInt getNumberFormatLocal = DEFAULT_FORMAT Case adUserDefined getNumberFormatLocal = DEFAULT_FORMAT Case adVarBinary getNumberFormatLocal = DEFAULT_FORMAT Case adVarChar getNumberFormatLocal = "@" Case adVariant getNumberFormatLocal = DEFAULT_FORMAT Case adVarNumeric getNumberFormatLocal = DEFAULT_FORMAT Case adWChar getNumberFormatLocal = DEFAULT_FORMAT Case Else p "error_at_getNumberFormatLocal :" & mColumn.Type End Select
End Function
Sub p(message As String)
Debug.Print message
End Sub
'ADOXで認識できなかった型を補う Public Sub setDataType?(datatype As String)
mDataType = datatype
End Sub
'nullable Public Sub setNullable(nullable As String)
mNullable = nullable
End Sub
Option Explicit
Public mCol As Collection Public mTable As ADOX.table Public mColFormat? As Collection
'初期化 Public Sub setTable(table As ADOX.table)
Set mTable = table Dim oracleColList As clsRecordset Dim oraclsColNameList As clsCollection Dim col As ADOX.column Dim cCol As clsColumn Dim i As Integer If TypeName(oracleColList) = "Nothing" Then For i = 0 To mTable.Columns.count - 1 Set col = mTable.Columns.Item(i) Set cCol = New clsColumn cCol.setColumn col addItem cCol Next Else Set oraclsColNameList = oracleColList.getFieldList("COLUMN_NAME") 'オラクルのカラム情報を元に列の順序をそろえる For i = 1 To oraclsColNameList.count Set col = mTable.Columns.Item(oraclsColNameList.getItem(i)) Set cCol = New clsColumn cCol.setColumn col addItem cCol Next End If On Error GoTo notOracle Dim cRecordset As clsRecordset Set cRecordset = getOracleColumnInfoRecordset(mTable) 'ADOXで取得したカラム一覧情報にさらに詳しい情報を付加します。
Do Until cRecordset.mRecordset.EOF Set cCol = getItem(cRecordset.mRecordset!COLUMN_NAME) cCol.setDataType cRecordset.mRecordset!DATA_TYPE cCol.setNullable cRecordset.mRecordset!nullable cRecordset.mRecordset.MoveNext Loop On Error GoTo 0 Exit Sub
notOracle:
End Sub
Private Function getOracleColumnInfoRecordset?(table As ADOX.table) As clsRecordset
On Error GoTo notOracle 'スキーマ取得用 ADOXではOracleのTIMESTAMPもDATEも区別していなかったためスキーマ取得クエリーを発行する。 Dim strSchema As String strSchema = "SELECT C.* FROM USER_TAB_COLUMNS C WHERE C.TABLE_NAME = '$TABLENAME$'" strSchema = Replace(strSchema, "$TABLENAME$", table.name) '検索処理 Dim con As Connection Set con = table.ParentCatalog.ActiveConnection Dim rs As recordset Set rs = con.execute(strSchema) Dim cRecordset As clsRecordset Set cRecordset = New clsRecordset cRecordset.setRecordset rs Set getOracleColumnInfoRecordset = cRecordset Exit Function
notOracle:
Set getOracleColumnInfoRecordset = Nothing
End Function
Private Sub Class_Initialize()
Set mCol = New Collection
End Sub
Public Function count() As Long
count = mCol.count
End Function
Public Sub addItem(column As clsColumn)
If Not isExist(column.mColumn.name) Then mCol.Add column, column.mColumn.name End If
End Sub
Public Function getItem(index As Variant) As clsColumn
Set getItem = mCol.Item(index)
End Function
Public Function isExist(name As String) As Boolean
On Error GoTo notExist Dim dummy As clsColumn Set dummy = getItem(name) isExist = True Exit Function
notExist:
isExist = False
End Function
Public Function getNameList?() As clsCollection
Dim ret As clsCollection Set ret = New clsCollection Dim i As Integer For i = 1 To count ret.mCol.Add getItem(i).mColumn.name Next Set getNameList = ret
End Function
Public Function getTimeStampColumnList?() As clsColumnList?
Dim ret As clsColumnList Set ret = New clsColumnList Dim i As Integer For i = 1 To count If InStr(1, getItem(i).mDataType, "TIMESTAMP") <> 0 Then ret.addItem getItem(i) End If Next Set getTimeStampColumnList = ret
End Function
Option Explicit
'クラスの説明 ' 自動クローズコネクションクラス
Const MDB_CONNECT = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" Const ORA_CONNECT = "Provider=MSDAORA;Data Source="
Public adoCON As Connection Public cat As New Catalog
Public Sub setDSN(strDSN As String)
'On Error GoTo show_error 'ADOを使いデータソースをオープンします adoCON.Open strDSN '"DSN=TKOTRIP2_DAO; UID=TKOTRIP2_DAO; PWD=TKOTRIP2_DAO;" cat.ActiveConnection = adoCON p "DBをオープン:" & strDSN Exit Sub
show_error:
p strDSN MsgBox "DSNが存在していないかUIDが存在していません" End
End Sub
Sub p(message As String)
Debug.Print message
End Sub
Private Sub Class_Initialize()
Set adoCON = New Connection
End Sub
Private Sub Class_Terminate()
On Error GoTo close_error adoCON.Close 'データベースの自動クローズ p "DBをClose:" & adoCON.ConnectionString Exit Sub
close_error:
p "コネクションは閉じられていました。"
End Sub
Public Function getTableList?() As clsTableList?
Dim ret As clsTableList Set ret = New clsTableList ret.setConnection adoCON, cat Set getTableList = ret
End Function
Public Sub setConnection(con As Connection)
Set adoCON = con cat.ActiveConnection = con
End Sub
Public Sub openMDB(Optional strFileName? As String = "")
If strFileName <> "" And strFileName <> CurrentProject.path & "\" & CurrentProject.name Then Dim dbCon As ADODB.Connection Set dbCon = New ADODB.Connection dbCon.Open MDB_CONNECT & strFileName Set adoCON = dbCon Else Set adoCON = CurrentProject.Connection End If cat.ActiveConnection = adoCON
End Sub
Public Sub OpenOracle?(strServerName? As String, strUID As String, strPWD As String)
Dim dbCon As ADODB.Connection Set dbCon = New ADODB.Connection dbCon.Open ORA_CONNECT & strServerName & ";User ID=" & strUID & "; Password=" & strPWD & ";"
Set adoCON = dbCon cat.ActiveConnection = adoCON
End Sub
Public Function getUserTableList?() As clsCollection
Dim cRecordset As New clsRecordset Set cRecordset = execute("SELECT * FROM USER_TABLES") Set getUserTableList = cRecordset.getList("TABLE_NAME")
End Function
Public Function execute(strSQL As String) As clsRecordset
Dim ret As New clsRecordset Dim rs As recordset Set rs = adoCON.execute(strSQL) ret.setRecordset rs Set execute = ret
End Function
'mdbに格納してあるテーブルにPKの情報を追加する。 Public Function addPKToMDB(tablename As String, savename As String)
Dim cDB As clsDB Set cDB = New clsDB cDB.OpenDB Dim cTable As clsTable Set cTable = cDB.getTableList.getItem(savename) 'PK追加 Dim cPKList As clsColumnList Set cPKList = getTableList.getItem(tablename).getPKColumns cTable.addPK cPKList 'レコードセット追加 Dim cConstraintList As clsRecordset Set cConstraintList = getTableList.getItem(tablename).getConstraintColumnRecordset cTable.addConstraint cConstraintList
End Function
Option Compare Database Option Explicit
Public mDB As database Public mConnection As clsConnection
Public Sub setDB(database As database)
Set mDB = database
End Sub
Private Sub Class_Terminate()
On Error Resume Next mDB.Close Set mDB = Nothing
End Sub
'データベースを開く Public Sub OpenDB(Optional name As String = "")
If name = "" Then name = CurrentDb.name Set mConnection = New clsConnection mConnection.setConnection CurrentProject.Connection Set mDB = CurrentDb Else Set mDB = OpenDatabase(name) End If
End Sub
'コネクションクラスを返します。 Public Function getConnection() As clsConnection
If TypeName(mConnection) = "Nothing" Then Set mConnection = New clsConnection On Error GoTo con_err mConnection.setConnection mDB.Connection On Error GoTo 0 ElseIf IsNull(mConnection.cat) Then Set mConnection = New clsConnection mConnection.setConnection mDB.Connection End If On Error Resume Next mConnection.adoCON.BeginTrans On Error Resume Next mConnection.adoCON.RollbackTrans On Error GoTo 0 Set getConnection = mConnection Exit Function
con_err:
Debug.Print "コネクションエラー"
End Function
Public Function CreateTableDef?(name As String) As clsTableDef?
Dim cTabledef As clsTableDef Set cTabledef = New clsTableDef cTabledef.setTableDef mDB.CreateTableDef(name), mDB Set CreateTableDef = cTabledef
End Function
Public Function getTableList?() As clsTableList?
Set getTableList = getConnection.getTableList
End Function
Public Function isExistTable?(name As String) As Boolean
isExistTable = getTableList.isExist(name)
End Function
Public Sub dropTable(name As String)
getConnection.cat.Tables.Delete name
End Sub
Option Compare Database Option Explicit
Private Const ODBC_ADD_SYS_DSN = 4 'Add data source Private Const ODBC_CONFIG_SYS_DSN = 5 'Configure (edit) data source Private Const ODBC_REMOVE_SYS_DSN = 6 'Remove data source
Private Const vbAPINull As Long = 0& ' NULL Pointer
Private Declare Function SQLConfigDataSource? Lib "ODBCCP32.DLL" (ByVal? _
hwndParent As Long, ByVal fRequest As Long, ByVal _ lpszDriver As String, ByVal lpszAttributes As String) As Long
'Function Build_SystemDSN(DSN_NAME As String, Db_Path As String) ' ' Dim ret%, Driver$, Attributes$ ' ' Driver = "Microsoft Access Driver (*.MDB)" & Chr(0) ' Attributes = "DSN=" & DSN_NAME & Chr(0) ' Attributes = Attributes & "Uid=Admin" & Chr(0) & "pwd=" & Chr(0) ' Attributes = Attributes & "DBQ=" & Db_Path & Chr(0) ' ' ret = SQLConfigDataSource?(0, ODBC_ADD_SYS_DSN, Driver, Attributes) ' ' ' 'ret is equal to 1 on success and 0 if there is an error ' If ret <> 1 Then ' MsgBox? "DSN Creation Failed" ' End If ' 'End Function
'使用例 'イミディエイト ウィンドウに次の行を入力し Enter キーを押します。 'Print Build_SystemDSN("My SampleDSN", "c:\Northwind.mdb")
Public Sub addOracleDSN(strDSName As String, strUID As String, strPWD As String, strServerName? As String)
' strDriver = "Oracle ODBC Driver" ' 'DSN文字列 ' strDSN = "DSN=dsn_name" & vbNullChar? ' strDSN = strDSN & "Description=TEST" & vbNullChar? ' strDSN = strDSN & "UserID=user_name" & vbNullChar? ' strDSN = strDSN & "ServerName?=service_name" & vbNullChar? & vbNullChar?
Dim lngRequest As Long Dim strDriver As String 'ドライバ名 'Dim strDSN As String 'DSN文字列 'ドライバ名 ドライバ名が正しくない場合は自分で設定してみてください。 strDriver = "Oracle in OraClient10g_home1" 'DSN文字列 Dim cDSN As New clsCollection 'cDSN.addItem "DRIVER=Oracle in OraClient10g_home1" 'cDSN.addItem "uid = " & strUID 'cDSN.addItem "TLO = O" 'cDSN.addItem "FBS = 60000" 'cDSN.addItem "FWC = F" 'cDSN.addItem "CSR = F" 'cDSN.addItem "MDI = Me" 'cDSN.addItem "MTS = T" 'cDSN.addItem "DPM = F" 'cDSN.addItem "NUM = NLS" 'cDSN.addItem "BAM = IfAllSuccessful" 'cDSN.addItem "BTD = F" 'cDSN.addItem "rst = T" 'cDSN.addItem "LOB = T" 'cDSN.addItem "FDL = 10" 'cDSN.addItem "FRC = 10" 'cDSN.addItem "QTO = T" 'cDSN.addItem "FEN = T" 'cDSN.addItem "XSM = Default" 'cDSN.addItem "EXC = F" 'cDSN.addItem "APA = T" 'cDSN.addItem "DBA = W" 'cDSN.addItem "DBQ = " & strPWD 'cDSN.addItem "SERVER = " & strServerName cDSN.addItem "DSN=" & strDSName cDSN.addItem "PWD=" & strPWD cDSN.addItem "Server=" & strServerName cDSN.addItem "UID=" & strUID cDSN.addItem "DESCRIPTION=AUTO_GENERATED" 'cDSN.addItem "DSN=TKOTRIP2" ' & strDSN 'cDSN.addItem "PWD=TKOTRIP2" ' & strPWD 'cDSN.addItem "Server=TKOTRIP2" ' & strServerName 'cDSN.addItem "UID=TKOTRIP2" ' & strUID 'cDSN.addItem "DESCRIPTION=GEN" 'cDSN.addItem "DATABASE=TKOTRIP2" cDSN.addItem "" lngRequest = SQLConfigDataSource(vbAPINull, ODBC_ADD_SYS_DSN, strDriver, cDSN.join(vbNullChar)) 'If lngRequest = 0 Then ' MsgBox "ODBCの登録に失敗しました!", vbCritical, "ODBC登録エラー" 'End If
End Sub
Option Compare Database
Public xls As Excel.Application
Private Sub Class_Initialize()
Set xls = New Excel.Application
End Sub
Private Sub Class_Terminate()
On Error Resume Next xls.Quit Set xls = Nothing
End Sub
Option Compare Database Option Explicit
Public mField As field
Public name As String
Public AllowZeroLength? As Boolean
Public Sub setField(fld As field)
Set mField = fld name = fld.name
End Sub
'DAOフィールドにパラメータを追加 Public Function cloneParam(fld As DAO.field) As DAO.field
'fld.AllowZeroLength fld.DefaultValue = mField.OriginalValue
' fld.Size = mField.DefinedSize? ' fld.Attributes = mField.Attributes ' fld.DataFormat? = mField.DataFormat? ' fld.DefinedSize? = mField.DefinedSize? ' fld.name = mField.name ' fld.NumericScale? = mField.NumericScale? ' fld.OriginalValue? = mField.OriginalValue? ' fld.Precision = mField.Precision ' fld.Properties = mField.Properties ' fld.Status = mField.Status ' fld.Type = mField.Type ' fld.UnderlyingValue? = mField.UnderlyingValue? ' fld.Value = mField.Value
Set cloneParam = fld
End Function
'オラクルの検索結果などをアクセスに格納できる型に変換 Public Function getMDBType()
'参考:http://www.ruriplus.com/msaccess/Exp/exp0142.htm 'dbText 'テキスト型 'dbMemo 'メモ型 'dbByte 'バイト型 'dbInteger '整数型 'dbLong '長整数型 'dbSingle '単精度浮動小数点型 'dbDouble '倍精度浮動小数点型 'dbDate '日付/時刻型 'dbCurrency '通貨型 'dbLong 'Attributes : dbAutoIncrField 'オートナンバー型 'dbBoolean 'Yes/No型 'dbLongBinary 'OLE オブジェクト型 'dbMemo 'Attributes : dbHyperLink 'ハイパーリンク型 Select Case mField.Type Case adBigInt getMDBType = dbLong Case adBinary getMDBType = dbLongBinary Case adBoolean getMDBType = dbBoolean Case adBSTR getMDBType = dbMemo Case adChapter getMDBType = dbMemo Case adChar getMDBType = dbText Case adCurrency getMDBType = dbCurrency Case adDate getMDBType = dbDate Case adDBTime getMDBType = dbDate Case adDBTimeStamp getMDBType = dbDate Case adDecimal getMDBType = dbCurrency Case adDouble getMDBType = dbDouble Case adEmpty getMDBType = dbMemo Case adError getMDBType = dbMemo Case adFileTime getMDBType = dbDate Case adGUID getMDBType = dbMemo Case adIDispatch getMDBType = dbMemo Case adInteger getMDBType = dbInteger Case adIUnknown getMDBType = dbMemo Case adLongVarBinary getMDBType = dbLongBinary Case adLongVarChar getMDBType = dbMemo Case adLongVarWChar getMDBType = dbMemo Case adNumeric getMDBType = dbDouble Case adPropVariant getMDBType = dbMemo Case adSingle getMDBType = dbSingle Case adSmallInt getMDBType = dbInteger Case adTinyInt getMDBType = dbInteger Case adUnsignedBigInt getMDBType = dbLong Case adUnsignedInt getMDBType = dbLong Case adUnsignedSmallInt getMDBType = dbLong Case adUnsignedTinyInt getMDBType = dbLong Case adUserDefined getMDBType = dbMemo Case adVarBinary getMDBType = dbLongBinary Case adVarChar getMDBType = dbMemo Case adVariant getMDBType = dbMemo Case adVarNumeric getMDBType = dbMemo Case adWChar getMDBType = dbMemo Case Else getMDBType = mField.Type End Select
End Function
Private Sub Class_Initialize()
AllowZeroLength = True
End Sub
Option Compare Database Option Explicit
Public mCol As Collection
Private Sub Class_Initialize()
Set mCol = New Collection
End Sub
Public Sub addItem(cField As clsField)
mCol.Add cField, cField.name
End Sub
Public Function count() As Integer
count = mCol.count
End Function
Public Function getItem(index As Variant) As clsField
Set getItem = mCol.Item(index)
End Function
Option Compare Database
Option Explicit
Public fso As New FileSystemObject? Public st As TextStream? Public history As New clsCollection
Public Sub openLogFile?(strLogFilePath? As String)
If fso.FileExists(strLogFilePath) Then Set st = fso.OpenTextFile(strLogFilePath, ForAppending) Else Set st = fso.CreateTextFile(strLogFilePath, True) End If
End Sub
Public Sub log(message As String)
Dim strMessage As String If UBound(Split(message)) > 0 Then strMessage = Now & ":" & vbCrLf & message st.WriteLine Now & ":" & vbCrLf & message p strMessage history.addItem message Else strMessage = Now & ":" & message st.WriteLine Now & ":" & message p strMessage history.addItem message End If
End Sub
Public Sub p(message As Variant)
Debug.Print message
End Sub
Public Function msgboxWithLog?(Prompt As String, Optional Buttons As VbMsgBoxStyle? = vbOKOnly, Optional Title As String = "snapSchema") As VbMsgBoxResult?
log Replace(Prompt, Chr(10), vbCrLf) msgboxWithLog = MsgBox(Prompt, Buttons, Title)
End Function
Private Sub Class_Initialize()
End Sub
Private Sub Class_Terminate()
On Error Resume Next st.Close
End Sub
Option Explicit
Public mRecordset As New recordset
Public mNotNullSetting? As New clsCollection
Public Sub setRecordset(recordset As recordset)
Set mRecordset = recordset
End Sub
Private Sub Class_Terminate()
On Error Resume Next mRecordset.Close Set mRecordset = Nothing
End Sub
'レコードセットの中身をDBに保存する Public Sub createTable(tablename As String, Optional dbname As String = "")
'DBをオープン Dim cDB As clsDB Set cDB = New clsDB cDB.OpenDB dbname 'TableDefの作成 Dim cTabledef As clsTableDef Set cTabledef = cDB.CreateTableDef(tablename) 'フィールドを追加 cTabledef.addFieldByFieldList getFieldList
'反映 cTabledef.Refresh
End Sub
Public Function getFieldList?() As clsFieldList?
Dim ret As clsFieldList Set ret = New clsFieldList Dim i As Integer Dim newField As clsField For i = 0 To mRecordset.Fields.count - 1 Set newField = New clsField newField.setField mRecordset.Fields.Item(i) If mNotNullSetting.isExist(mRecordset.Fields.Item(i).name) Then newField.AllowZeroLength = False End If ret.addItem newField Next Set getFieldList = ret
End Function
'savetablename保存先のテーブル名 Public Sub save(savetablename As String, Optional notNullList? As clsCollection = Nothing)
If TypeName(notNullList) = "Nothing" Then Set notNullList = New clsCollection End If
'テーブル作成準備 Dim conMDB As clsConnection Set conMDB = New clsConnection conMDB.openMDB
'すでに存在していればドロップ Dim tableListMDB As clsTableList Set tableListMDB = conMDB.getTableList tableListMDB.drop savetablename '再度テーブル一覧を取得 Dim con As clsConnection Set con = New clsConnection con.openMDB Set tableListMDB = con.getTableList Dim cRecordset As New clsRecordset cRecordset.setRecordset mRecordset 'NotNull格納 Set cRecordset.mNotNullSetting = notNullList 'レコード元にテーブルが作成される tableListMDB.setDataByRecordset savetablename, cRecordset
End Sub
'カラム定義の情報を元にオラクル側のテーブルに保存します。 Public Sub saveToOracle?(cCon As clsConnection, strTablename As String, log As clsLog)
'mdbのレコードセットの情報 Dim cFieldList As clsFieldList Set cFieldList = getFieldList
'-----Oracle側の情報収集 Dim cTableList As clsTableList Set cTableList = cCon.getTableList Dim cTable As clsTable Set cTable = cTableList.getItem(strTablename)
Dim cColumnList As clsColumnList Set cColumnList = cTable.getColumnList
Dim rst As New clsRecordset On Error Resume Next cCon.adoCON.BeginTrans rst.mRecordset.Open "select * from " & strTablename, cCon.adoCON, adOpenDynamic, adLockOptimistic, adCmdText
Dim cAndList As clsCollection Set cAndList = cColumnList.getNameList.toUpperCase.matchAnd(rst.getFieldNameList.toUpperCase).matchAnd(getFieldNameList.toUpperCase) Dim i As Integer Dim strDate As String Dim colName As String On Error GoTo error_handle Dim counter As Long counter = 0 If cAndList.count <> 0 Then Do Until mRecordset.EOF counter = counter + 1 DoEvents rst.mRecordset.AddNew For i = 1 To cAndList.count colName = cAndList.getItem(i) On Error GoTo no_fieldname '一致するフィールドがあるかどうか見る。 If rst.mRecordset.Fields(colName).Type = adDBTimeStamp And mRecordset.Fields(colName).Type = adLongVarWChar Then On Error GoTo error_handle '文字列→タイムスタンプパターン strDate = mRecordset.Fields(colName).value 'とりあえずミリ秒を丸めて格納し、後ほどSQLで再度入れる rst.mRecordset.Fields(colName).value = CDate(Left(strDate, 19)) Else '通常のフィールド代入 'If colName = "AAAA" Then Stop On Error GoTo error_handle rst.mRecordset.Fields(colName).value = mRecordset.Fields(colName).value End If Next rst.mRecordset.Update mRecordset.MoveNext Loop cCon.adoCON.CommitTrans Else cCon.adoCON.RollbackTrans End If Exit Sub
error_handle:
If (IsNull(mRecordset.Fields(colName).value)) Then log.msgboxWithLog " テーブル名:" & strTablename & Chr(10) & " カラム名:" & colName & Chr(10) & _ " 値:" & mRecordset.Fields(colName).value & Chr(10) & _ " 行番号:" & counter & Chr(10) & _ "データを見直してください。" & Chr(10) & _ "非NULL項目にNULLを格納しようとしていないかどうか確認をお願いします。:" & Chr(10) & _ " テーブル名:" & strTablename & Chr(10) & _ " カラム名:" & colName & Chr(10) & _ " ErrorDescription:" & Err.Description _ , vbCritical, "Access⇒Oracle 変換中にエラー: " Else log.msgboxWithLog " テーブル名:" & strTablename & Chr(10) & " カラム名:" & colName & Chr(10) & _ " 値:" & mRecordset.Fields(colName).value & Chr(10) & _ " 行番号:" & counter, vbCritical, "Access⇒Oracle 変換中にエラー: " & Chr(10) & _ " ErrorDescription:" & Err.Description & _ "データを見直してください。" End If cCon.adoCON.RollbackTrans Dim yesno As Long yesno = MsgBox("テーブル:" & strTablename & "の処理をスキップしますか。" & Chr(10) & _ " ErrorDescription:" & Err.Description & Chr(10) & _ "[再試行] -> デバックモードにした後エラー表示を行い再試行可能にする" & Chr(10) & _ "[中止] -> デバック状態にして停止しますので、コードの解析が必要ない場合は終了してください。" & Chr(10) & _ "[無視] -> このテーブルについてなにもしない (次のテーブルの処理があれば、次のテーブルを処理する)", vbAbortRetryIgnore) If yesno = vbRetry Then Stop Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext ElseIf yesno = vbIgnore Then Exit Sub ElseIf yesno = vbAbort Then Stop End If Exit Sub
no_fieldname:
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub
Public Function getFieldNameList?() As Object
Dim res As New clsCollection Dim fld As field For Each fld In mRecordset.Fields res.addItem fld.name Next Set getFieldNameList = res
End Function
Private Function hasField(rs1 As recordset, name As String) As Boolean
On Error GoTo HaveNot Dim dummy As String dummy = rs1.Fields(name).name hasField = True Exit Function
HaveNot?:
hasField = False
End Function
Private Sub p(message As String)
Debug.Print message
End Sub
'タイムスタンプのミリ秒形式でADOを使って格納できなかったため、カラム定義の情報を元にオラクル側のテーブルに保存します。 Public Sub saveToOracleTimeStamp?(cCon As clsConnection, strTablename As String, log As clsLog)
'mdbのレコードセットの情報 Dim cFieldList As clsFieldList Set cFieldList = getFieldList
'-----Oracle側の情報収集 Dim cTableList As clsTableList Set cTableList = cCon.getTableList Dim cTable As clsTable Set cTable = cTableList.getItem(strTablename)
Dim cColumnList As clsColumnList Set cColumnList = cTable.getColumnList 'オラクルのカラムリストよりタイムスタンプのカラムを抽出 Dim cTimeStampColumnList As clsColumnList Set cTimeStampColumnList = cColumnList.getTimeStampColumnList 'タイムスタンプがない場合は何もしない If cTimeStampColumnList.count = 0 Then Exit Sub '主キーを抽出 Dim cPKColumnList As clsColumnList Set cPKColumnList = cTable.getPKColumns 'プライマリキーがない場合は何もしない If cPKColumnList.count = 0 Then Exit Sub Dim i As Integer Dim j As Integer Dim strSQL As String cCon.adoCON.BeginTrans Do Until mRecordset.EOF DoEvents 'SQL代入文を生成 strSQL = "UPDATE " & strTablename & " SET " For i = 1 To cTimeStampColumnList.count If i <> 1 Then strSQL = strSQL + "," End If strSQL = strSQL & cTimeStampColumnList.getItem(i).mColumn.name & "='" & mRecordset.Fields(cTimeStampColumnList.getItem(i).mColumn.name).value & "'" Next strSQL = strSQL + " WHERE " 'プライマリキーで絞り込む For i = 1 To cPKColumnList.count If i <> 1 Then strSQL = strSQL + " AND " End If strSQL = strSQL & cPKColumnList.getItem(i).mColumn.name & "='" & mRecordset.Fields(cPKColumnList.getItem(i).mColumn.name).value & "'" Next 'SQL実行 cCon.adoCON.execute strSQL mRecordset.MoveNext Loop cCon.adoCON.CommitTrans
End Sub
Function getList(colName As String) As clsCollection
Dim ret As New clsCollection mRecordset.MoveFirst Do Until mRecordset.EOF DoEvents ret.addItem mRecordset.Fields(colName).value mRecordset.MoveNext Loop Set getList = ret
End Function
Option Explicit
Public mTable As ADOX.table Public name As String
Public Sub setTable(table As ADOX.table)
Set mTable = table name = Trim(table.name)
End Sub
Public Function getColumnList?() As clsColumnList?
Dim ret As clsColumnList Set ret = New clsColumnList ret.setTable mTable Set getColumnList = ret
End Function
Public Sub p(message As Variant)
Debug.Print message
End Sub
Public Function getColumnScheme?() As clsRecordset
'スキーマ取得用 ADOXではOracleのTIMESTAMPもDATEも区別していなかったためスキーマ取得クエリーを発行する。 Dim strSchema As String strSchema = "SELECT C.* FROM USER_TAB_COLUMNS C WHERE C.TABLE_NAME = '$TABLENAME$'" strSchema = Replace(strSchema, "$TABLENAME$", name) '検索処理 Dim con As Connection Set con = mTable.ParentCatalog.ActiveConnection Dim rs As recordset Set rs = con.execute(strSchema) Dim cRecordset As clsRecordset Set cRecordset = New clsRecordset cRecordset.setRecordset rs Set getColumnScheme = cRecordset
End Function
' Public Function getPKColumnRecordset?() As clsRecordset
Dim ret As clsRecordset Set ret = New clsRecordset Dim strSchema As String strSchema = "SELECT B.CONSTRAINT_NAME,A.INDEX_NAME,A.COLUMN_NAME " & _ " FROM USER_IND_COLUMNS A,USER_CONSTRAINTS B" & _ " WHERE A.INDEX_NAME = B.INDEX_NAME" & _ " AND CONSTRAINT_TYPE='P'" & _ " AND A.TABLE_NAME = '$TABLENAME$'" & _ " ORDER BY B.CONSTRAINT_NAME,A.INDEX_NAME,A.COLUMN_POSITION;" strSchema = Replace(strSchema, "$TABLENAME$", name) '検索処理 Dim con As Connection Set con = mTable.ParentCatalog.ActiveConnection Dim rs As recordset Set rs = con.execute(strSchema) ret.setRecordset rs Set getPKColumnRecordset = ret
End Function
Public Function getConstraintColumnRecordset?() As clsRecordset
Dim ret As clsRecordset Set ret = New clsRecordset Dim strSchema As String strSchema = "SELECT" & _ " A.COLUMN_NAME AS NAME , B.SEARCH_CONDITION AS COND " & _ " FROM " & _ " USER_CONSTRAINTS B,USER_CONS_COLUMNS A " & _ " WHERE " & _ " B.TABLE_NAME = '$TABLENAME$' " & _ " AND " & _ " B.CONSTRAINT_NAME = A.CONSTRAINT_NAME " & _ " AND " & _ " B.CONSTRAINT_TYPE = 'C'" & _ " ORDER BY" & _ " A.COLUMN_NAME;" strSchema = Replace(strSchema, "$TABLENAME$", name) '検索処理 Dim con As Connection Set con = mTable.ParentCatalog.ActiveConnection Dim rs As recordset Set rs = con.execute(strSchema) ret.setRecordset rs Set getConstraintColumnRecordset = ret
End Function
Public Sub drop()
mTable.ParentCatalog.Tables.Delete mTable.name
End Sub
Public Sub setDataByRecordset?(rs As clsRecordset)
Dim rst As DAO.recordset Dim db As clsDB Set db = New clsDB db.OpenDB Dim cColumnNameList As clsCollection Set cColumnNameList = getColumnList.getNameList Set rst = db.mDB.OpenRecordset(name, dbOpenTable, dbAppendOnly) Dim i As Integer Dim strFieldName As String Do Until rs.mRecordset.EOF DoEvents rst.AddNew For i = 1 To cColumnNameList.count strFieldName = cColumnNameList.getStringItem(i) rst.Fields(strFieldName).value = rs.mRecordset.Fields(strFieldName).value Next rst.Update rs.mRecordset.MoveNext Loop rst.Close
End Sub
'全件取得 Public Function toRecordset() As clsRecordset
Dim con As Connection Set con = mTable.ParentCatalog.ActiveConnection Dim rs As recordset Set rs = con.execute(getSQLAllSelect & mTable.name) Dim ret As clsRecordset Set ret = New clsRecordset ret.setRecordset rs Set toRecordset = ret
End Function
Public Function getSQLAllSelect?() As String
Dim ret As String On Error GoTo mdbSQL 'タイムスタンプ型をもっていないかどうか確認する。 Dim cRecordset As clsRecordset Set cRecordset = getColumnScheme On Error GoTo 0 Dim cFieldList As Fields Dim i As Integer ret = "SELECT " i = 1 Do Until cRecordset.mRecordset.EOF DoEvents If i <> 1 Then ret = ret & "," End If Set cFieldList = cRecordset.mRecordset.Fields If InStr(1, cFieldList.Item("DATA_TYPE").value, "TIMESTAMP") = 0 Then ret = ret & cFieldList.Item("COLUMN_NAME").value Else ret = ret & "TO_CHAR(" & cFieldList.Item("COLUMN_NAME").value & ",'YYYY/MM/DD HH24:MI:SS.FF') AS " & cFieldList.Item("COLUMN_NAME").value End If i = i + 1 cRecordset.mRecordset.MoveNext Loop getSQLAllSelect = ret & " FROM " Exit Function
mdbSQL:
ret = "SELECT * FROM " getSQLAllSelect = ret
End Function
Public Function getPKColumns() As clsColumnList?
Dim ret As New clsColumnList Dim cPKList As clsRecordset Set cPKList = getPKColumnRecordset Dim cColList As clsColumnList Set cColList = getColumnList Do Until cPKList.mRecordset.EOF ret.addItem cColList.getItem(cPKList.mRecordset.Fields("COLUMN_NAME").value) cPKList.mRecordset.MoveNext Loop Set getPKColumns = ret
End Function
Public Function addPK(pkList As clsColumnList?)
'検索処理 If pkList.count <> 0 Then Dim con As Connection Set con = mTable.ParentCatalog.ActiveConnection con.execute "ALTER TABLE " + name + " ADD CONSTRAINT PrimaryKey PRIMARY KEY (" + pkList.getNameList.join(",") + ");" End If
End Function
Public Function addConstraint(constraintList As clsRecordset)
'検索処理 Dim con As Connection Set con = mTable.ParentCatalog.ActiveConnection Dim strCond As String Dim strName As String Do Until constraintList.mRecordset.EOF DoEvents strName = constraintList.mRecordset.Fields(0) strCond = constraintList.mRecordset.Fields(1) If InStr(1, strCond, "NOT NULL") <> 0 Then 'con.execute "ALTER TABLE " & name & " ALTER COLUMN " & strName & " " & getColType(strName) & " NOT NULL;" End If constraintList.mRecordset.MoveNext Loop
' Dim i As Integer ' Dim ColumnsNameList? As clsCollection ' Set ColumnsNameList? = constraintList.getFieldNameList?("COLUMN_NAME") ' ' Dim constraintTypeList? As clsCollection ' Set constraintTypeList? = constraintList.getFieldNameList?("SEARCH_CONDITION") ' ' ' For i = 1 To ColumnsNameList?.count ' If InStr?(1, constraintTypeList?.getItem(i), "NOT NULL") Then ' con.execute "ALTER TABLE " + name + " ADD CONSTRAINT NOT NULL (" + ColumnsNameList?.getItem(i) + ");" ' End If ' Next
End Function
Public Function getNotNullList?() As clsCollection
Dim ret As New clsCollection Dim rs As clsRecordset Set rs = getConstraintColumnRecordset rs.mRecordset.MoveFirst Do Until rs.mRecordset.EOF DoEvents p rs.mRecordset.Fields(0) 'p rs.mRecordset.Fields(1) 'If InStr(1, castNull(rs.mRecordset.Fields("COND")), "NOT NULL") <> 0 Then ret.addWithKey rs.mRecordset.Fields("Name"), "TRUE" 'End If rs.mRecordset.MoveNext Loop Set getNotNullList = ret
End Function
Private Function castNull(value As Variant) As String
If IsNull(value) Then castNull = "" Else castNull = CStr(value) End If
End Function
Option Compare Database Option Explicit
Public mTableDef? As DAO.tabledef Public mDB As DAO.database
Public Sub setTableDef?(tabledef As tabledef, db As database)
Set mTableDef = tabledef Set mDB = db
End Sub
Public Sub Refresh()
mDB.TableDefs.Append mTableDef mDB.TableDefs.Refresh
End Sub
Public Sub addField(cField As clsField)
Dim fld As DAO.field Set fld = mTableDef.CreateField(cField.name, cField.getMDBType()) On Error Resume Next If cField.AllowZeroLength Then fld.Required = False fld.AllowZeroLength = True Else fld.Required = True fld.AllowZeroLength = False End If On Error GoTo 0 mTableDef.Fields.Append fld
End Sub
Public Sub addFieldByFieldList?(list As clsFieldList?)
Dim i As Integer On Error GoTo err_handle For i = 1 To list.count Dim newItem As clsField Set newItem = list.getItem(i) Debug.Print newItem.name addField newItem Next Exit Sub
err_handle:
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub
'メッセージを表示 Private Sub p(message As Variant)
Debug.Print message
End Sub
Option Explicit
Private mCol As Collection Private mCon As ADODB.Connection
Private Sub Class_Initialize()
Set mCol = New Collection
End Sub
Public Function getItem(name As Variant) As clsTable
If IsNumeric(name) Then Set getItem = mCol.Item(name) Else Set getItem = mCol.Item(Trim(name)) End If
End Function
Public Sub setConnection(con As ADODB.Connection, cat As ADOX.Catalog)
Set mCon = con Dim TB As ADOX.table Dim cTable As clsTable clearAll For Each TB In cat.Tables If (TB.Type = "TABLE") And (InStr(1, TB.name, "$") = 0) Then Set cTable = New clsTable cTable.setTable TB On Error Resume Next 'On Error GoTo error_handler addItem cTable On Error GoTo 0 ElseIf TB.Type <> "SYNONYM" Then 'p TB.Type & ":" & TB.name End If Next TB Exit Sub
error_handler:
p TB.name & "は追加済み" Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub
Public Sub clearAll()
Dim i As Integer For i = count To 1 Step -1 mCol.Remove i Next
End Sub
Public Sub addItem(cTable As clsTable)
mCol.Add cTable, Trim(cTable.mTable.name)
End Sub
Public Function count() As Integer
count = mCol.count
End Function
'指定したカラムがどのテーブルで使用されているか Public Function findColumn(name As String) As clsTableList?
Dim ret As clsTableList Set ret = New clsTableList Dim i As Integer For i = 1 To count DoEvents If getItem(i).getColumnList.isExist(Trim(name)) Then ret.addItem getItem(i) End If Next Set findColumn = ret
End Function
'テーブル一覧表示 Public Sub showTableList?()
Dim i As Integer For i = 1 To count p getItem(i).mTable.name Next
End Sub
Public Function getTableNameList?() As clsCollection
Dim ret As New clsCollection Dim i As Integer For i = 1 To count ret.mCol.Add getItem(i).mTable.name Next Set getTableNameList = ret.getReduceList("MGMT_.*").getReduceList("SYS_.*").getReduceList(".*_TAB").getReduceList("ORD_.*").getReduceList("SDO_.*").getReduceList("OGIS_.*").getReduceList(".*PARTITION.*").getReduceList("LBAC_AUDIT_ACTIONS").getReduceList("SESSINFO")
End Function
Sub p(message As String)
Debug.Print message
End Sub
Public Function isExist(tablename As String) As Boolean
Dim dummy As Object On Error GoTo empt Set dummy = getItem(tablename) isExist = True Exit Function
empt:
isExist = False
End Function
Public Sub drop(tablename As String)
If isExist(tablename) Then getItem(tablename).drop End If
End Sub
Public Sub setDataByRecordset?(tablename As String, rs As clsRecordset)
If Not isExist(tablename) Then
'テーブル作成 rs.createTable tablename Dim cTable As clsTable Set cTable = New clsTable Dim cat As New Catalog Set cat.ActiveConnection = mCon cTable.setTable cat.Tables.Item(tablename) addItem cTable End If getItem(tablename).setDataByRecordset rs
End Sub
Option Compare Database
Option Explicit
Public alreadyOpened As Boolean
Public mWorkbook As Workbook
Public Sub OpenWorkbook?(xls As Excel.Application, wbpath As String, Optional flgReadOnly? As Boolean = True)
On Error GoTo NEWOPEN
Dim wb As Workbook Dim fso As New FileSystemObject Dim wbname As String wbname = fso.GetFile(wbpath).name
Set mWorkbook = xls.Workbooks.Item(wbname) alreadyOpened = True Exit Sub
NEWOPEN:
On Error GoTo 0 alreadyOpened = False Set mWorkbook = xls.Workbooks.Open(wbpath, , flgReadOnly)
End Sub
Private Sub Class_Initialize()
alreadyOpened = False
End Sub
Private Sub Class_Terminate()
If (Not alreadyOpened) Then On Error Resume Next mWorkbook.Close mWorkbook.Quit End If
End Sub
Public Function getTableList?() As clsCollection
Dim ret As New clsCollection
Dim tablename As String
Dim ws As Worksheet Set ws = mWorkbook.Sheets("テーブル一覧") Dim i As Integer Dim cel As Range i = 0 Set cel = ws.Cells(7 + i, 17) 'R列 ... 17 While cel.value <> "" DoEvents ret.addItem cel.value i = i + 1 Set cel = ws.Cells(7 + i, 17) 'R列 ... 17 Wend Set getTableList = ret Exit Function
End Function
Option Explicit
Public ados As New ADODB.Stream
Public path As String 'Public tmpPath As String
Public Sub load(path As String) ', tmpPath As String)
ados.LoadFromFile path
End Sub
Public Sub save(Optional strPath As String = "") ', tmpPath As String)
' バイナリモードにするためにPositionを一度0に戻す ' Readするためにはバイナリタイプでないといけない ados.Position = 0 ados.Type = adTypeBinary ' Positionを3にしてから読み込むことで最初の3バイトをスキップする ' つまりBOMをスキップします ados.Position = 3 Dim bin: bin = ados.Read ados.Close ' 読み込んだバイナリデータをバイナリデータとしてファイルに出力する ' ここは一般的な書き方なので説明を省略 Dim stm As ADODB.Stream Set stm = New ADODB.Stream stm.Type = adTypeBinary stm.Open stm.Write bin
If strPath = "" Then stm.SaveToFile path, adSaveCreateOverWrite ' force overwrite Else stm.SaveToFile strPath, adSaveCreateOverWrite ' force overwrite End If stm.Close
End Sub
Public Sub close_()
ados.Close
End Sub
Private Sub Class_Initialize()
ados.Type = adTypeText ados.Charset = "UTF-8" ados.Open
End Sub
Private Sub Class_Terminate()
On Error Resume Next ados.Close Set ados = Nothing
End Sub
Public Function EOF()
EOF = ados.EOS
End Function
Public Function readLine() As String
readLine = ados.ReadText(adReadLine)
End Function
Public Sub writeLine(line As String)
ados.WriteText line, adWriteLine
End Sub