- 追加された行はこの色です。
- 削除された行はこの色です。
*目次 [#z0323312]
#contents
*趣旨 [#c8f06ba8]
何度も同じようなコードをインターネットから探しては
自分のルールに沿ってクラス化してきたが、
何度もやるのはめんどくさくなったから、
頻度の高いところをまとめる。
できるならば、クラスをそのまま貼り付ける。
*ファイル操作 [#mfe5e5c7]
**一時ファイル取得 [#g8a4f38a]
' 一時ファイル名取得用 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
*basMain [#j14dac99]
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
*basReadEntity [#l9343893]
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
*clsCollection [#dac6ff07]
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
*clsColumn [#x6db0b3c]
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
*clsColumnList [#vbfd177a]
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
*clsConnection [#l3a7b91f]
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
*clsDB [#t3d15c78]
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
*clsDSN [#c4c7861e]
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
*clsExcel [#s9c32d58]
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
*clsField [#l7d1ad0c]
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
*clsFieldList [#t5d1f71a]
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
*clsLog [#g46ded57]
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
*clsRecordset [#ue3ca92f]
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
*clsTable [#qc50cc58]
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
*clsTableDef [#r43199b4]
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
*clsTableList [#y7153e9e]
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
*clsWorkbook [#g88400dc]
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
*clsUTF8File [#h9441720]
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