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から主キー値を取得する関数「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に一時テーブルを生成する関数「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の一時テーブルをクリアする関数「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の一時テーブルを削除する関数「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
