SELECT
object_name(sys.columns.object_id),
sys.columns.column_id,
sys.columns.name,
sys.indexes.name AS INDEX_NAME,
sys.indexes.is_primary_key AS TEST
FROM
sys.columns inner join sys.objects on
sys.columns.object_id = sys.objects.object_id
LEFT JOIN
sys.index_columns
on sys.columns.column_id = sys.index_columns.column_id
and sys.columns.object_id = sys.index_columns.object_id
LEFT JOIN sys.indexes
on sys.indexes.object_id = sys.index_columns.object_id
where
ISNULL(sys.indexes.is_primary_key ,-1) IN (-1,1)
and
sys.objects.type = 'U'
--もしER図に出したくないカラムがある場合はここで指定
--and--sys.columns.name NOT IN ( --'created',
--'テスト項目',
--'削除フラグ'
--)
--テーブルしぼるならここで！
--and--LEFT(object_name(sys.columns.object_id),8) IN (
--'T_氏名'
--'T_給与'
--)
order by
object_name(sys.columns.object_id),
column_id
②出力された結果をエクセルに貼り付けて以下の様にします
（必ずＡ１セルから貼り付けてください）
③貼り付けたシート上で以下のＶＢＡマクロを実行します。
Dim WB As Workbook
Set WB = ActiveWorkbook
Dim WS1 As Worksheet
Set WS1 = WB.ActiveSheet
WS1.Select
Range("A1:E1").Select
Range(Selection, Selection.End(xlDown)).Select
'--------------------------------------------------------
'実行速度向上のため画面更新と自動計算を停止
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'-----------------------------------------------------------
'現在選択しているセルの取得
Dim intStartGyo As Integer: intStartGyo = Selection.Row
Dim intLastGyo As Integer: intLastGyo = Selection.Row + Selection.Rows.Count - 1
Dim intStartClm As Integer: intStartClm = Selection.Column
Dim intLastClm As Integer: intLastClm = Selection.Column + Selection.Columns.Count - 1
'※初期置
Dim Rng As Range
Set Rng = WS1.Cells(intStartGyo, intStartClm)
Dim lWidth As Long: lWidth = 150 'エンティティオブジェクトのサイズ
Dim lHeight As Long: lHeight = 14 'エンティティオブジェクトのサイズ
lLeft = Rng.Left + 350 '初期位置
Ltop = Rng.Top + 10 '初期位置
Dim TblCnt As Integer: TblCnt = 0
Dim TblTitle As String
Dim TblStartTop As Integer
Dim ECnt As Integer
Dim strShapes As String
Dim FlgKey As Boolean
For j = intStartGyo To intLastGyo
'テーブルカウント
If TblTitle <> WS1.Cells(j, intStartClm).Text Then
TblCnt = TblCnt + 1
TblTitle = WS1.Cells(j, intStartClm).Text
ECnt = 0
strShapes = ""
Ltop = WS1.Cells(j + 1, intStartClm).Top + 10
TblStartTop = Ltop
FlgKey = True
End If
'エンティティの作成---------------------------------------
Dim myShape1 As Shape
'主キーからそうでなくなった場合、線を足す
If WS1.Cells(j, intStartClm + 4).Text <> "1" Then
If FlgKey = True Then
Dim SShape As Shape
Set SShape = WS1.Shapes.AddConnector(msoConnectorStraight, lLeft, Ltop, lLeft + lWidth, Ltop)
strShapes = strShapes & "," & SShape.Name
FlgKey = False
End If
End If
Dim oShape As Shape
Set oShape = WS1.Shapes.AddShape(msoShapeRectangle, lLeft, Ltop, lWidth, lHeight)
With oShape
.Fill.Visible = msoFalse
.Fill.Solid 'グラデーション等無し
.Line.Visible = msoFalse
.TextFrame.Characters.Font.Color = vbBlack
If WS1.Cells(j, intStartClm + 4).Text <> "1" Then
.TextFrame.Characters.Text = WS1.Cells(j, intStartClm + 2).Text
Else
.TextFrame.Characters.Text = "■" & WS1.Cells(j, intStartClm + 2).Text
End If
.TextFrame.Characters.Font.Size = 8
.TextFrame.HorizontalAlignment = xlHAlignLeft
End With
strShapes = strShapes & "," & oShape.Name
'追加位置を下へずらす
Ltop = Ltop + lHeight
ECnt = ECnt + 1
'-------------------------------------------------------
'次が異なるテーブルor終了行---------------------------------
If Len(strShapes) > 0 Then
If WS1.Cells(j + 1, intStartClm).Text <> TblTitle Or j + 1 > intLastGyo Then
Set oShape = WS1.Shapes.AddShape(msoShapeRectangle, lLeft, TblStartTop - 20, lWidth, 30 + ECnt * (lHeight + 1))
With oShape
.Fill.Visible = msoFalse
.Fill.Solid 'グラデーション等無し
.Line.Visible = msoTrue
.TextFrame.Characters.Font.Color = vbBlue
.TextFrame.Characters.Text = TblTitle
.TextFrame.Characters.Font.Size = 8
.TextFrame.HorizontalAlignment = xlHAlignLeft
End With
'strShapes(ECnt) = oShape.Name
'ActiveSheet.Shapes.Range(Array("""" & oShape.Name & """" & strShapes)).Select
strShapes = strShapes & "," & oShape.Name
Dim valShapes() As String
valShapes = Split(strShapes, ",")
'oShape.Select
'Selection.ShapeRange.Group.Select
WS1.Shapes.Range(valShapes).Group
'追加位置を右へずらす
'lLeft = lLeft + lWidth + 5
'追加位置を下へずらす
Ltop = Ltop + 30 + ECnt * (lHeight + 1) + 10
End If
End If
'------------------------------------------------------------
Next
'実行速度向上のため画面更新と自動計算を再開---------------
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
'-----------------------------------------------------------
MsgBox ("作成成功")
End Sub
④以下の様にER図用のエンティティ図形が出来ます。
