【ExcelVBA】ER図のパーツを作る

自分用。作成は、Office2010。

コピーするシート上にある元のシェイプグループはこんなん↓
テーブル名と、フィールド名と、それを括るものの3つで構成。


ターゲットシート（Worksheets("TgtDB")）には、ER図を作りたいテーブルの俗称とフルパスが複数入っていて、そのデータベースの中に、DBのテーブル情報をまとめたテーブル（"C1"）が個々に入っている、という設計です。

複製したシートの、2行目から、10個ずつ折り返しつつ、ずらずらとテーブルごとにシェイプグループを作ります。雛形が一行目に残りっぱなしですけど、それは後で手で削除します。

グループはなんか、オブジェクトじゃなくて状態？なのかなんなのか知らないんですけども（の、割にはObjectに入ったけど…）グループを入れたObjectと、グルーピングしたいシェイプのObjectをつかんでるだけでは、両方を選択することができないらしく…。

結局、個別にユニーク名を付けて、名前で選択→グルーピング、しか、今回手段が見つけられなかった感じです。
'--------------------------------------------------------------------------
' 　　　Write by m_o_co
'--------------------------------------------------------------------------
Option Explicit

Private Const GRP_NM As String = "Gr_TBL"
Private Const TBL_TTL As String = "R_TBL_Title"
Private Const TBL_FLM As String = "R_TBL_FRAM"
Private Const FLD_NM As String = "R_FLD_NM"

Private DB As DAO.database
Private RS As DAO.Recordset

Private WB As Workbook
Private tmpShp As Object
Private wkSht As Worksheet

Private wkTblNm As String

Private cRow As Long
Private cClm As Integer

'--------------------------------------------------------------------------
Public Sub crtErPeace()

　　Dim tgtLst As Worksheet
　　Dim tmpSht As Worksheet
　　Dim rngTgt As Range
　　
　　Dim wkRng As Range
　　
　　Const strRow As Long = 2
　　Const strClm As Long = 1
　　
　　Dim wkShps As Object
　　Dim wkShp As Object
　　Dim wkFlm As Object
　　
　　Set WB = ThisWorkbook
　　
　　With WB
　　　　
　　　　Set tgtLst = .Worksheets("TgtDB")
　　　　Set tmpSht = .Worksheets("ER図")
　　　　Set tmpShp = tmpSht.Shapes(GRP_NM)
　　　　
　　End With
　　
　　Set rngTgt = tgtLst.Range("A1:A5") ' 雑設定。対象が変わったら修正
　　
　　For Each wkRng In rngTgt
　　
　　　　' 雛形シートをコピー
　　　　tmpSht.Copy after:=tmpSht
　　　　Set wkSht = ActiveSheet
　　　　
　　　　wkSht.Name = tmpSht.Name & "_" & wkRng.Value
　　　　
　　　　Set DB = OpenDatabase(wkRng.Offset(0, 1).Value, False, False, ";PWD=XXXXXXX") ' 雑指定
　　　　Set RS = DB.OpenRecordset(tgtLst.Range("C1").Value, dbOpenSnapshot)
　　
　　　　cRow = strRow
　　　　cClm = strClm
　　
　　　　' 一件目
　　　　If Not RS.EOF Then
　　　　　　wkTblNm = RS!テーブル名
　　　　　　Set wkShps = crtErPeace0010(RS)
　　　　　　Set wkFlm = crtErPeace0025(wkShps)
　　　　End If
　　　　
　　　　Set wkShp = Nothing
　　　　
　　　　Do Until RS.EOF
　　　　
　　　　　　'--------------------------------------
　　　　　　' シェイプ編集
　　　　　　'--------------------------------------
　　　　　　If wkShp Is Nothing Then
　　　　　　　　Set wkShp = crtErPeace0020(wkShps, RS)
　　　　　　Else
　　　　　　　　Set wkShp = crtErPeace0030(wkShps, wkFlm, wkShp, RS)
　　　　　　End If
　　　　
　　　　　　RS.MoveNext
　　　　　　
　　　　　　'--------------------------------------
　　　　　　' テーブル名変更
　　　　　　'--------------------------------------
　　　　　　If Not RS.EOF Then
　　　　　　　　If wkTblNm <> RS!テーブル名 Then
　　　　　　
　　　　　　　　　　cClm = cClm + 1
　　　　
　　　　　　　　　　If cClm > 10 Then
　　　　　　　　　　　　cClm = strClm
　　　　　　　　　　　　cRow = cRow + 1
　　　　　　　　　　End If
　　　　　　　　
　　　　　　　　　　wkTblNm = RS!テーブル名
　　　　　　　　　　Set wkShps = crtErPeace0010(RS)
　　　　　　　　　　Set wkFlm = crtErPeace0025(wkShps)
　　　　　　　　　　Set wkShp = Nothing
　　　　　　　　
　　　　　　　　End If
　　　　　　End If
　　　　　　　　
　　　　Loop
　　　　
　　　　RS.Close: Set RS = Nothing
　　
　　Next
　　
　　DB.Close: Set DB = Nothing
　　
　　
　　Set WB = Nothing
　　Set tmpShp = Nothing
　　Set wkSht = Nothing
　　


End Sub

'--------------------------------------------------------------------------
Private Function crtErPeace0010(RS As DAO.Recordset) As Object
'--------------------------------------
' 枠複製
'--------------------------------------

　　Dim wkGrp As Object

　　With wkSht
　　　　
　　　　tmpShp.Copy
　　　　.Cells(cRow, cClm).Select
　　　　ActiveSheet.Paste
　　　　
　　　　Selection.Name = GRP_NM & wkTblNm
　　　　Set wkGrp = Selection.ShapeRange.GroupItems
　　　　Set crtErPeace0010 = wkGrp
　　　　
　　　　Call crtErPeace0015(wkGrp, RS)
　　　　
　　End With

End Function

'--------------------------------------------------------------------------
Private Sub crtErPeace0015(wkShps As Object, RS As DAO.Recordset)
'--------------------------------------
' フィールド名増殖
'　　 ・グループ内で、左上が一番上のシェイプを探し、タイトルを入れる
'--------------------------------------

　　Dim wkObj As Object
　　Dim wkLft As Double
　　Dim wkTop As Double
　　Dim kepShp As Object

　　wkLft = 1000000
　　wkTop = 1000000

　　Set kepShp = wkShps(1)

　　For Each wkObj In wkShps
　　
　　　　If wkObj.Top < kepShp.Top Or wkObj.Left < kepShp.Left Then Set kepShp = wkObj
　　
　　Next
　　
　　kepShp.TextFrame.Characters.Text = RS!テーブル名

End Sub

'--------------------------------------------------------------------------
Private Function crtErPeace0020(wkShps As Object, RS As DAO.Recordset) As Object
'--------------------------------------
' フィールド名増殖
'　　 ・グループ内で、左上が一番下のシェイプを探す
'--------------------------------------

　　Dim wkObj As Object
　　Dim wkLft As Double
　　Dim wkTop As Double
　　Dim kepShp As Object

　　wkLft = 0
　　wkTop = 0

　　Set kepShp = wkShps(1)

　　For Each wkObj In wkShps
　　
　　　　If wkObj.Top > kepShp.Top Or wkObj.Left > kepShp.Left Then Set kepShp = wkObj
　　
　　Next
　　
　　kepShp.TextFrame.Characters.Text = RS!項目名
　　kepShp.Name = FLD_NM & RS!項目名 & cRow & "_" & cClm
　　Set crtErPeace0020 = kepShp

End Function

'--------------------------------------------------------------------------
Private Function crtErPeace0025(wkShps As Object) As Object
'--------------------------------------
'　　 ・グループ内で、一番高いシェイプを返す
'--------------------------------------

　　Dim wkObj As Object
　　Dim wkHight As Double
　　Dim kepShp As Object

　　wkHight = 0

　　Set kepShp = wkShps(1)

　　For Each wkObj In wkShps
　　
　　　　If wkObj.Height > kepShp.Height Then Set kepShp = wkObj
　　
　　Next
　　
　　Set crtErPeace0025 = kepShp

End Function

'--------------------------------------------------------------------------
Private Function crtErPeace0030(wkShps As Object, wkFlm As Object, wkShp As Object, RS As DAO.Recordset) As Object
'--------------------------------------
' フィールド名増殖
'　　 ・wkShpを、wkShpの下へ複製貼り付け
'　　 ・グループ化
'--------------------------------------

　　Dim wkTop As Double
　　Dim wkLeft As Double
　　Dim wkHight As Double
　　Dim wkObj As Object
　　
　　　　wkTop = wkShp.Top
　　　　wkLeft = wkShp.Left
　　　　wkHight = wkShp.Height
　　
　　　　wkShp.Copy
　　　　wkSht.Paste
　　　　
　　　　Set wkShp = Selection
　　　　
'　　　　wkShp.TextFrame.Characters.Text = RS!項目名
　　　　Selection.Characters.Text = RS!項目名
　　　　wkShp.Left = wkLeft
　　　　wkShp.Top = wkTop + wkHight
　　　　wkFlm.Height = wkFlm.Height + wkHight
　　　　
　　　　Set crtErPeace0030 = wkShp
　　　　
　　　　wkShp.Name = FLD_NM & RS!項目名 & cRow & "_" & cClm
　　　　
　　　　wkSht.Shapes.Range(Array(GRP_NM & wkTblNm, wkShp.Name)).Select
　　　　Selection.ShapeRange.Group.Select
　　　　Selection.Name = GRP_NM & wkTblNm

End Function
'--------------------------------------------------------------------------