PowerPoint ShapeにAccessデータ
スライドの作成
Shape 名前の編集
スライドにタブ「挿入」の中にあるメニュー「図形」から「正方形／長方形」を選択します。
例では、A1～A9 B1～B7 C1～C7 D1～D9を挿入しています。
次に、Shape の名前を変更します。変更は、タブ「ホーム」の中にあるメニュー「配置」から行います。
「配置」をクリックします。するとメニューが開きますので一番下の「オブジェクトの選択と表示」をクリックします。
「選択」ウィンドウが右端に開きます。スライドにあるオブジェクトの一覧が表示されます。
「選択」ウィンドウの中を選択クリックしてすると編集状態になります。
例では、Text が 「A1」の Shape を選択しています。この名前は「正方形／長方形 3」でこれを「A1」に変更します。
全部の編集が終わるとこのような状態になります。
コードの追加・修正
buダイヤログ_Click
MsgBox を削除して、Call ShapeDraw を追加してShapeたちの文字列を編集します。
'-----------------------------------------
'ボタン「ダイヤログ」のクリック
Private Sub buダイヤログ_Click()
Dim FilePath As String
FilePath = getFileName("Accessを選択")
If FilePath = "" Then
Exit Sub
End If
Call ConnectDB(FilePath)
Call ShapeDraw
End Sub
ConnectDB
SQL文（mySQL）を変更しています。
「区画ID」をすべて表示して、判定日において有効期間であるもののみをサブSQLとして「LEFT JOIN」結合して結果を求めます。
こうすることによって「区画ID」をキー、契約者情報を値とするハッシュテーブルにおいて重複が把握しやすくなります。
'-----------------------------------------
'Access に接続してデータを配列に取得します。
Private Sub ConnectDB(ByVal strFileName As String)
Dim ADOCn As Object
Dim ADORs As Object
Dim Data() As Variant
Dim mySQL As String
Dim myDate As String
Dim I As Long
Dim J As Long
'ADODBコネクションオブジェクトを作成します。
Set ADOCn = CreateObject("ADODB.Connection")
'Access ファイルに接続します。
ADOCn.Open "Provider = Microsoft.ACE.OLEDB.12.0;" & _
"Data Source = " & strFileName & ";"
'今日の日を判定日とします。
myDate = Format(Date, "yyyy-mm-dd")
'SQL文の作成
'条件は、判定日が開始日以降で、終了日以前もしくは終了日が空の場合とします。
'A.終了日を SWITCH 関数で場合分けします。
mySQL = "SELECT A.区画ID"
mySQL = mySQL & ", X.登録番号"
mySQL = mySQL & ", X.氏名"
mySQL = mySQL & " FROM MT_区画 AS A"
mySQL = mySQL & " LEFT JOIN "
mySQL = mySQL & "(SELECT B.区画ID"
mySQL = mySQL & ", B.登録番号"
mySQL = mySQL & ", C.氏名"
mySQL = mySQL & " FROM MT_契約 AS B"
mySQL = mySQL & " LEFT JOIN"
mySQL = mySQL & " MT_契約者 AS C"
mySQL = mySQL & " ON B.契約者ID = C.契約者ID"
mySQL = mySQL & " WHERE B.開始日 <= '" & myDate & "'"
mySQL = mySQL & " AND SWITCH(B.終了日 IS NULL , '9999-12-31'"
mySQL = mySQL & ", B.終了日 = '', '9999-12-31'"
mySQL = mySQL & ", TRUE, B.終了日) >= '" & myDate & "') AS X"
mySQL = mySQL & " ON A.区画ID = X.区画ID"
mySQL = mySQL & ";"
'レコードセットを作成します。
Set ADORs = CreateObject("ADODB.Recordset")
ADORs.Open mySQL, ADOCn, adOpenStatic, adLockReadOnly
'フィールド名とインデックスを対応させたハッシュテーブルを作成します。
Set FieldsDict = New Dictionary
With FieldsDict
For I = 0 To ADORs.Fields.Count - 1
.Add ADORs.Fields(I).Name, I
Next I
End With
'データを書き出す配列を作成します。
ReDim Data(ADORs.Fields.Count - 1, ADORs.RecordCount - 1)
'レコードセットのデータを配列に書き出します。
Data = ADORs.GetRows
'データを取得したので切断します。
ADORs.Close
Set ADORs = Nothing
ReDim myData(UBound(Data, 2), UBound(Data, 1))
For I = 0 To UBound(Data, 2)
For J = 0 To UBound(Data, 1)
myData(I, J) = Data(J, I)
Next J
Next I
End Sub
ShapeDraw
指定範囲の「スライド」を対象にして、Shapeたちの文字列を編集します。
'-----------------------------------------
'AccessのデータをShapeに書き込みます。
Private Sub ShapeDraw()
Dim SlideNum As Long
Dim KeiyakuDict As Dictionary
Dim Shp As Shape
Dim BUF As String
Dim V As String
Dim I As Long
'後の処理を考え、区画IDをキーとするハッシュテーブルを作成します。
Set KeiyakuDict = New Dictionary
With KeiyakuDict
For I = 0 To UBound(myData, 1)
'配列 mtData の要素は Variant 型なので Null ということもあります。
'Null の場合 BUF には空 "" が入ります。
BUF = NZ(myData(I, FieldsDict("登録番号")))
If BUF = "" Then
BUF = NZ(myData(I, FieldsDict("氏名")))
If BUF <> "" Then
V = BUF
Else
V = ""
End If
Else
V = BUF
BUF = NZ(myData(I, FieldsDict("氏名")))
If BUF <> "" Then
V = V & vbLf & BUF
End If
End If
'重複した時の処理
If .Exists(myData(I, FieldsDict("区画ID"))) Then
If KeiyakuDict(myData(I, FieldsDict("区画ID"))) <> "重複" Then
KeiyakuDict(myData(I, FieldsDict("区画ID"))) = "重複"
End If
Else
.Add myData(I, FieldsDict("区画ID")), V
End If
Next I
End With
'スライド2に作ったから2です。状況に応じて決めます。
For SlideNum = 2 To 2
For Each Shp In ActivePresentation.Slides(SlideNum).Shapes
'ハッシュテーブルと照合します。
If KeiyakuDict.Exists(Shp.Name) Then
If KeiyakuDict(Shp.Name) <> "" Then
With Shp.TextFrame
'テキストのベースオブジェクトを中央に配置します。
.HorizontalAnchor = msoAnchorCenter
.MarginLeft = 1
.MarginRight = 1
With .TextRange
.Text = KeiyakuDict(Shp.Name)
.Font.Size = 10
'テキストを中央に配置します。
.ParagraphFormat.Alignment = msoAlignCenter
End With
End With
Else
With Shp.TextFrame
'テキストのベースオブジェクトを中央に配置します。
.HorizontalAnchor = msoAnchorCenter
.MarginLeft = 1
.MarginRight = 1
With .TextRange
.Text = Shp.Name
.Font.Size = 16
'テキストを中央に配置します。
.ParagraphFormat.Alignment = msoAlignCenter
End With
End With
End If
End If
Next Shp
Next SlideNum
Set KeiyakuDict = Nothing
End Sub
NZ()関数
PowerPoint には Access に備わっている Nz() 関数がありませんので必要に応じて自作します。
'-----------------------------------------
'AccessにあるNz関数がないので状況に応じて自作します。
Private Function NZ(ByVal Val As Variant, _
Optional def As Variant) As Variant
Dim Res As Variant
If IsMissing(def) Then
Res = ""
Else
Res = def
End If
If IsNull(Val) Then
'何もしません
ElseIf IsEmpty(Val) Then
'何もしません
Else
Res = Val
End If
NZ = Res
End Function
実行結果
目的の表現ができています。
「図形」の「正方形／長方形」を使っていますので編集の範囲は必要に応じて編集します。
