根据EXCEL文件各数据表结构定义中创建ER图实体对象

原创： 牛超

2008-06-17

OSAKA

 

又要整理EXCEL文档了。。。

如题，遍历EXCEL各SHEET（表定义），创建实体对象（框图），设置字体与间距。

脚本如下：

 

Option Explicit

Private Sub CommandButton1_Click()
    createRects
End Sub

Private Sub createRects()
Dim stitle As String
Dim slayout As String
Dim scontent As String
Dim scur As String
Dim sdesc As String
Dim slabel As String
Dim myshape As Shape
Dim ws As Worksheet
Dim irow As Integer

Dim trgws As Excel.Worksheet
Dim cx, cy, rwh, rht, wthlmt, maxht As Single

cx = 10
cy = 50
rwh = 200
rht = 200
wthlmt = 1500
maxht = 0

Set trgws = ThisWorkbook.Worksheets(1)

For Each myshape In trgws.Shapes
    If myshape.AutoShapeType = msoShapeRectangle Then
        myshape.Delete
    End If
Next
       
    For Each ws In ThisWorkbook.Worksheets
        If ws.Index > 1 Then
            scontent = ""
            slabel = ""
           
            slayout = ws.Name
            stitle = ws.Cells(1, 1)
           
            For irow = 3 To 200
                scur = ws.Cells(irow, 1)
               
                If Len(Trim(scur)) = 0 Then
                    Exit For
                End If
               
                sdesc = ws.Cells(irow, 6)
                If InStr(LCase(sdesc), LCase("index:idx01")) Then
                    scontent = scontent & "・" & scur & Chr(10)
                End If
            Next
           
            slabel = "【" & stitle & "】" & slayout & Chr(10) & scontent
            Set myshape = trgws.Shapes.AddShape(msoShapeRectangle, cx, cy, rwh, rht)
            myshape.Select
           
            'With myshape.TextFrame
            '    .Characters.Text = slabel
            '    .HorizontalAlignment = xlHAlignLeft
            '    .VerticalAlignment = xlVAlignCenter
            'End With
           
            Selection.Characters.Text = slabel
            Selection.Characters.Font.Name = "ＭＳ 明朝"
            Selection.Characters.Font.Size = 9
           
            Selection.AutoSize = True
            If Selection.Height > maxht Then
                maxht = Selection.Height
            End If

            cx = cx + Selection.Width + 20
            If cx > wthlmt Then
                cx = 10
                cy = cy + maxht + 20
            End If
        End If
    Next
   
End Sub