Sibainu Relax Room

愛犬の柴犬とともに過ごす部屋

PowerPointとAccessの連携まとめ

4つに分かれたコードを1つにまとめただけのものです。

UserForm のコード

UserForm1 の全コードです。

copy

Option Explicit

'// 64bit版
#If VBA7 And Win64 Then
    Private Declare PtrSafe Function SetForegroundWindow Lib "user32" _
        (ByVal hwnd As LongPtr) As Long
'// 32bit版
#Else
    Private Declare Function SetForegroundWindow Lib "user32" _
        (ByVal hwnd As Long) As Long
#End If

Private xlApp               As Object

Private FieldsDict          As Dictionary
Private myData()            As Variant
'-----------------------------------------
'
Private Sub UserForm_Initialize()

    'エクセルを開きます。
    Set xlApp = CreateObject("Excel.Application")

End Sub
'-----------------------------------------
'ボタン「閉じる」のクリック
Private Sub bu閉じる_Click()

    Unload Me

End Sub
'-----------------------------------------
'フォームが閉じるときに実行されるコード
Private Sub UserForm_Terminate()

    Set xlApp = Nothing
 
End Sub
'-----------------------------------------
'ボタン「ダイヤログ」のクリック
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
'-----------------------------------------
'エクセルのダイヤログを開き選択したファイルのパスを返します。
Private Function getFileName(ByVal myTitle As String) As String
    Const msoFileDialogFilePicker = 3
    Dim ThisPath            As String
    Dim BUF                 As String

    '開いている PowerPoint のパス
    ThisPath = ActivePresentation.Path

    BUF = ""

    'エクセルのダイヤログを開きます。
    With xlApp

        'これをしないとExcelはPowerPointに隠れたままです。
        Call SetForegroundWindow(.hwnd)

        With .FileDialog(msoFileDialogFilePicker)

            .InitialFileName = ThisPath & "\"
            .AllowMultiSelect = False
            .Title = myTitle
            .Filters.Add "ACCESS", "*.accdb"
            .Filters.Add "すべてのファイル", "*.*"
            .FilterIndex = 1
            .ButtonName = "開く"

            If .Show = True Then
                BUF = .SelectedItems(1)
            End If

        End With

        'エクセルを閉じる
        .Quit

    End With

    getFileName = BUF
    
End Function
'-----------------------------------------
'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
'-----------------------------------------
'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
'-----------------------------------------
'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

UserForm

デフォルトで挿入されたフォーム「UseForm1」にボタン「bu閉じる」「buダイヤログ」を配置しただけのフォームです。