'===============(標準モジュール)=====================================
Option Explicit
'+------------------------------------------------------------------------------
'| 共通変数
'| 参照設定：Microsoft Activex Data Object X.X Library と
'| 参照設定：Microsoft ADO Ext.X.X for DDL and Security が必要
'+------------------------------------------------------------------------------
Public Ps_Mdb As String 'ACCESS MDB FILE
Public JetCn As ADODB.Connection 'コネクション
Public JetRs As ADODB.Recordset 'レコードセット
Public ErrMsg As String 'エラーメッセージ
'+------------------------------------------------------------------------------
'| 処理名 ：ボタン「TABLE」
'+------------------------------------------------------------------------------
Sub テーブル一覧()
On Error GoTo Err_Han
ErrMsg = ""
' 画面固定
Application.ScreenUpdating = False
Application.Speech.Speak "TABLE LISTING"
' データベース接続
Call PS_DbConn
If ErrMsg <> "" Then GoTo TBL_END
Dim MyCtg As New ADOX.Catalog
Dim MyTbl As ADOX.Table
Dim iRow As Integer
' ACCESS(ADOX)接続
MyCtg.ActiveConnection = JetCn
' 項目リストクリア
Worksheets("COLUMN").Select
Range(Range("A2:C2"), Selection.End(xlDown)).ClearContents
' テーブルリストクリア
Worksheets("TBL").Select
Range(Range("A2:D2"), Selection.End(xlDown)).ClearContents
' データを取得(カタログ情報)
iRow = 1
For Each MyTbl In MyCtg.Tables
If (MyTbl.Type = "TABLE" Or MyTbl.Type = "VIEW") And _
Left(MyTbl.Name, 1) <> "~" Then
If UserForm1.TextBox1.Text = "" Or _
InStr(MyTbl.Name, UserForm1.TextBox1.Text) > 0 Then
iRow = iRow + 1
Worksheets("TBL").Cells(iRow, 1).Value = MyTbl.Name
Worksheets("TBL").Cells(iRow, 2).Value = MyTbl.Type
Worksheets("TBL").Cells(iRow, 3).Value = MyTbl.DateCreated
Worksheets("TBL").Cells(iRow, 4).Value = MyTbl.DateModified
End If
End If
Next MyTbl
' リストボックス範囲の変更
If iRow < 2 Then iRow = 2
Application.Names("テーブル一覧").RefersTo = "=TBL!$A$2:$A$" & iRow
Worksheets("TBL").Range("A1").Select
TBL_END:
' オブジェクト消去
Set MyTbl = Nothing
Set MyCtg = Nothing
' データベース接続切断(NO COMMIT)
Call PS_DbDisConn(False)
' 画面固定解除
Application.ScreenUpdating = True
If ErrMsg <> "" Then
MsgBox ErrMsg
Exit Sub
End If
Unload UserForm1
UserForm1.Show
Exit Sub
Err_Han:
If ErrMsg = "" Then
ErrMsg = Err.Description
End If
GoTo TBL_END
End Sub
'+------------------------------------------------------------------------------
'| 処理名 ：ボタン「COLUMN」
'+------------------------------------------------------------------------------
Sub 項目一覧()
On Error GoTo Err_Han
ErrMsg = ""
If UserForm1.ListBox1.Value = "" Then
Application.Speech.Speak "You Don't select Tables"
MsgBox "テーブルが選択されていません！"
Err.Raise 0
Exit Sub
End If
' 画面固定
Application.ScreenUpdating = False
Application.Speech.Speak "COLUMN LISTING"
' データベース接続
Call PS_DbConn
If ErrMsg <> "" Then GoTo ITEM_END
Dim stSQL As String
Dim iRow As Integer: iRow = 1
Dim i As Integer
Dim j As Integer: j = 0
Dim k As Integer: k = 0
Dim m As Integer
Dim stTblNo As String: stTblNo = ""
' 選択ありを数え、マークする
For i = 0 To UserForm1.ListBox1.ListCount - 1
If UserForm1.ListBox1.Selected(i) Then
j = j + 1
Worksheets("TBL").Cells(i + 2, 2).Value = 1 'FLG ON
Else
Worksheets("TBL").Cells(i + 2, 2).Value = "" 'FLG OFF
End If
Next i
' 項目リストクリア
Worksheets("COLUMN").Select
Application.Goto Reference:="項目一覧"
Selection.ClearContents
iRow = 1
For i = 0 To UserForm1.ListBox1.ListCount - 1
If UserForm1.ListBox1.Selected(i) Then
If j > 1 Then '複数テーブル選択か？
k = k + 1
stTblNo = "T" & k & "."
End If
stSQL = "SELECT * FROM " & UserForm1.ListBox1.List(i)
Set JetRs = JetCn.Execute(stSQL)
' 項目展開
For m = 0 To JetRs.Fields.Count - 1
iRow = iRow + 1
Worksheets("COLUMN").Cells(iRow, 1).Value = stTblNo & JetRs.Fields(m).Name '項目名
Select Case JetRs.Fields(m).Type '項目型
Case adDate, adDBTimeStamp
Worksheets("COLUMN").Cells(iRow, 2).Value = "日付/時刻型"
Case adChar, adLongVarChar, adVarWChar, adLongVarWChar
Worksheets("COLUMN").Cells(iRow, 2).Value = "テキスト型"
Case adInteger, adDouble, adNumeric, adSmallInt, adUnsignedTinyInt
Worksheets("COLUMN").Cells(iRow, 2).Value = "数値型"
Case adBinary, adVarBinary
Worksheets("COLUMN").Cells(iRow, 2).Value = "バイナリ型"
Case adBinary, adCurrency
Worksheets("COLUMN").Cells(iRow, 2).Value = "通貨型"
Case adBoolean
Worksheets("COLUMN").Cells(iRow, 2).Value = "Yes/No型"
Case Else
Worksheets("COLUMN").Cells(iRow, 2).Value = JetRs.Fields(m).Type
End Select
Select Case Worksheets("COLUMN").Cells(iRow, 2).Value '項目長
Case "数値型", "通貨型"
Worksheets("COLUMN").Cells(iRow, 3).Value = JetRs.Fields(m).Precision & "," _
& JetRs.Fields(m).NumericScale
Case "日付/時刻型", "Yes/No型"
Worksheets("COLUMN").Cells(iRow, 3).Value = ""
Case Else
Worksheets("COLUMN").Cells(iRow, 3).Value = JetRs.Fields(m).DefinedSize
End Select
Next m
End If
Next i
' リストボックス範囲の変更
If iRow < 2 Then iRow = 2
Application.Names("項目一覧").RefersTo = "=COLUMN!$A$2:$C$" & iRow
Worksheets("COLUMN").Range("A2").Select
ITEM_END:
' データベース接続切断(NO COMMIT)
Call PS_DbDisConn(False)
' 画面固定解除
Application.ScreenUpdating = True
If ErrMsg <> "" Then
MsgBox ErrMsg
Exit Sub
End If
Unload UserForm1
UserForm1.Show
Exit Sub
Err_Han:
If ErrMsg = "" Then
ErrMsg = Err.Description
End If
GoTo ITEM_END
End Sub
'+------------------------------------------------------------------------------
'| 処理名 ：ボタン「SQL実行」
'+------------------------------------------------------------------------------
Sub SQL実行()
On Error GoTo Err_Han
ErrMsg = ""
If UserForm1.TextBox2.Text = "" Then
Application.Speech.Speak "You don't set SQL"
MsgBox "SQLが設定されていません！"
Err.Raise 0
Exit Sub
End If
Dim stSQL As String
Dim i As Integer
' 画面固定
Application.ScreenUpdating = False
' データ取得SQL編集
stSQL = UserForm1.TextBox2.Text
If InStr(stSQL, "WHERE") = 0 And _
InStr(stSQL, "UPDATE") = 0 And _
InStr(stSQL, "INSERT") = 0 Then
stSQL = StrConv(stSQL, vbUpperCase)
End If
If Left(stSQL, 6) = "SELECT" Then
' データベース接続(レコードセットオプション:読み取り専用)
Call PS_DbConn
If ErrMsg <> "" Then GoTo DATA_END
' データを取得
Application.Speech.Speak "SELECT EXECUTE"
Set JetRs = JetCn.Execute(stSQL)
Else
' データベース接続(更新あり)
Call PS_DbConn(False)
If ErrMsg <> "" Then GoTo DATA_END
' データを更新
Application.Speech.Speak "UPDATE EXECUTE"
JetCn.Execute (stSQL)
GoTo HIST_ADD
End If
' データシートクリア
Worksheets("DATA").Select
Cells.Clear
' 項目名展開
For i = 0 To JetRs.Fields.Count - 1
Worksheets("DATA").Cells(1, i + 1).Value = JetRs.Fields(i).Name
Select Case JetRs.Fields(i).Type
Case adDate, adDBTimeStamp
Worksheets("DATA").Cells(2, i + 1).Value = "日付/時刻型"
Case adChar, adLongVarChar, adVarWChar, adLongVarWChar
Worksheets("DATA").Cells(2, i + 1).Value = "テキスト型"
Case adInteger, adDouble, adNumeric, adSmallInt, adUnsignedTinyInt
Worksheets("DATA").Cells(2, i + 1).Value = "数値型"
Case adBinary, adVarBinary
Worksheets("DATA").Cells(2, i + 1).Value = "バイナリ型"
Case adBinary, adCurrency
Worksheets("DATA").Cells(2, i + 1).Value = "通貨型"
Case adBoolean
Worksheets("DATA").Cells(2, i + 1).Value = "Yes/No型"
Case Else
Worksheets("DATA").Cells(2, i + 1).Value = JetRs.Fields(i).Type
End Select
Next i
Rows("1:2").Interior.ColorIndex = 37
' データ展開
Application.StatusBar = "データ展開中"
Worksheets("DATA").Range("A3").CopyFromRecordset JetRs
If Cells(Rows.Count, 1).Value <> "" Then
Call CSV出力処理
End If
Application.StatusBar = False
HIST_ADD:
' 履歴追加
Worksheets("HIST").Select
Worksheets("HIST").Rows(1).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
stSQL = Replace(stSQL, vbNewLine & " " & vbNewLine, vbNewLine)
stSQL = Replace(stSQL, vbNewLine & vbNewLine, vbNewLine)
Worksheets("HIST").Cells(1, 1).Value = Trim(stSQL)
Worksheets("HIST").Cells(1, 2).Value = Ps_Mdb
' リストボックス範囲の維持(変えない)
Application.Names("実行履歴").RefersTo = "=HIST!$A$1:$A$20"
' データシート表示
ActiveWindow.WindowState = xlNormal
Worksheets("DATA").Select
Worksheets("DATA").Range("A1").Select
DATA_END:
' データベース接続切断
Select Case Left(stSQL, 6)
Case "UPDATE", "DELETE", "INSERT"
Call PS_DbDisConn(True)
Case Else
Call PS_DbDisConn(False)
End Select
' 画面固定解除
Application.ScreenUpdating = True
If ErrMsg <> "" Then
MsgBox ErrMsg
Exit Sub
End If
If Left(stSQL, 6) = "SELECT" Then
UserForm1.Hide
Else
Unload UserForm1
UserForm1.TextBox2.Text = stSQL
UserForm1.Show
End If
Exit Sub
Err_Han:
If ErrMsg = "" Then
ErrMsg = Err.Description
End If
GoTo DATA_END
End Sub
'+------------------------------------------------------------------------------
'| 処理名 ：ボタン「SAVE」
'+------------------------------------------------------------------------------
Sub データセーブ()
Dim FileName As Variant
FileName = Application.GetSaveAsFilename("DATA.xls", "Excel ブック(*.xls),1")
If FileName <> False Then 'ダイアログでキャンセルを選ぶとFALSEで抜ける
Sheets("DATA").Copy
ActiveWorkbook.SaveAs FileName:=FileName, FileFormat:=xlExcel8, _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWindow.Close
End If
End Sub
'+------------------------------------------------------------------------------
'| 処理名 ：ＣＳＶ出力処理
'+------------------------------------------------------------------------------
Sub CSV出力処理()
Application.Speech.Speak "Do You want to write a CSV file?"
If MsgBox("検索件数がシート行限界に達しました" & vbNewLine & "CSVに出力しますか？", vbYesNo) = vbNo Then Exit Sub
Dim FileName As Variant
FileName = Application.GetSaveAsFilename("DATA.csv", "CSV ファィル(*.csv),1")
If FileName = False Then Exit Sub 'ダイアログでキャンセルを選ぶとFALSEで抜ける
Dim outFF As Integer ' FreeFile値
Dim Buf As String: Buf = ""
Dim i As Integer
Dim j As Long: j = 0
outFF = FreeFile
Open FileName For Output As #outFF
For i = 0 To JetRs.Fields.Count - 1
If i > 0 Then Buf = Buf & ","
Buf = Buf & JetRs.Fields(i).Name
Next i
Print #outFF, Buf
JetRs.MoveFirst
Do While Not JetRs.EOF
Select Case JetRs.Fields(0).Type
Case adDate, adDBTimeStamp, adChar, adLongVarChar, adVarWChar, adLongVarWChar
Buf = """" & JetRs.Fields(0).Value & """"
Case Else
Buf = JetRs.Fields(0).Value
End Select
For i = 1 To JetRs.Fields.Count - 1
Select Case JetRs.Fields(i).Type
Case adDate, adDBTimeStamp, adChar, adLongVarChar, adVarWChar, adLongVarWChar
Buf = Buf & ",""" & JetRs.Fields(i).Value & """"
Case Else
Buf = Buf & "," & JetRs.Fields(i).Value
End Select
Next i
Print #outFF, Buf
j = j + 1
If j = Int(j / 100) * 100 Then
Application.StatusBar = "CSV RECORD(現在 " & j & "件目)"
End If
JetRs.MoveNext
Loop
Close #outFF
Application.Speech.Speak "A CSV file writing is completed"
MsgBox FileName & vbNewLine & "に " & j & " 件出力しました"
Application.StatusBar = False
End Sub
'+------------------------------------------------------------------------------
'| 処理名 ：データベース接続
'| 処理内容 ：データベースに接続する
'| 引数 ：(1) (I) Boolean 読込フラグ
'| True=読込のみ,False=更新する
'| 返値 ：なし
'| 備考 ：実行時エラーは上位処理でハンドル
'+------------------------------------------------------------------------------
Private Sub PS_DbConn(Optional pb_Set As Boolean)
On Error GoTo Err_Han
Dim i As Integer
' 共通変数・ホスト、ユーザ、パスワードのいずれかに入力がない場合
If Ps_Mdb = "" Then
i = 2
Do While Worksheets("USER").Cells(i, 1).Value <> ""
If UserForm1.ComboBox1.Value = Worksheets("USER").Cells(i, 1).Value Then
Ps_Mdb = Worksheets("USER").Cells(i, 2).Value 'ACCESS MDB FILR
Exit Do
End If
i = i + 1
Loop
If Ps_Mdb = "" Then
ErrMsg = "USERシートにACCESS MDB情報が設定されていません"
' 実行時エラーを発生させる
Err.Raise 0
Exit Sub
End If
End If
' ACCESS接続
Set JetCn = CreateObject("ADODB.Connection")
With JetCn
.Provider = "Microsoft.Jet.OLEDB.4.0"
If pb_Set Then
.Mode = adModeRead ' 読込のみ
Else
.Mode = adModeReadWrite ' 更新あり
End If
.ConnectionString = (Ps_Mdb)
.Open
End With
' トランザクションの開始
JetCn.BeginTrans
Exit Sub
Err_Han:
ErrMsg = "ACCESS MDB 接続が失敗しました"
Err.Raise 0
Exit Sub
End Sub
'+------------------------------------------------------------------------------
'| 処理名 ：データベース切断
'| 処理内容 ：データベース接続を切断する
'| 引数 ：(1) (I) Boolean トランザクション処理フラグ
'| True=Commitする,False=ロールバックする
'| 返値 ：なし
'+------------------------------------------------------------------------------
Public Sub PS_DbDisConn(pb_Set As Boolean)
If ErrMsg <> "" Then Exit Sub
On Error Resume Next '実行時エラーを無視
'トランザクション処理フラグ = Trueの場合
If pb_Set Then
JetCn.CommitTrans 'トランザクションをコミットする
'トランザクション処理フラグ=Falseの場合
Else
JetCn.RollbackTrans 'トランザクションをロールバックする
End If
' オブジェクト消去
JetRs.Close
Set JetRs = Nothing
JetCn.Close
Set JetCn = Nothing
On Error GoTo 0 '実行時エラーハンドリングリセット
End Sub
' 引数 SheetName のシートが実際にあるかチェックする
Function ExistSheet(SheetName) As Boolean
Dim i As Integer
ExistSheet = False
For i = 1 To Sheets.Count
If StrConv(Sheets(i).Name, vbUpperCase) = StrConv(SheetName, vbUpperCase) Then
ExistSheet = True
Exit For
End If
Next i
End Function
'+------------------------------------------------------------------------------
'| 処理名 ：環境設定
'+------------------------------------------------------------------------------
' シート未設定時(初回のみ)手動実行
Sub 初期シート設定()
Dim NewWorkSheet As Worksheet
Const CFont As String = "HGゴシックM" ' 任意のフォントを設定(お好きなフォント)
If ExistSheet("DATA") = False Then
Set NewWorkSheet = Worksheets.Add(after:=Worksheets(Worksheets.Count)) '-- シートが無ければ追加する
NewWorkSheet.Name = "DATA"
Cells.Select
Selection.Font.Name = CFont
Range("A1").Select
Set NewWorkSheet = Nothing
End If
If ExistSheet("USER") = False Then
Set NewWorkSheet = Worksheets.Add(after:=Worksheets(Worksheets.Count)) '-- シートが無ければ追加する
NewWorkSheet.Name = "USER"
Cells.Select
Selection.Font.Name = CFont
Cells(1, 1).Value = "接続先" ' 見出し(識別名)-- 任意の名称
Cells(1, 2).Value = "ＭＤＢ" ' ACCESS MDB FILE NAME
Cells(1, 7).Value = "選択idx" ' 選択記録用(次回表示時も選択を継続)
Cells(2, 7).Value = 0 ' 先頭が0(初期値)
Range("A2:E2").Select
ActiveWorkbook.Names.Add Name:="接続一覧", RefersTo:="=USER!$A$2:$B$2"
ActiveWorkbook.Names("接続一覧").Comment = "ACCESSの接続情報をコンボボックスに表示する"
Range("A1").Select
Set NewWorkSheet = Nothing
End If
If ExistSheet("TBL") = False Then
Set NewWorkSheet = Worksheets.Add(after:=Worksheets(Worksheets.Count)) '-- シートが無ければ追加する
NewWorkSheet.Name = "TBL"
Cells.Select
Selection.Font.Name = CFont
Cells(1, 1).Value = "TABLE_NAME" ' 見出し
Range("A2:A2").Select
ActiveWorkbook.Names.Add Name:="テーブル一覧", RefersTo:="=TBL!$A$2:$A$2"
ActiveWorkbook.Names("テーブル一覧").Comment = "テーブル一覧情報をリストボックスに表示する"
Range("A1").Select
Set NewWorkSheet = Nothing
End If
If ExistSheet("COLUMN") = False Then
Set NewWorkSheet = Worksheets.Add(after:=Worksheets(Worksheets.Count)) '-- シートが無ければ追加する
NewWorkSheet.Name = "COLUMN"
Cells.Select
Selection.Font.Name = CFont
Cells(1, 1).Value = "COLUMN_NAME" ' 見出し(項目名)
Cells(1, 2).Value = "TYPE" ' 見出し(データタイプ)
Cells(1, 3).Value = "LENGTH" ' 見出し(項目長、但し数値型は編集置換する)
Range("A2:C2").Select
ActiveWorkbook.Names.Add Name:="項目一覧", RefersTo:="=COLUMN!$A$2:$C$2"
ActiveWorkbook.Names("項目一覧").Comment = "項目一覧情報をリストボックスに表示する"
Range("A1").Select
Set NewWorkSheet = Nothing
End If
If ExistSheet("HIST") = False Then
Set NewWorkSheet = Worksheets.Add(after:=Worksheets(Worksheets.Count)) '-- シートが無ければ追加する
NewWorkSheet.Name = "HIST"
Cells.Select
Selection.Font.Name = CFont
Range("A2:A20").Select
ActiveWorkbook.Names.Add Name:="実行履歴", RefersTo:="=HIST!$A$2:$A$20"
ActiveWorkbook.Names("実行履歴").Comment = "実行履歴をリストボックスに表示する"
Range("A1").Select
Set NewWorkSheet = Nothing
End If
' 既定シートは削除する(削除しなくても可)
If ExistSheet("Sheet1") Then
Worksheets("Sheet1").Delete
End If
If ExistSheet("Sheet2") Then
Worksheets("Sheet2").Delete
End If
If ExistSheet("Sheet3") Then
Worksheets("Sheet3").Delete
End If
End Sub
'(次の記事に続く)
' http://blog.goo.ne.jp/frontflug/e/4b7bd96bb47092935d4356fe710ea65d
