VBA来实现已存在的数据库，取得所有表的结构

问题描述

用VBA来取出MySQL数据库中的所有表的结构后生成一个Excel的文档

首先创建MySQL的数据源，如何创建数据源在前章已经写过，之后把下面的信息填写上即可

在window7 64位系统上面可能会出现错误，出错的原因是因为mysql的驱动问题，你需要安装window7的32位的MySQL驱动。这样就不会出现问题。

在window10上面则没有这种问题。

说明

DSN是你所创建的数据源的名称

SERVER是你本地的数据库

DB是你的数据库的名称

UID是登入数据库的用户名

PWD是登入数据库的密码

SCHEMA是你所创建的数据库的SCHEMA

之后在MysqlDbTable按钮下写入下面的代码即可

'----------------mysqlからテーブル一覧出力---------------------------
Private Sub getMysqlDbTeble_Click()

    Dim fiStr As String
    Dim dsnStr As String
    Dim serverStr As String
    Dim dbStr As String
    Dim uidStr As String
    Dim pwdStr As String
    Dim schemaStr As String

    Dim sheet As Worksheet
    Set sheet = ThisWorkbook.Sheets("Sheet1")
    dsnStr = sheet.Range("C2")
    serverStr = sheet.Range("C3")
    dbStr = sheet.Range("C4")
    uidStr = sheet.Range("C5")
    pwdStr = sheet.Range("C6")
    schemaStr = sheet.Range("C7")

    fiStr = ThisWorkbook.Path & "\QR_DBテーブル一覧.xlsx"
    Dim wb As Workbook
    Set wb = Workbooks.Open(fiStr)

    Dim sht As Object
    Set sht = wb.Sheets("テーブル一覧")
    sht.Range("A3:D" & sht.UsedRange.Rows.Count) = ""

    'MySql接続
    Dim conn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Set conn = New ADODB.Connection
    Set rs = New ADODB.Recordset

    'テーブル情報取得
    conn.ConnectionString = "DSN=" & dsnStr & ";Server=" & serverStr & ";DB=" & dbStr & ";UID=" & uidStr & ";PWD=" & pwdStr & ";OPTION=3;"

    sqlStr = "select TABLE_NAME, TABLE_COMMENT from information_schema.tables where table_schema='" & schemaStr & "'"
    conn.Open connStr

    Set rs = conn.Execute(sqlStr)

    Dim index As Integer
    index =
    While Not rs.EOF
         sht.Range("A" & index) = index -
         sht.Range("B" & index) = rs!TABLE_NAME
         sht.Range("C" & index) = rs!TABLE_COMMENT

        'テーブル定義情報
        Dim shtName As String
        shtName = tebleInfo(conn, wb, rs!TABLE_NAME, rs!TABLE_COMMENT, index)

        sht.Hyperlinks.Add Anchor:=sht.Range("B" & index), Address:="", SubAddress:="'" & shtName & "'" & "!C2"
        rs.MoveNext
        index = index +
    Wend

    rs.Close: Set rs = Nothing
    conn.Close: Set conn = Nothing
    wb.Close savechanges:=False

    MsgBox "完了"
End Sub

'----------------mysqlからテーブル定義出力---------------------------
Function tebleInfo(connTable As ADODB.Connection, wbTable As Workbook, tableNm As String, tableComment As String, idx As Integer)

    Dim rsTable As ADODB.Recordset
    Set rsTable = New ADODB.Recordset

    '検索テーブル定義情報
    sqlStr = "select COLUMN_NAME, COLUMN_COMMENT, COLUMN_KEY, COLUMN_TYPE, COLUMN_DEFAULT ,IS_NULLABLE  from information_schema.columns where TABLE_SCHEMA='XXX_XXX_XXX' and TABLE_NAME = '" & tableNm & "'"
    Set rsTable = connTable.Execute(sqlStr)

    Worksheets("テンプレート").Copy before:=Worksheets("テンプレート")

    'シート名の長さが31文字以内
    Dim sheetNm As String
    If Len(tableNm) >  Then
        sheetNm = Right(tableNm, )
    Else
        sheetNm = tableNm
    End If

    'シート名存在チェック
    Dim flag As Boolean
    flag = SheetIsExist(wbTable, sheetNm)
    If flag Then
        Application.DisplayAlerts = False
        'シート名存在したら、削除
        wbTable.Sheets(sheetNm).Delete
        Application.DisplayAlerts = True

    End If

    ActiveSheet.Name = sheetNm
    Dim shtTable As Object
    Set shtTable = ActiveSheet
    shtTable.Range("C2") = tableNm
    shtTable.Range("E2") = tableComment

    '取得した
    Dim indexTable As Integer
    indexTable =
    While Not rsTable.EOF
        'No
        shtTable.Range("A" & indexTable) = indexTable -
        '項目物理名（EN）
        shtTable.Range("B" & indexTable) = rsTable!COLUMN_NAME
        '項目論理名（CH）
        shtTable.Range("C" & indexTable) = rsTable!COLUMN_COMMENT
        'KEY
        shtTable.Range("D" & indexTable) = rsTable!COLUMN_KEY
        '属性
        shtTable.Range("E" & indexTable) = rsTable!COLUMN_TYPE
        '黙認
        shtTable.Range("F" & indexTable) = rsTable!COLUMN_DEFAULT
        'NULL
        shtTable.Range("G" & indexTable) = rsTable!IS_NULLABLE
        rsTable.MoveNext
        indexTable = indexTable +
    Wend
    tebleInfo = sheetNm
End Function

Function SheetIsExist(wbCheck As Workbook, shtNm As String)

    SheetIsExist = False
    On Error GoTo lab1
    Set shtSheet = wbCheck.Sheets(shtNm)
    If shtSheet Is Nothing Then
        SheetIsExist = False
    Else
        SheetIsExist = True
    End If

    Set shtSheet = Nothing
    Exit Function

lab1:
    SheetIsExist = False
End Function

最总实现的效果：