そして、I列の1から5行目、下記の情報を入れる
サーバー
DB名
ユーザ
パスワード
接続DBタイプ["SQL Server","MySQL ODBC 5.1 DRIVER"]
※今のところ、MS SQL Serverとmysqlしか対応していない
シート"テーブル一覧"は
Private Sub CommandButton1_Click()
Call getTables
End Sub
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
'MsgBox Target.TextToDisplay
getTableData Target.TextToDisplay
End Sub
モジュールに下記のコード
Public con As ADODB.Connection
Public wb As Workbook
Public st As Worksheet
Public gDB As String
Public gConDriver As String
Dim connectionString As String
Sub initDBcon()
Set wb = ThisWorkbook
Set st = wb.Worksheets("テーブル一覧")
'接続文字列
gConDriver = st.Range("I5")
Select Case gConDriver
Case "SQL Server"
connectionString = "Provider=Sqloledb;" _
& " Data Source=" & st.Range("I1") & ";" _
& " Initial Catalog=" & st.Range("I2") & ";" _
& " Connect Timeout=15;" _
& " user id=" & st.Range("I3") & ";" _
& " password=" & st.Range("I4")
Case "MySQL ODBC 5.1 DRIVER"
connectionString = "Driver={" & gConDriver & "};" _
& " SERVER=" & st.Range("I1") & ";" _
& " DATABASE=" & st.Range("I2") & ";" _
& " USER=" & st.Range("I3") & ";" _
& " PASSWORD=" & st.Range("I4") & ";"
End Select
gDB = st.Range("I2")
'ADODB.Connection生成
Set con = New ADODB.Connection
On Error GoTo Err
'MySQLに接続
con.Open connectionString
Exit Sub
Err:
Set con = Nothing
MsgBox (Err.Description)
End Sub
Sub getTables()
Dim rs As ADODB.Recordset
Dim sqlStr As String
Dim rowNo As Integer
Dim colNo As Integer
Dim item As Variant
Call initDBcon
If con Is Nothing Then
Exit Sub
End If
Application.DisplayAlerts = False
For Each stname In wb.Sheets
If stname.Name <> "テーブル一覧" Then
stname.Delete
End If
Next
Application.DisplayAlerts = True
'SQL文
Select Case gConDriver
Case "SQL Server"
sqlStr = "select table_name from information_schema.tables;"
Case "MySQL ODBC 5.1 DRIVER"
sqlStr = "show tables;"
End Select
'SQL文実行
Set rs = con.Execute(sqlStr)
'シートデータクリア
'st.Cells.Clear
st.Columns("A:A").Clear
rowNo = 1
Do While rs.EOF = False
'データ抽出
For Each item In rs.Fields
st.Range("A" & rowNo).Value = item.Value
st.Range("A" & rowNo).Hyperlinks.Add Anchor:=st.Range("A" & rowNo), _
Address:="", TextToDisplay:=item.Value
Next
rowNo = rowNo + 1
'次のレコード
rs.MoveNext
Loop
'クローズ
con.Close
Set rs = Nothing
Set con = Nothing
Exit Sub
End Sub
Sub getTableData(ByVal srtTableName As String)
Dim stname As Variant
Dim qt As QueryTable
Call initDBcon
For Each stname In wb.Sheets
If stname.Name = srtTableName Then
Exit Sub
End If
Next
wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count)).Name = srtTableName
On Error GoTo Err
Select Case gConDriver
Case "MySQL ODBC 5.1 DRIVER"
With wb.Worksheets(srtTableName).ListObjects.Add(SourceType:=xlSrcExternal, Source:=Array(Array( _
"ODBC;" & connectionString), Array("E=db35211_CustomerMasterList;DefaultTable=Customers;")), _
Destination:=wb.Sheets(srtTableName).Range("$A$1")).QueryTable
.CommandText = Array("Select * FROM " & srtTableName)
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.ListObject.DisplayName = "テーブル_" & gDB & "_" & srtTableName
.Refresh BackgroundQuery:=False
End With
Case "SQL Server"
With wb.Worksheets(srtTableName).ListObjects.Add(SourceType:=xlSrcExternal, Source:=Array( _
"OLEDB;" & connectionString), Destination:=wb.Sheets(srtTableName).Range("$A$1")).QueryTable
.CommandType = xlCmdTable
.CommandText = Array("""" & gDB & """.""dbo"".""" & srtTableName & """")
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.ListObject.DisplayName = "テーブル_" & gDB & "_" & srtTableName
.Refresh BackgroundQuery:=False
End With
End Select
Exit Sub
Err:
Set con = Nothing
MsgBox (Err.Description)
End Sub
