读取word文件中的数据库表定义，并生成建表sql文件

概要
通过word vba读取word文档，遍历文档中的Tables，
如果table的格式符合预想，则读取数据库定义信息。
根据定义信息生成建表sql语句，并写出到文件。

Option Explicit

Public Const DEFAULT_FILEPATH = "E:\test\"
Public Const DEFAULT_SQL_OUTPUT_PATH = "E:\sql"
Public Const MAX_FILE_COUNT = 5
Public Const MAX_TABLES_IN_DOC = 20
Public Const MAX_COLUMNS_IN_TABLE = 100

Public Type t_columnInfo
    columnName As String
    columnID As String
    columnType As String
    columnIsPK As Boolean
    columnNotNull As Boolean
    columnComment As String
End Type

Public Type t_tableInfo
    tableName As String
    tableID As String
    tableComment As String
    columnCount As Integer
    columns(MAX_COLUMNS_IN_TABLE) As t_columnInfo
End Type

Private Sub getDocInfo(d As Document)
    Dim pagecnt As Integer
    Dim linecnt As Integer
    Dim tablecnt As Integer
    pagecnt = d.BuiltInDocumentProperties(wdPropertyPages)
    linecnt = d.BuiltInDocumentProperties(wdPropertyLines)
    tablecnt = d.Tables.Count

    Debug.Print d.Tables(1).Rows(3).Cells(2).Range.Text & " " & pagecnt & " " & linecnt & " " & tablecnt

End Sub

Private Sub testsub(s As String)
    MsgBox s
End Sub

Private Function opendoc(filename As String)
    On Error Resume Next
    Set opendoc = Nothing

    Dim d As Document
    Set d = Documents.Open(filename:=filename, ConfirmConversions:=False, ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
    ''''''''''''''''''''''''''''''' do not use Visible:=False. it cause open doc menually but show nothing
    If d Is Nothing Then
        Debug.Print "error open " & filename
        Exit Function
    End If

    'Call showTable(d)

    Set opendoc = d

End Function

Private Sub closedoc(d As Document)
    d.Close (wdDoNotSaveChanges)
End Sub

Private Function trimCRLF(ByVal s As String)
    Dim l As Long
                                    'Debug.Print "trimCRLF in: len=" & Len(s) & " s=" & s
    If s = "" Then
        trimCRLF = ""
    End If

    l = Len(s)
    Do While l > 0
        If Mid(s, l, 1) = Chr(10) Or Mid(s, l, 1) = Chr(13) Or Mid(s, l, 1) = Chr(7) Then
            s = Left(s, l - 1)
            l = l - 1
        Else
            Exit Do
        End If
    Loop
    trimCRLF = s
                                    'Debug.Print "trimCRLF out: len=" & Len(s) & " s=" & s
End Function

Private Sub test_trimCRLF()
    trimCRLF ("")
    trimCRLF ("1")
    trimCRLF ("2 two spaces follow ")
    trimCRLF ("3 0D follow" & Chr(13))
    trimCRLF ("4 0A follow" & Chr(10))
    trimCRLF ("5 0D0A follow" & Chr(13) & Chr(10))
End Sub

Private Function checkTableFormat(t As Table)
    On Error Resume Next

    Dim msgStr As String
    Dim rowcnt As Integer
    Dim colcnt As Integer
    Dim celltext As String
    Dim chkTableOK As Boolean

    rowcnt = t.Rows.Count
    colcnt = t.columns.Count

    ' cell(1,1)
    celltext = t.Rows(1).Cells(1).Range.Text
    celltext = trimCRLF(celltext)

    ' check table format
    ' 表名    xxx     编码    yyy
    ' 描述    编码    类型    主键    必填    备注
    chkTableOK = True
    ' check. 6 columns
    If colcnt <> 6 Then
        If celltext = "项目" Or celltext = "名称" Or UCase(Left(celltext, 2)) = "NO" Then
            ' skip page description
        Else
            Debug.Print "[error] table format incorrect. column count is " & colcnt
        End If
        chkTableOK = False
    End If

    If chkTableOK = True Then
        ' check. row1 col1 is 表名/表名描述
        celltext = t.Rows(1).Cells(1).Range.Text
        celltext = trimCRLF(celltext)
        If celltext <> "表名" And celltext <> "表名描述" Then
            Debug.Print "[error] table format incorrect. cell(1,1) is " & celltext
            chkTableOK = False
        End If
    End If

    If chkTableOK = True Then
        ' check. row1 col3 is 编码/表名
        celltext = t.Rows(1).Cells(3).Range.Text
        celltext = trimCRLF(celltext)
        If celltext <> "编码" And celltext <> "表名" Then
            Debug.Print "[error] table format incorrect. cell(1,3) is " & celltext
            chkTableOK = False
        End If
    End If

    If chkTableOK = True Then
        ' check. row2 col1 is 描述
        celltext = t.Rows(2).Cells(1).Range.Text
        celltext = trimCRLF(celltext)
        If celltext <> "描述" Then
            Debug.Print "[error] table format incorrect. cell(2,1) is " & celltext
            chkTableOK = False
        End If
    End If

    If chkTableOK = True Then
        ' check. row2 col2 is 编码
        celltext = t.Rows(2).Cells(2).Range.Text
        celltext = trimCRLF(celltext)
        If celltext <> "编码" Then
            Debug.Print "[error] table format incorrect. cell(2,2) is " & celltext
            chkTableOK = False
        End If
    End If

    If chkTableOK = True Then
        ' check. row2 col3 is 类型 or 数据类型
        celltext = t.Rows(2).Cells(3).Range.Text
        celltext = trimCRLF(celltext)
        If celltext <> "类型" And celltext <> "数据类型" Then
            Debug.Print "[error] table format incorrect. cell(2,3) is " & celltext
            chkTableOK = False
        End If
    End If

    If chkTableOK = True Then
        ' check. row2 col4 is 主键/是否主键
        celltext = t.Rows(2).Cells(4).Range.Text
        celltext = trimCRLF(celltext)
        If celltext <> "主键" And celltext <> "是否主键" Then
            Debug.Print "[error] table format incorrect. cell(2,4) is " & celltext
            chkTableOK = False
        End If
    End If

    If chkTableOK = True Then
        ' check. row2 col5 is 必填/是否必填
        celltext = t.Rows(2).Cells(5).Range.Text
        celltext = trimCRLF(celltext)
        If celltext <> "必填" And celltext <> "是否必填" Then
            Debug.Print "[error] table format incorrect. cell(2,5) is " & celltext
            chkTableOK = False
        End If
    End If

    If chkTableOK = True Then
        ' check. row2 col6 is 备注/必备
        celltext = t.Rows(2).Cells(6).Range.Text
        celltext = trimCRLF(celltext)
        If celltext <> "备注" And celltext <> "必备" Then
            Debug.Print "[error] table format incorrect. cell(2,6) is " & celltext
            chkTableOK = False
        End If
    End If

    checkTableFormat = chkTableOK

End Function

Private Sub getTableInfo(t As Table, tableInfo As t_tableInfo)
    On Error Resume Next

    Dim msgStr As String
    Dim rowcnt As Integer
    Dim colcnt As Integer
    Dim celltext As String
    Dim chkTableOK As Boolean
    Dim i As Integer
    Dim indexColumn As Integer

    rowcnt = t.Rows.Count
    colcnt = t.columns.Count

    chkTableOK = checkTableFormat(t)

    If chkTableOK <> True Then
        Exit Sub
    End If
    ' table name
    celltext = t.Rows(1).Cells(2).Range.Text
    celltext = trimCRLF(celltext)
    tableInfo.tableName = celltext

    ' table id
    celltext = t.Rows(1).Cells(4).Range.Text
    celltext = trimCRLF(celltext)
    tableInfo.tableID = celltext
                                 msgStr = "        tablename:" & tableInfo.tableName
                                msgStr = msgStr & "  tableID:" & tableInfo.tableID
                                msgStr = msgStr & "  table has " & rowcnt & " rows"
                                Debug.Print msgStr
    indexColumn = 0
    ' column defination starts from row 3
    For i = 3 To rowcnt
        ' columnName
        celltext = t.Rows(i).Cells(1).Range.Text
        celltext = trimCRLF(celltext)
        tableInfo.columns(indexColumn).columnName = celltext
        ' columnID
        celltext = t.Rows(i).Cells(2).Range.Text
        celltext = trimCRLF(celltext)
        tableInfo.columns(indexColumn).columnID = celltext
        ' columnType
        celltext = t.Rows(i).Cells(3).Range.Text
        celltext = trimCRLF(celltext)
        tableInfo.columns(indexColumn).columnType = celltext
        ' columnIsPK
        celltext = t.Rows(i).Cells(4).Range.Text
        celltext = trimCRLF(celltext)
        celltext = Trim(celltext)
        'If UCase(celltext) <> "" And UCase(celltext) <> "T" And UCase(celltext) <> "TRUE" Then
        '    Debug.Print "[error] columnIsPK is not in space/T/TRUE/F/FALSE. value is " & celltext
        'End If
        Select Case UCase(celltext)
        Case "T", "TRUE"
            tableInfo.columns(indexColumn).columnIsPK = True
        Case "", "F", "FALSE"
            tableInfo.columns(indexColumn).columnIsPK = False
        Case Else
            Debug.Print "[error] columnIsPK is not in empty/T/TRUE/F/FALSE. value is " & celltext
            tableInfo.columns(indexColumn).columnIsPK = False
        End Select

        ' columnNotNull
        celltext = t.Rows(i).Cells(5).Range.Text
        celltext = trimCRLF(celltext)
        celltext = Trim(celltext)
        Select Case UCase(celltext)
        Case "T", "TRUE"
            tableInfo.columns(indexColumn).columnNotNull = True
        Case "", "F", "FALSE"
            tableInfo.columns(indexColumn).columnNotNull = False
        Case Else
            Debug.Print "[error] columnNotNull is not in space/T/TRUE/F/FALSE. value is " & celltext
            tableInfo.columns(indexColumn).columnNotNull = False
        End Select

        ' columnComment
        celltext = t.Rows(i).Cells(6).Range.Text
        celltext = trimCRLF(celltext)
        tableInfo.columns(indexColumn).columnComment = celltext

        indexColumn = indexColumn + 1
                                'Debug.Print " " & _
                                            tableInfo.columns(i).columnName & Chr(9) & _
                                            tableInfo.columns(i).columnID & Chr(9) & _
                                            tableInfo.columns(i).columnType & Chr(9) & _
                                            tableInfo.columns(i).columnIsPK & Chr(9) & _
                                            tableInfo.columns(i).columnNotNull & Chr(9) & _
                                            tableInfo.columns(i).columnComment

    Next
    tableInfo.columnCount = indexColumn

End Sub

Private Function getTableInfoFromDoc(d As Document, arrTableInfo() As t_tableInfo)
    On Error Resume Next
    Dim tableCount As Integer
    Dim indexTable As Integer
    Dim i As Integer
    Dim j As Integer
    'Dim t As Table

    If d Is Nothing Then
        Debug.Print "[error] getTableInfoFromDoc parameter is null"
        Exit Function
    End If

    tableCount = d.Tables.Count
    Debug.Print "    document " & d.Name & " has " & tableCount & " tables"

    indexTable = 0
    For i = 1 To tableCount
        Dim tmpTableInfo As t_tableInfo
        Call getTableInfo(d.Tables(i), tmpTableInfo)
        If tmpTableInfo.tableName <> "" Then
            ' do not add duplicate table to array
            Dim isDup As Boolean
            isDup = False
            For j = 0 To indexTable
                If tmpTableInfo.tableID = arrTableInfo(j).tableID Then
                    isDup = True
                End If
            Next
            If isDup = False Then
                arrTableInfo(indexTable) = tmpTableInfo
                indexTable = indexTable + 1
            Else
                Debug.Print "    duplicate table found " & tmpTableInfo.tableID
            End If
        End If
    Next
    getTableInfoFromDoc = indexTable
End Function


Private Sub creaSQL(tableInfo As t_tableInfo)
    Dim i As Integer
    Dim j As Integer
    Dim colInf As t_columnInfo
    Dim sqlstm_drop As String
    Dim sqlstm As String
    Dim pkstr As String
    Const PkstrIninStr = "    primary key("
    Const PkstrIninLen = 16

    sqlstm_drop = "drop table if exists " & tableInfo.tableID & ";" & vbCrLf
                            Debug.Print " [" & i & "]" & " " & sqlstm_drop

    pkstr = PkstrIninStr
    sqlstm = "create table " & tableInfo.tableID & "(" & vbCrLf
    For j = 0 To tableInfo.columnCount - 1
        colInf = tableInfo.columns(j)
        sqlstm = sqlstm & " " & colInf.columnID
        sqlstm = sqlstm & " " & colInf.columnType
        If colInf.columnNotNull = True Then
            sqlstm = sqlstm & " not null"
        End If
        sqlstm = sqlstm & "," & vbCrLf

        If colInf.columnIsPK = True Then
            If Len(pkstr) > PkstrIninLen Then
                pkstr = pkstr & ", "
            End If
            pkstr = pkstr & colInf.columnID
        End If
    Next
    pkstr = pkstr & ")" & vbCrLf
    sqlstm = sqlstm & pkstr & ");" & vbCrLf
                            Debug.Print " [" & i & "]" & " " & sqlstm

    outputSQL tableInfo.tableID, sqlstm_drop & sqlstm

End Sub

Sub outputSQLtoFile(filename As String, sqlstm As String)
    Dim fileExist As Boolean

    ' check if file exist
    If Dir(filename) <> "" Then
        fileExist = True
                                    Debug.Print "  file already exist. skip this file " & filename
    Else
        fileExist = False
                                    Debug.Print "  outputSQLtoFile file " & filename
        Open filename For Output As #1
        Print #1, sqlstm
        Close #1

    End If
End Sub

Sub outputSQL(sqlname As String, sqlstm As String)
    Dim tmpFilename As String
    tmpFilename = DEFAULT_SQL_OUTPUT_PATH & "\" & sqlname & ".sql"
    outputSQLtoFile tmpFilename, sqlstm
End Sub

Sub mainprocess()
    On Error Resume Next
    Dim d As Document
    Dim arrTableInfo(MAX_TABLES_IN_DOC) As t_tableInfo
    Dim arrayDocFile(MAX_FILE_COUNT) As String
    Dim filePath As String
    Dim filename As String
    Dim i As Integer
    Dim j As Integer
    Dim tablecnt As Integer

    Debug.Print "mainprocess start"
    'Application.ScreenUpdating = False

    ' get filenames
    filePath = DEFAULT_FILEPATH
    filename = Dir(filePath & "*.doc?")
    i = 0
    Do While filename <> "" And i < MAX_FILE_COUNT
        filename = Dir
                                            Debug.Print filePath & filename
        If filename = "" Then
            Exit Do
        End If
        arrayDocFile(i) = filePath & filename
        i = i + 1
    Loop

    i = 0
    Do While arrayDocFile(i) <> ""
        Set d = opendoc(arrayDocFile(i))
        ' clear array per doc
        Erase arrTableInfo
        tablecnt = 0
        tablecnt = getTableInfoFromDoc(d, arrTableInfo)
                                        'MsgBox "hello"
                                        'getTableInfo ActiveDocument.Tables(1), tableInfo
        closedoc d
        Set d = Nothing
        'Debug.Print "Documents.Count=" & Documents.Count

        For j = 0 To tablecnt - 1
            creaSQL arrTableInfo(j)
        Next
        i = i + 1
    Loop
    'Application.ScreenUpdating = True

    Debug.Print "mainprocess end