【Access VBA】PostgreSQLのテーブルを編集する

Access VBA

SQL 第2版: ゼロからはじめるデータベース操作

SQL 第2版: ゼロからはじめるデータベース操作

Amazon

AccessからPostgreSQLのテーブルを編集する

PostgreSQLの「売上伝票」テーブルおよび「売上明細」テーブルのデータをAccessで取得し、修正を加えたのち、PostgreSQLに保存します。


テーブルを準備する

PostgreSQLで「sample」という名前のデータベースの中に「T売上伝票」、「T売上明細」の2つのテーブルを用意しました。「T売上伝票」、「T売上明細」は生データを保存するテーブルです。Accessには「WT売上伝票」、「WT売上明細」の2つのテーブルを用意しました。「TEMP売上伝票」、「TEMP売上明細」は一時的にAccessから編集後のデータを受け取るテーブルです。この一時テーブルからストアドプロシージャを使って、生データのテーブルにデータを書き込みます。「TEMP売上伝票」、「TEMP売上明細」はAccessで編集したデータをPostgreSQLに保存するときに生成し、保存後は削除します。
さらに「T売上伝票」の主キー値発番用に「T発番」という名前のテーブルを用意しました。


「T売上伝票」、「T売上明細」の間に連鎖削除を設定しました。

PostgreSQLにストアドプロシージャを準備する

PostgreSQLに「import売上情報」という名前のストアドプロシージャを用意しました。
これにより一時テーブルのデータを生データのテーブルに書き込みます。

CREATE OR REPLACE PROCEDURE public."import売上情報"()
LANGUAGE plpgsql
AS $$
BEGIN
BEGIN
LOCK TABLE "T売上伝票" IN ACCESS EXCLUSIVE MODE;
LOCK TABLE "T売上明細" IN ACCESS EXCLUSIVE MODE;
--T売上伝票更新------------------------------------------------
MERGE INTO "T売上伝票" AS A
USING "TEMP売上伝票" AS B ON A.伝票番号 = B.伝票番号
WHEN MATCHED THEN
  UPDATE SET 日付 = B.日付
WHEN NOT MATCHED THEN
  INSERT (伝票番号, 日付)
  VALUES (B.伝票番号, B.日付);
--------------------------------------------------------------
--T売上明細更新------------------------------------------------
MERGE INTO "T売上明細" AS C
USING "TEMP売上明細" AS D ON C."明細ID" = D."明細ID"
WHEN MATCHED AND D.削除=FALSE THEN
  UPDATE SET 商品コード = D.商品コード,数量 = D.数量
WHEN MATCHED AND D.削除=TRUE THEN
  DELETE
WHEN NOT MATCHED AND D.削除=FALSE THEN
  INSERT (伝票番号, 商品コード,数量)
  VALUES (D.伝票番号, D.商品コード,D.数量);
---------------------------------------------------------------
EXCEPTION
WHEN OTHERS THEN
RAISE WARNING 'エラー';
ROLLBACK;
RETURN;
END;
COMMIT;
END;
$$

PostgreSQLに「SetID」という名前のストアドファンクションを用意しました。これにより「売上伝票」の主キー値を発番します。以下に「SetID」のコードを記載します。

CREATE OR REPLACE FUNCTION public."SetID"()
RETURNS integer
LANGUAGE plpgsql
AS $$
DECLARE id integer;
BEGIN
BEGIN 
LOCK TABLE "T発番" IN ACCESS EXCLUSIVE MODE;
SELECT 連番 INTO id FROM "T発番";    
UPDATE "T発番" SET 連番=id+1;
EXCEPTION
WHEN OTHERS THEN
RETURN -1;
END;
RETURN id;
END;
$$

選択クエリの作成

Accessで「Q売上明細」という名前の選択クエリを作成しました。サブフォームのレコードソースとして使用します。

フォームの準備

下のような「Fサンプル」という名前のフォームを作成しました。「伝票一覧」と「売上明細」はサブフォームです。「売上伝票」の部分には非連結のテキストボックス２つを配置しています。


「売上明細」サブフォームでは「伝票番号」と「削除」フィールドを非表示にして、以下の既定値を設定しました。


PostgreSQLのテーブルから「売上伝票」と「売上明細」を取得するコードの記述

標準モジュールにPostgreSQLのテーブルから売上伝票と売上明細を取得する関数「wtINSERT」を記述しました。

Public Const strCN As String = "Driver={PostgreSQL Unicode};Server=localhost;Port=5432;
DATABASE=sample;Uid=postgres;Pwd=1111"
Public Function wtINSERT(ByVal strWT As String, ByVal strSQL As String) As Boolean
    On Error GoTo Errh
    DoCmd.SetWarnings False
    Dim db As Database
    Set db = CurrentDb
    Dim qdf As QueryDef
    Set qdf = db.CreateQueryDef("Q取込", "INSERT INTO " & strWT & " " & strSQL)
    qdf.ODBCTimeout = 3
    DoCmd.OpenQuery "Q取込"
    DoCmd.SetWarnings True
    db.QueryDefs.Delete "Q取込"
    wtINSERT = True
    Exit Function
Errh:
    DoCmd.SetWarnings True
    db.QueryDefs.Delete "Q取込"
    wtINSERT = False
End Function

PostgreSQLの「T売上伝票」から目的のデータを削除するコードの記述

標準モジュールにPostgreSQLの「T売上伝票」から目的のデータを削除する関数「tDELETE」を作成しました。

Public Function tDELETE(ByVal intSlipNo As Integer) As Boolean
    On Error GoTo Errh
    Dim cn As New ADODB.Connection
    cn.Open strCN
    Dim cmd As New ADODB.Command
    cmd.ActiveConnection = cn
    cmd.CommandTimeout = 3
    cmd.CommandType = adCmdText
    cmd.CommandText = "DELETE FROM ""T売上伝票"" WHERE 伝票番号=" & intSlipNo
    cmd.Execute
    Set cmd = Nothing
    cn.Close: Set cn = Nothing
    tDELETE = True
    Exit Function
Errh:
    Set cmd = Nothing
    cn.Close: Set cn = Nothing
    tDELETE = False
End Function

PostgreSQLのストアドプロシージャを実行するコードの記述

標準モジュールにPostgreSQLのストアドプロシージャを実行する関数「ExecutePostgreSQLStoredProcedure」を作成しました。

Public Function ExecutePostgreSQLStoredProcedure(ByVal strStoredProcedure As String) As Boolean
    On Error GoTo Errh
    Dim cn As New ADODB.Connection
    cn.Open strCN
    Dim cmd As New ADODB.Command
    cmd.ActiveConnection = cn
    cmd.CommandType = adCmdText
    cmd.CommandText = "CALL " & strStoredProcedure
    cmd.CommandTimeout = 3
    cmd.Execute
    If cn.Errors.Count = 0 Then
        ExecutePostgreSQLStoredProcedure = True
    Else
        ExecutePostgreSQLStoredProcedure = False
    End If
    Set cmd = Nothing
    cn.Close: Set cn = Nothing
    Exit Function
Errh:
    Set cmd = Nothing
    cn.Close: Set cn = Nothing
End Function

PostgreSQLから主キー値を取得するコードの記述

標準モジュールにPostgreSQLから主キー値を取得する関数「GetID」を作成しました。

Public Function GetID(ByRef n As Integer) As Boolean
    On Error GoTo Errh
    DoCmd.SetWarnings False
    Dim db As Database
    Set db = CurrentDb
    Dim qdf As QueryDef
    For Each qdf In db.QueryDefs
       If qdf.Name = "Q採番" Then
          db.QueryDefs.Delete qdf.Name
    End If
    Next
    Set qdf = db.CreateQueryDef()
    With qdf
        .Name = "Q採番"
        .SQL = "select ""SetID""()"
        .Connect = "ODBC;" & strCN
        .ODBCTimeout = 3
    End With
    db.QueryDefs.Append qdf
    db.QueryDefs.Refresh
    
    Dim rs As DAO.Recordset
    Set rs = qdf.OpenRecordset()
    
    If rs.Fields(0).Value < 0 Then
        GetID = False
        MsgBox "エラーが発生しました。", vbExclamation, "確認"
    Else
        n = rs.Fields(0).Value
        GetID = True
    End If
    db.QueryDefs.Delete "Q採番"
    Set qdf = Nothing
    rs.Close: Set rs = Nothing
    db.Close: Set db = Nothing
    Exit Function
Errh:
    GetID = False
    MsgBox "エラーが発生しました。", vbExclamation, "確認"
    db.QueryDefs.Delete "Q採番"
    Set qdf = Nothing
    db.Close: Set db = Nothing
End Function

Accessのテーブルをクリアするコードの記述

標準モジュールにAccessのテーブルをクリアする関数「wtDELETE」を作成しました。

Public Function wtDELETE(ByVal strWT As String) As Boolean
    On Error GoTo Errh
    Dim w_cn As New ADODB.Connection
    Set w_cn = CurrentProject.AccessConnection
    Dim w_cmd As New ADODB.Command
    w_cmd.ActiveConnection = w_cn
    w_cmd.CommandType = adCmdText
    w_cmd.CommandText = "DELETE FROM " & strWT
    w_cmd.Execute
    Set w_cmd = Nothing
    w_cn.Close: Set w_cn = Nothing
    wtDELETE = True
    Exit Function
Errh:
    Set w_cmd = Nothing
    w_cn.Close: Set w_cn = Nothing
    wtDELETE = False
End Function

PostgreSQLに一時テーブルを生成するコードの記述

標準モジュールにPostgreSQLに一時テーブルを生成する関数「tempEXPORT」を記述しました。

Public Function tempEXPORT(ByVal strWT As String, ByVal strSQL As String) As Boolean
    On Error GoTo Errh
    DoCmd.SetWarnings False
    Dim db As Database
    Set db = CurrentDb
    Dim qdf As QueryDef
    Set qdf = db.CreateQueryDef("Q書出", "SELECT * INTO " & strWT & " IN ''[ODBC;" & strCN & "] " & strSQL)
    qdf.ODBCTimeout = 3
    DoCmd.OpenQuery "Q書出"
    DoCmd.SetWarnings True
    db.QueryDefs.Delete "Q書出"
    tempEXPORT = True
    Exit Function
Errh:
    DoCmd.SetWarnings True
    db.QueryDefs.Delete "Q書出"
    tempEXPORT = False
End Function

PostgreSQLの一時テーブル「temp売上伝票」にレコードを挿入するコードの記述

標準モジュールにPostgreSQLの一時テーブル「temp売上伝票」にレコードを挿入する関数「tempINSERT」を記述しました。

Public Function tempINSERT(ByVal strWT As String, ByVal strSQL As String) As Boolean
    On Error GoTo Errh
    DoCmd.SetWarnings False
    Dim db As Database
    Set db = CurrentDb
    Dim qdf As QueryDef
    Set qdf = db.CreateQueryDef("Q挿入", "INSERT INTO " & strWT & " IN ''[ODBC;" & strCN & "] " & strSQL)
    qdf.ODBCTimeout = 3
    DoCmd.OpenQuery "Q挿入"
    DoCmd.SetWarnings True
    db.QueryDefs.Delete "Q挿入"
    tempINSERT = True
    Exit Function
Errh:
    DoCmd.SetWarnings True
    db.QueryDefs.Delete "Q挿入"
    tempINSERT = False
End Function

PostgreSQLの一時テーブルをクリアするコードの記述

標準モジュールにPostgreSQLの一時テーブルをクリアする関数「tempTRUNCATE」を作成しました。

Public Function tempTRUNCATE(ByVal strWT As String) As Boolean
    On Error GoTo Errh
    Dim cn As New ADODB.Connection
    cn.Open strCN
    Dim cmd As New ADODB.Command
    cmd.ActiveConnection = cn
    cmd.CommandTimeout = 3
    cmd.CommandType = adCmdText
    cmd.CommandText = "TRUNCATE """ & strWT & """"
    cmd.Execute
    Set cmd = Nothing
    cn.Close: Set cn = Nothing
    tempTRUNCATE = True
    Exit Function
Errh:
    Set cmd = Nothing
    cn.Close: Set cn = Nothing
    tempTRUNCATE = False
End Function

PostgreSQLの一時テーブルを削除するコードの記述

標準モジュールにPostgreSQLの一時テーブルを削除する関数「tempDROP」を作成しました。

Public Function tempDROP(ByVal strWT As String) As Boolean
    On Error GoTo Errh
    Dim cn As New ADODB.Connection
    cn.Open strCN
    Dim cmd As New ADODB.Command
    cmd.ActiveConnection = cn
    cmd.CommandTimeout = 3
    cmd.CommandType = adCmdText
    cmd.CommandText = "DROP TABLE IF EXISTS """ & strWT & """"
    cmd.Execute
    Set cmd = Nothing
    cn.Close: Set cn = Nothing
    tempDROP = True
    Exit Function
Errh:
    Set cmd = Nothing
    cn.Close: Set cn = Nothing
    tempDROP = False
End Function


フォーム用プロシージャの記述

「Fサンプル」の読み込み時と、「新規作成」ボタンおよび「保存」ボタンのクリック時のイベントプロシージャに以下のコードを記述しました。

Private Sub Form_Load()
    On Error GoTo Errh
    Dim strSQL As String
Importh:
    If wtDELETE("WT売上伝票") = False Then GoTo Errh
    If wtDELETE("WT売上明細") = False Then GoTo Errh
    strSQL = "SELECT * FROM T売上伝票 IN ''[ODBC;" & strCN & "]"
    If wtINSERT("WT売上伝票", strSQL) = False Then GoTo Errh
    Me.sub伝票一覧.Requery
    If DCount("*", "WT売上伝票") = 0 Then Exit Sub
    [伝票番号] = Me.sub伝票一覧.Form![伝票番号]
    [日付] = Me.sub伝票一覧.Form![日付]
    strSQL = "SELECT * FROM T売上明細 IN ''[ODBC;" & strCN & "] WHERE 伝票番号=" & [伝票番号]
    If wtINSERT("WT売上明細", strSQL) = False Then GoTo Errh
    Me.sub売上明細.Requery
    Exit Sub
Errh:
    Dim msg As String
    Dim res As Integer
    msg = "エラーが発生しました。" & vbCrLf & "もう一度読み込みますか？"
    res = MsgBox(msg, vbYesNo + vbExclamation, "確認")
    If res = vbNo Then
        DoCmd.Close acForm, Me.Name
    Else
        GoTo Importh
    End If
End Sub

'「新規作成」ボタンクリック時のプロシージャ--------------------------------------------
Private Sub btnNew_Click()
    Dim n As Integer
    If GetID(n) Then
        [伝票番号] = n
    Else
        [伝票番号] = Null
    End If
    Call wtDELETE("WT売上明細")
    [日付] = Null
    Me.sub売上明細.SourceObject = "F売上明細"
End Sub

'「保存」ボタンクリック時のプロシージャ-------------------------------------------------
Private Sub btnUpdate_Click()
    If IsNull([伝票番号]) Then Exit Sub
    '売上明細ゼロ件の時、売上伝票を削除する-----------------------------------
Deleteh:
    If DCount("*", "Q売上明細") = 0 Then
        If tDELETE([伝票番号]) = False Then GoTo Errh
        [伝票番号] = Null
        [日付] = Null
        MsgBox "保存しました。", vbInformation, "確認"
        GoTo UD:
    End If
  '---------------------------------------------------------------------------
    On Error GoTo Errh
    'PostgreSQLの一時テーブルにAccessのデータを転記する--------------------------
    Dim strSQL As String
    If tempDROP("TEMP売上伝票") = False Then GoTo Errh
    If tempDROP("TEMP売上明細") = False Then GoTo Errh
    strSQL = "FROM WT売上伝票"
    If tempEXPORT("TEMP売上伝票", strSQL) = False Then GoTo Errh
    If tempTRUNCATE("TEMP売上伝票") = False Then GoTo Errh
    strSQL = "VALUES(" & [伝票番号]
    strSQL = strSQL & ",'" & [日付]
    strSQL = strSQL & "')"
    If tempINSERT("TEMP売上伝票", strSQL) = False Then GoTo Errh
    strSQL = "FROM WT売上明細"
    If tempEXPORT("TEMP売上明細", strSQL) = False Then GoTo Errh
    On Error GoTo 0
    '---------------------------------------------------------------------------
    'PostgreSQLの一時テーブルから生データテーブルに転記する----------------------
    If ExecutePostgreSQLStoredProcedure("import売上情報()") = True Then
        MsgBox "保存しました。", vbInformation, "確認"
        If tempDROP("TEMP売上伝票") = False Then GoTo Errh
        If tempDROP("TEMP売上明細") = False Then GoTo Errh
    Else
        GoTo Errh
    End If
    '---------------------------------------------------------------------------
UD:
    Me.sub伝票一覧.Form.Painting = False
    If wtDELETE("WT売上伝票") = False Then GoTo Errh
    strSQL = "SELECT * FROM T売上伝票 IN ''[ODBC;" & strCN & "]"
    If wtINSERT("WT売上伝票", strSQL) = False Then GoTo Errh
    Me.sub伝票一覧.Requery
    If Not IsNull([伝票番号]) Then
        Me.sub伝票一覧.Form.Recordset.MoveFirst
        Me.sub伝票一覧.Form.Recordset.FindFirst "伝票番号=" & [伝票番号]
    End If
    Me.sub伝票一覧.Form.Painting = True
    If DCount("*", "WT売上伝票") <> 0 Then
        [伝票番号] = Me.sub伝票一覧.Form.[伝票番号]
        [日付] = Me.sub伝票一覧.Form.[日付]
        If wtDELETE("WT売上明細") = False Then GoTo Errh
        strSQL = "SELECT * FROM T売上明細 IN ''[ODBC;" & strCN & "] WHERE 伝票番号=" & [伝票番号]
        If wtINSERT("WT売上明細", strSQL) = False Then GoTo Errh
        Me.sub売上明細.Requery
    End If
    Exit Sub
Errh:
    Dim msg As String
    Dim res As Integer
    msg = "エラーが発生しました。" & vbCrLf & "もう一度保存しますか？"
    res = MsgBox(msg, vbYesNoCancel + vbExclamation, "確認")
    If res = vbNo Then
        GoTo UD
    ElseIf res = vbYes Then
        GoTo Deleteh
    Else
        DoCmd.Close acForm, Me.Name
    End If
End Sub


サブフォーム用プロシージャの記述

「F伝票一覧」のクリック時に以下のイベントプロシージャを記述しました。

Public Sub Form_Click()
Importh:
    If wtDELETE("WT売上明細") = False Then GoTo Errh
    Forms![Fサンプル].[伝票番号] = [伝票番号]
    Forms![Fサンプル].[日付] = [日付]
    Dim strSQL As String
    strSQL = "SELECT * FROM T売上明細 IN ''[ODBC;" & strCN & "] WHERE 伝票番号=" & [伝票番号]
    If wtINSERT("WT売上明細", strSQL) = False Then GoTo Errh
    Forms![Fサンプル].sub売上明細.Form.Painting = False
    Forms![Fサンプル].sub売上明細.Requery
    Forms![Fサンプル].sub売上明細.Form.Painting = True
    Exit Sub
Errh:
    Dim msg As String
    Dim res As Integer
    msg = "エラーが発生しました。" & vbCrLf & "もう一度読み込みますか？"
    res = MsgBox(msg, vbYesNo + vbExclamation, "確認")
    If res = vbNo Then
        DoCmd.Close acForm, Me.Name
    Else
        GoTo Importh
    End If
End Sub

「F売上明細」の「削除」ボタンのクリック時に以下のイベントプロシージャを記述しました。

Private Sub btnDelete_Click()
    If Me.NewRecord Then
        MsgBox "新規レコードは削除できません。"
        Exit Sub
    End If
    [削除] = True
    Me.Requery
End Sub