PowerPoint Accessと接続

copy

'-----------------------------------------
'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 & ", B.登録番号"
    mySQL = mySQL & ", C.氏名"
    mySQL = mySQL & " FROM (MT_区画 AS A"
    mySQL = mySQL & " LEFT JOIN MT_契約 AS B"
    mySQL = mySQL & " ON A.区画ID = B.区画ID)"
    mySQL = mySQL & " LEFT JOIN 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 & "'"
    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

copy

'-----------------------------------------
'ボタン「ダイヤログ」のクリック
Private Sub buダイヤログ_Click()
    Dim FilePath            As String

    FilePath = getFileName("Accessを選択")

    If FilePath = "" Then
        Exit Sub
    End If

    Call ConnectDB(FilePath)

    'FieldsDict を作成したのは配列の Column 値を名称で扱うためです。
    MsgBox myData(0, FieldsDict("氏名")) & " : " & myData(0, FieldsDict("登録番号"))

End Sub