【Access VBA】フォームの表示位置を指定する

フォームの表示位置を指定する

Windows APIを使ってフォームの表示位置を指定します。下記リンク先にて作成したカレンダーコントロールの表示位置が呼び出し元フォームのテキストボックスの位置に連動して変わるようにします。
【Access VBA】カレンダーコントロールの作成 - カットマンブログ

twipをpixelに変換する関数の記述

テキストボックスの位置がtwip単位で取得されるため、これをpixelに変換する関数を標準モジュールに記述します。下記サイトよりコピペしました。
Access VBA Form の位置、サイズはtwip単位で係数は567である #access - Qiita

Public Const SM_CYCAPTION As Long = 4
Public Const SM_CXFIXEDFRAME As Long = 7
Public Const SM_CYFIXEDFRAME As Long = 8
Public Const SM_CXFULLSCREEN As Long = 16
Public Const SM_CYFULLSCREEN As Long = 17
Public Const WU_LOGPIXELSX = 88
Public Const WU_LOGPIXELSY = 90

Public Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, ByRef lpRect As RECT) As LongPtr
Public Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Public Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As LongPtr
Public Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As LongPtr
Public Declare PtrSafe Function MoveWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As LongPtr
Public Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Public Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Public meRect_parent As RECT
Public meRect_client As RECT
Public ownerRect As RECT

Public Function ConvertTwipsToPixels(lngTwips As Long, lngDirection As Long) As Long
   'Handle to device
   Dim lngDC As Long
   Dim lngPixelsPerInch As Long
   Const nTwipsPerInch = 1440
   lngDC = GetDC(0)
   If (lngDirection = 0) Then       'Horizontal
      lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX)
   Else                            'Vertical
      lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY)
   End If
   lngDC = ReleaseDC(0, lngDC)
   ConvertTwipsToPixels = (lngTwips / nTwipsPerInch) * lngPixelsPerInch
End Function

カレンダーフォームの開く時のイベントプロシージャの記述

Fカレンダーの開く時のイベントプロシージャに以下のコードを記述します。
Fカレンダーが画面の右側にはみ出す場合に、Fカレンダーの右端がテキストボックスの右端にくるようにしています。
Fカレンダーが画面の下側にはみ出す場合に、Fカレンダーの下端がテキストボックスの上端にくるようにしています。

Private Sub Form_Open(Cancel As Integer)
    Dim leftPosition As Long
    Dim topPosition As Long
    Dim oForm As Object
    Set oForm = Forms(Application.CurrentObjectName)

    GetWindowRect Forms(Application.CurrentObjectName).hwnd, ownerRect

    Dim meWidth_parent As Long
    Dim meHeight_parent As Long
    GetWindowRect Me.hwnd, meRect_parent
    GetClientRect Me.hwnd, meRect_client
    With meRect_parent
        meWidth_parent = .Right - .Left 'Fカレンダーの幅
        meHeight_parent = .Bottom - .Top 'Fカレンダーの高さ
    End With
    Dim leftPosition_owner As Long
    Dim topPosition_owner As Long
    Dim xframeWidth As Long
    Dim titleHeight As Long
    Dim leftPosition_textbox As Long
    Dim topPosition_textbox As Long
    Dim textboxWidth As Long
    Dim textboxHeight As Long
    Dim screenWidth As Long
    Dim screenHeight As Long
    Dim meWidth_client As Long
    Dim meHeight_client As Long
    leftPosition_owner = ownerRect.Left '呼び出し元フォームの左位置
    topPosition_owner = ownerRect.Top '呼び出し元フォームの上位置
    xframeWidth = GetSystemMetrics(SM_CXFIXEDFRAME) 'ウインドウの水平罫線の太さ
    titleHeight = GetSystemMetrics(SM_CYCAPTION) 'タイトルバーの高さ
    screenWidth = GetSystemMetrics(SM_CXFULLSCREEN) '全画面表示ウインドウのクライアント領域の幅
    screenHeight = GetSystemMetrics(SM_CYFULLSCREEN) '全画面表示ウインドウのクライアント領域の高さ
    meWidth_client = meRect_client.Right 'Fカレンダーのクライアント領域の幅
    meHeight_client = meRect_client.Bottom 'Fカレンダーのクライアント領域の高さ
    
    With oForm.Controls(OpenArgs)
        leftPosition_textbox = ConvertTwipsToPixels(.Left, 0) 'テキストボックスの左位置
        topPosition_textbox = ConvertTwipsToPixels(.Top, 1) 'テキストボックスの上位置
        textboxWidth = ConvertTwipsToPixels(.Width, 0) 'テキストボックスの幅
        textboxHeight = ConvertTwipsToPixels(.Height, 1) 'テキストボックスの高さ
    End With
        If leftPosition_owner + leftPosition_textbox > screenWidth - meWidth_parent Then
            leftPosition = leftPosition_owner + leftPosition_textbox + textboxWidth - meWidth_client
        Else
            leftPosition = leftPosition_owner + leftPosition_textbox
        End If
        
        If topPosition_owner + xframeWidth + titleHeight + topPosition_textbox + textboxHeight > screenHeight - meHeight_parent Then
            topPosition = topPosition_owner + topPosition_textbox - meHeight_client
        Else
            topPosition = topPosition_owner + xframeWidth + titleHeight + topPosition_textbox + textboxHeight
        End If

    MoveWindow Me.hwnd, leftPosition, topPosition, meWidth_parent, meHeight_parent, True
End Sub

呼び出し元フォームのボタンクリック時イベントプロシージャの修正

呼び出し元フォームのボタンクリック時イベントプロシージャのOpenFormメソッドのOpenArgs引数にテキストボックスの名前を追加しました。

Private Sub btnCalendar_Click()
        sDate = Nz(txtDate, 0)
        DoCmd.OpenForm "Fカレンダー", , , , , acDialog, "txtDate"
        If sDate <> 0 Then
            txtDate = sDate
        End If
End Sub

アプリ作成で学ぶ Access VBAプログラミング ワンランク上のフォーム&レポート

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

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

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

テーブルを準備する

SQL Serverで「sample」という名前のデータベースの中に「T売上伝票」、「T売上明細」、「TEMP売上伝票」、「TEMP売上明細」の4つのテーブルを用意しました。「T売上伝票」、「T売上明細」は生データを保存するテーブルであり、「TEMP売上伝票」、「TEMP売上明細」は一時的にAccessから編集後のデータを受け取るテーブルです。この一時テーブルからストアドプロシージャを使って、生データのテーブルにデータを書き込みます。
さらに「T売上伝票」の主キー値発番用に「T発番」という名前のテーブルを用意しました。
発番用のストアドプロシージャについては下記リンク先を参照してください。
【Access VBA】主キー値をSQL Serverから取得する - カットマンブログ
Accessには「WT売上伝票」、「WT売上明細」の2つのテーブルを用意しました。


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

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

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

ALTER PROCEDURE [dbo].[import売上情報] 	
	
AS
BEGIN	
	SET NOCOUNT ON;
    BEGIN TRY
      BEGIN TRANSACTION
      --T売上伝票更新----------------------------------------------------	
	MERGE INTO [T売上伝票] AS A    
        USING
       (SELECT [伝票番号],[日付] FROM [TEMP売上伝票] WITH(TABLOCKX)) 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    
        (SELECT [明細ID],[伝票番号],[商品コード],[数量],[削除]
        FROM [TEMP売上明細] WITH(TABLOCKX)) AS D
        ON    
        (C.[明細ID] = D.[明細ID])
        WHEN MATCHED AND D.[削除]=0 THEN
          UPDATE SET [商品コード] =D.[商品コード], [数量] = D.[数量]		            
        WHEN MATCHED AND D.[削除]=1 THEN   
	      DELETE
        WHEN NOT MATCHED AND D.[削除]=0 THEN
          INSERT ([伝票番号],[商品コード],[数量])
          VALUES (D.[伝票番号],D.[商品コード],D.[数量]);
      -------------------------------------------------------------------			
      COMMIT TRANSACTION 
      RETURN-1 
    END TRY

    BEGIN CATCH
      ROLLBACK TRANSACTION		
      RETURN 0
    END CATCH
END

SQL Serverに「SetID」という名前のストアドプロシージャを用意しました。これにより「売上伝票」の主キー値を発番します。以下に「SetID」のコードを記載します。

ALTER PROCEDURE [dbo].[SetID]	
	@ID int OUTPUT 
AS
BEGIN	
	SET NOCOUNT ON;    
	BEGIN TRY
		BEGIN TRANSACTION
			SELECT @ID=	連番 FROM T発番 WITH(TABLOCKX)
			UPDATE T発番 SET 連番=@ID+1
		COMMIT TRANSACTION 
		RETURN -1 
	END TRY

	BEGIN CATCH
		ROLLBACK TRANSACTION		
		RETURN 0
	END CATCH
END

リンクテーブルの作成

Accessで「TEMP売上伝票」と「TEMP売上明細」のリンクテーブルを作成しました。
作成方法は下記リンク先を参照してください。
【Access】SQL Serverのリンクテーブル作成 - カットマンブログ

選択クエリの作成

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

フォームの準備

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


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

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

標準モジュールにAccessのテーブルをクリアし、SQL Serverのテーブルから売上伝票と売上明細を取得するプロシージャ「wtImport」を記述します。

Public Const strCN As String = "driver={ODBC Driver 17 for SQL Server};server=LAPTOP-114315\SQLEXPRESS;DATABASE=sample;uid=administrator;PWD=1111"
Public Sub wtImport(ByVal strWT As String, ByVal strSQL As String)
    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
    w_cmd.CommandText = "INSERT INTO " & strWT & " " & strSQL
    w_cmd.Execute
    Set w_cmd = Nothing
    w_cn.Close: Set w_cn = Nothing
End Sub

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

標準モジュールにSQL Serverの「T売上伝票」から目的のデータを削除するプロシージャ「tDelete」を作成しました。

Public Sub tDelete(ByVal intSlipNo As Integer)
    Dim cn As New ADODB.Connection
    cn.Open strCN
    Dim cmd As New ADODB.Command
    cmd.ActiveConnection = cn
    cmd.CommandType = adCmdText
    cmd.CommandText = "DELETE FROM T売上伝票 WHERE 伝票番号=" & intSlipNo
    cmd.Execute
    Set cmd = Nothing
    cn.Close: Set cn = Nothing
End Sub

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

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

Public Function GetID(ByRef n As Integer) As Boolean
    Dim cn As New ADODB.Connection
    cn.Open strCN
    Dim cmd As New ADODB.Command
    cmd.ActiveConnection = cn
    cmd.CommandType = adCmdStoredProc
    cmd.CommandText = "SetID"
    cmd.Parameters.Append cmd.CreateParameter(, adInteger, adParamReturnValue, , Null)
    cmd.Parameters.Append cmd.CreateParameter("@ID", adInteger, adParamOutput, , Null)
    cmd.Execute
    
    If CBool(cmd.Parameters(0).Value) Then
        n = cmd.Parameters("@ID").Value
        GetID = True
    Else
        MsgBox "エラーが発生しました。", vbExclamation, "確認"
        GetID = False
    End If
    Set cmd = Nothing
    cn.Close: Set cn = Nothing
End Function

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

標準モジュールにAccessのテーブルをクリアするプロシージャ「wtDelete」を作成しました。

Public Sub wtDelete(ByVal strWT As String)
    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
End Sub

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

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

Private Sub Form_Load()
    Dim strSQL As String
    strSQL = "SELECT * FROM T売上伝票 IN ''[ODBC;" & strCN & "] "
    Call wtImport("WT売上伝票", strSQL)
    Me.sub伝票一覧.Requery
    If DCount("*", "WT売上伝票") = 0 Then Exit Sub
    [伝票番号] = Forms![Fサンプル].sub伝票一覧.Form![伝票番号]
    [日付] = Forms![Fサンプル].sub伝票一覧.Form![日付]
    strSQL = "SELECT * FROM T売上明細 IN ''[ODBC;" & strCN & "] WHERE 伝票番号=" & [伝票番号]
    Call wtImport("WT売上明細", strSQL)
    Me.sub売上明細.Requery
End Sub

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

'「保存」ボタンクリック時のプロシージャ-------------------------------------
Private Sub btnUpdate_Click()
    If IsNull([伝票番号]) Then Exit Sub
    '売上明細ゼロ件の時、売上伝票を削除する-----------------------------------
    If DCount("*", "Q売上明細") = 0 Then
        Call tDelete([伝票番号])
        [伝票番号] = Null
        [日付] = Null
        GoTo UD
    End If
    '---------------------------------------------------------------------------
    On Error GoTo Errh
    'SQLServerの一時テーブルにAccessのデータを転記する--------------------------
    Dim cn As New ADODB.Connection
    cn.Open strCN
    Dim cmd As New ADODB.Command    
    cmd.ActiveConnection = cn
    cmd.CommandType = adCmdText
    cmd.CommandText = "TRUNCATE TABLE TEMP売上明細"
    cmd.Execute
    cmd.CommandText = "TRUNCATE TABLE TEMP売上伝票"
    cmd.Execute
    
    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 = "INSERT INTO TEMP売上明細 SELECT * FROM WT売上明細"
    w_cmd.Execute
    
    Dim strSQL As String
    strSQL = "VALUES(" & [伝票番号]
    strSQL = strSQL & ",'" & [日付]
    strSQL = strSQL & "')"
    w_cmd.CommandType = adCmdText
    w_cmd.CommandText = "INSERT INTO TEMP売上伝票 " & strSQL
    w_cmd.Execute
   
    Set w_cmd = Nothing
    w_cn.Close: Set w_cn = Nothing
    On Error GoTo 0
    '---------------------------------------------------------------------------
    'SQLServerの一時テーブルから生データテーブルに転記する----------------------
    cmd.CommandType = adCmdStoredProc
    cmd.CommandText = "import売上情報"
    
    cmd.Parameters.Append cmd.CreateParameter(, adInteger, adParamReturnValue, , Null)
    cmd.Execute
    
    If CBool(cmd.Parameters(0).Value) Then
        GoTo UD
    Else
        MsgBox "エラーが発生しました。", vbExclamation, "確認"
        Set cmd = Nothing
        cn.Close: Set cn = Nothing
        Exit Sub
    End If
    '---------------------------------------------------------------------------
UD:
    Set cmd = Nothing
    cn.Close: Set cn = Nothing
    Me.Painting = False
    strSQL = "SELECT * FROM T売上伝票 IN ''[ODBC;" & strCN & "] "
    Call wtImport("WT売上伝票", strSQL)
    
    Me.sub伝票一覧.Requery
    If Not IsNull([伝票番号]) Then
        Me.sub伝票一覧.Form.Recordset.FindFirst "伝票番号=" & [伝票番号]
    End If
    Me.Painting = True
    If DCount("*", "WT売上伝票") <> 0 Then
        [伝票番号] = Me.sub伝票一覧.Form.[伝票番号]
        [日付] = Me.sub伝票一覧.Form.[日付]
    
        strSQL = "SELECT * FROM T売上明細 IN ''[ODBC;" & strCN & "]" _
                        & "WHERE 伝票番号=" & [伝票番号]
    
        Call wtImport("WT売上明細", strSQL)
        Me.Painting = False
        Me.sub売上明細.Requery
        Me.Painting = True
    End If
    MsgBox "保存しました。", vbInformation, "確認"
    Exit Sub
Errh:
    MsgBox "エラーが発生しました。", vbExclamation, "確認"
End Sub

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

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

Public Sub Form_Click()
    Forms![Fサンプル].[伝票番号] = [伝票番号]
    Forms![Fサンプル].[日付] = [日付]
    Dim strSQL As String
    strSQL = "SELECT * FROM T売上明細 IN ''[ODBC;" & strCN & "] WHERE 伝票番号=" & [伝票番号]
    Call wtImport("WT売上明細", strSQL)
    Forms![Fサンプル].sub売上明細.Form.Painting = False
    Forms![Fサンプル].sub売上明細.Requery
    Forms![Fサンプル].sub売上明細.Form.Painting = True
End Sub

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

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

    [削除] = True
    Me.Requery
End Sub

アプリ作成で学ぶ Visual Basic データベースプログラミング for SQL Server 2012

【Access VBA】「あかさたな」ボタンでフォームにフィルターをかける

「あかさたな」ボタンでフォームにフィルターをかける

「あ」ボタンをクリックするとフリガナの頭文字があ行の市区町村のレコードのみ表示されます。

フォームに「あかさたな」ボタンを配置する

フォームに「あかさたな」ボタンを配置しました。名前とタグを以下のように設定しました。

コードの記述

クラスモジュールにclsFilterを作成し、下記コードを記述します。

Private WithEvents mbtn As CommandButton
Private mForm As Form
 
Public Sub Bind(ByVal oForm As Form, ByVal oCtrl As Control)
    Set mForm = oForm
    Set mbtn = oCtrl
    mbtn.OnClick = "[EVENT PROCEDURE]"
End Sub

Private Sub mbtn_Click()
    If mbtn.Tag = "全件" Then       
        mForm.FilterOn = False
    Else
        mForm.Filter = "フリガナ Like '[" & mbtn.Tag & "]*'"
        mForm.FilterOn = True
    End If
    DoCmd.GoToRecord , , acNewRec
    DoCmd.GoToControl "市区町村名"
End Sub

フォームの読み込み時イベントプロシージャに下記コードを記述します。

Private aClassFilter(10) As New clsFilter
Private Sub Form_Load()
    Dim i As Integer
   
    For i = 0 To 10
        Call aClassFilter(i).Bind(Me, Controls("btn" & i))
    Next
    
    DoCmd.GoToRecord , , acNewRec
    DoCmd.GoToControl "市区町村名"
End Sub

アプリ作成で学ぶ Access VBAプログラミング ワンランク上のフォーム&レポート

【Access VBA】SQL Serverからユニオンクエリの結果を取得する

2つのテーブルを合計した結果をグラフ表示する

SQL Serverにある２つのテーブルを合計した結果をAccessに取り込み、グラフ表示します。

SQL Serverにテーブルを準備する

SQL Serverで「sample」という名前のデータベースの中に「Tサンプル1」、「Tサンプル2」および「Tユニオンサンプル」の3つのテーブルを用意しました。ユニオンクエリの結果を「Tユニオンサンプル」に取り込みます。

Accessでフォームを準備する

下記のブログ記事でグラフを表示するフォームを作成しました。このときは「Tサンプル」テーブルをAccessに作成しましたが、今回は2つのテーブルをSQL Serverに作成し、ユニオンクエリの結果をAccessに取り込みます。。
【Access VBA】月別グラフの作成－データのない日も表示する - カットマンブログ

参照設定の準備

Visual Basic Editorを表示し、「ツール」タブの「参照設定」をクリック
　　　↓
「Microsoft ActiveX Data Objects ×.× Library」をチェック

コードの記述

標準モジュールの「SetLastDay」プロシージャを下記のコードで置き換えます。

Public Sub SetLastDay(ByVal Y As Integer, ByVal M As Integer)
'----------SQL Serverでユニオンクエリの結果を「Tユニオンサンプル」に取り込む----------
    Dim strCN As String
    Dim cn As New ADODB.Connection
    strCN = "driver={ODBC Driver 17 for SQL Server};server=LAPTOP-114315\SQLEXPRESS;DATABASE=sample;uid=administrator;PWD=1111"
    cn.Open strCN
    Dim cmd As New ADODB.Command
    cmd.ActiveConnection = cn
    cmd.CommandType = adCmdText
    cmd.CommandText = "DELETE FROM Tユニオンサンプル"
    cmd.Execute
    cmd.CommandText = "INSERT INTO Tユニオンサンプル SELECT A.日付,A.数量 FROM Tサンプル1 AS A UNION ALL SELECT B.日付,B.数量 FROM Tサンプル2 AS B"
    cmd.Execute
    Set cmd = Nothing
    cn.Close: Set cn = Nothing
'----------SQL Serverの「Tユニオンサンプル」から目的のデータを取り出す----------------
    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 WTサンプル"
    w_cmd.Execute
    w_cmd.CommandText = "INSERT INTO WTサンプル SELECT A.日付, A.数量 FROM Tユニオンサンプル AS A IN ''[ODBC;" & strCN & "] WHERE Year(A.日付) =" & Y _
                        & "AND Month(A.日付) =" & M & " ORDER BY A.日付"
    w_cmd.Execute
    Set w_cmd = Nothing
'-------------------------------------------------------------------------------------
    Dim i As Integer
    Dim LastDay As Integer
    LastDay = Day(DateSerial(Y, M + 1, 1) - 1)
'----------「WTサンプル」に月初と月末の空白データを作成-----------------------------
    Dim w_strSQL As String
    w_strSQL = "SELECT * FROM WTサンプル"
    Dim w_rs As New ADODB.Recordset
    w_rs.Open w_strSQL, w_cn, adOpenKeyset, adLockOptimistic
    If w_rs.RecordCount <> 0 Then
        For i = Day(DMin("日付", "WTサンプル")) - 1 To 1 Step -1
            w_rs.AddNew
            w_rs![日付] = DateSerial(Y, M, i)
            w_rs![数量] = 0
            w_rs.Update
        Next
        For i = Day(DMax("日付", "WTサンプル")) + 1 To LastDay
            w_rs.AddNew
            w_rs![日付] = DateSerial(Y, M, i)
            w_rs![数量] = 0
            w_rs.Update
        Next
    End If
'--------------------------------------------------------------------------------------
    w_rs.Close: Set w_rs = Nothing
    w_cn.Close: Set w_cn = Nothing
End Sub

アプリ作成で学ぶ Visual Basic データベースプログラミング for SQL Server 2012

【Access VBA】主キー値をSQL Serverから取得する

主キー値をSQL Serverから取り出す

AccessをSQL Serverのテーブルに接続し、新規レコード保存の際、主キー値をSQL Serverで設定します。

SQL Serverにテーブルを準備する

SQL Serverで「sample」という名前のデータベースの中に「Tサンプル」という名前のテーブルと「T発番」という名前のテーブルを用意しました。

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

SQL Serverに「SetID」という名前のストアドプロシージャを用意しました。

ALTER PROCEDURE [dbo].[SetID]
	
	@ID int OUTPUT 
AS
BEGIN
	
	SET NOCOUNT ON;
    
	BEGIN TRY
		BEGIN TRANSACTION
			SELECT @ID=連番 FROM T発番 WITH(TABLOCKX)
			UPDATE T発番 SET 連番=@ID+1
		COMMIT TRANSACTION 
		RETURN-1 
	END TRY

	BEGIN CATCH
		ROLLBACK TRANSACTION		
		RETURN 0
	END CATCH
END

フォームの準備

下のようなラベル3個、テキストボックス３個、ボタン１個を配置した非連結フォームを用意しました。

コードの記述

フォームの開く時と「更新」ボタンのクリック時に下記イベントプロシージャを記述しました。

Private cn As New ADODB.Connection
Private rs As New ADODB.Recordset
Private Sub Form_Open(Cancel As Integer)
'-----------SQL Serverの「sample」データベースに接続-----------------------
    Dim strCN As String
    strCN = "driver={ODBC Driver 17 for SQL Server};server=LAPTOP-114315\SQLEXPRESS;DATABASE=sample;uid=administrator;PWD=1111"
    cn.Open strCN
'------------------------------------------------------------------------------------
'-----------ストアドプロシージャからIDを取得---------------------------------
    Dim cmd As New ADODB.Command
    cmd.ActiveConnection = cn
    cmd.CommandType = adCmdStoredProc
    cmd.CommandText = "SetID"
    cmd.Parameters.Append cmd.CreateParameter(, adInteger, adParamReturnValue, , Null)
    cmd.Parameters.Append cmd.CreateParameter("@ID", adInteger, adParamOutput, , Null)
    cmd.Execute
    
    If CBool(cmd.Parameters(0).Value) Then
        If IsNull(txtID) Then
            txtID = cmd.Parameters("@ID").Value
        End If
    Else
        MsgBox "IDの取得に失敗しました。", vbExclamation, "確認"
        cn.Close: Set cn = Nothing
        Cancel = True
    End If
'-----------------------------------------------------------------------------------
End Sub
Private Sub btnUpdate_Click()
    Dim strSQL As String
    strSQL = "SELECT * FROM Tサンプル WHERE ID=" & txtID
    rs.Open strSQL, cn, adOpenKeyset, adLockOptimistic

            rs.AddNew
            rs![ID] = txtID
            rs![日付] = txtDate
            rs![数量] = txtQuantity
            rs.Update

    rs.Close: Set rs = Nothing
    cn.Close: Set cn = Nothing
    DoCmd.Close
End Sub

テスト

現在、「ID」が「130」までのデータが保存されているとします。

フォームを開くと「ID」テキストボックスに「131」が発番されます。

日付と数量を入力し「更新」ボタンをクリックするとテーブルにレコードが保存されます。

アプリ作成で学ぶ Visual Basic データベースプログラミング for SQL Server 2012

【Access VBA】SQL ServerにADOで接続する

SQL Serverにテーブルを準備する

SQL Serverで「sample」という名前のデータベースの中に「Tサンプル」という名前のテーブルを用意しました。

Accessでフォームを準備する

下記のブログ記事でグラフを表示するフォームを作成しました。このときは「Tサンプル」テーブルをAccessに作成しましたが、今回は「Tサンプル」テーブルをSQL Serverに作成し、ADOで接続します。

【Access VBA】月別グラフの作成－データのない日も表示する - カットマンブログ

参照設定の準備

Visual Basic Editorを表示し、「ツール」タブの「参照設定」をクリック
　　　↓
「Microsoft ActiveX Data Objects ×.× Library」をチェック

コードの記述

標準モジュールの「SetLastDay」プロシージャを下記のコードで置き換えます。

Public Sub SetLastDay(ByVal Y As Integer, ByVal M As Integer)
'----------SQL Serverの「Tサンプル」から目的のデータを取り出す--------------------
    Dim w_cn As ADODB.Connection
    Set w_cn = CurrentProject.Connection
    Dim cmd As New ADODB.Command
    cmd.ActiveConnection = w_cn
    cmd.CommandType = adCmdText
    cmd.CommandText = "DELETE FROM WTサンプル"
    cmd.Execute
    Dim strCN As String
    strCN = "driver={ODBC Driver 17 for SQL Server};server=LAPTOP-114315\SQLEXPRESS;DATABASE=sample;uid=administrator;PWD=1111"
    cmd.CommandText = "INSERT INTO WTサンプル SELECT A.日付, A.数量 FROM Tサンプル AS A IN ''[ODBC;" & strCN & "] WHERE Year(A.日付) =" & Y _
                        & "AND Month(A.日付) =" & M & " ORDER BY A.日付"
    cmd.Execute
    Set cmd = Nothing
'----------------------------------------------------------------------------------
    Dim i As Integer
    Dim LastDay As Integer
    LastDay = Day(DateSerial(Y, M + 1, 1) - 1)
'----------「WTサンプル」に月初と月末の空白データを作成---------------------------
    Dim w_strSQL As String
    w_strSQL = "SELECT * FROM WTサンプル"
    Dim w_rs As New ADODB.Recordset
    w_rs.Open w_strSQL, w_cn, adOpenKeyset, adLockOptimistic
    If w_rs.RecordCount <> 0 Then
        For i = Day(DMin("日付", "WTサンプル")) - 1 To 1 Step -1
            w_rs.AddNew
            w_rs![日付] = DateSerial(Y, M, i)
            w_rs![数量] = 0
            w_rs.Update
        Next
        For i = Day(DMax("日付", "WTサンプル")) + 1 To LastDay
            w_rs.AddNew
            w_rs![日付] = DateSerial(Y, M, i)
            w_rs![数量] = 0
            w_rs.Update
        Next
    End If
'-----------------------------------------------------------------------------------
    w_rs.Close: Set w_rs = Nothing
    w_cn.Close: Set w_cn = Nothing
End Sub

グラフ表示されました。

アプリ作成で学ぶ Visual Basic データベースプログラミング for SQL Server 2012

【Access】SQL Serverのリンクテーブル作成

SQL Serverにテーブルを準備

SQL Serverで「sample」という名前のデータベースの中に「Tサンプル」という名前のテーブルを用意しました。

テーブルのリンク設定

「外部データ」タブの「インポートとリンク」グループの「ODBCデータベース」をクリック
「外部データの取り込み」ダイアログボックスが表示されるので、「リンクテーブルを作成してソースデータにリンクする」を選択して、「OK」をクリック

「データソースの選択」ダイアログボックスが開くので、「コンピューターデータソース」タグの「新規作成」ボタンをクリック

「ODBC System DSNに関する警告」ダイアログボックスが表示されるが、「OK」をクリック

「データソースの新規作成」ダイアログボックスが開くので、「次へ」をクリック

「セットアップするデータソースのドライバーを選択してください」の画面で、「SQL Server」を選択して、「次へ」をクリック

「完了」をクリック

「SQL Serverに接続するための新規データソースを作成する」ダイアログボックスが表示されるので、「名前」に「サンプル」、「サーバー」にSQL Serverのサーバー名を入力し、「次へ」をクリック
SQL Serverのサーバー名はSQL Server Management Studio起動時に表示されるものを使用してください。

「ユーザーが入力するSQL Server用ログインIDとパスワードを使う」を選択し、「ログインID」と「パスワード」を入力して、「次へ」をクリック
「ログインID」と「パスワード」はSQL Server Management Studio起動時に表示されるものを使用してください。

「既定のデータベースを以下のものに変更する」をチェックし、「sample」を選択し、「次へ」をクリック

「SQL Serverのシステムメッセージを以下の言語に変更する」をチェックし、「Japanese」を選択し、「完了」をクリック

「ODBC Microsoft SQL Server セットアップ」ダイアログボックスの「データソースのテスト」ボタンをクリック

「テストは無事に完了しました。」と表示されれば、「OK」をクリック

新規データソースが追加されているのを確認して「OK」をクリック

「SQL Serverログイン」ダイアログボックスが表示されるので「パスワード」を入力して「OK」をクリック

「テーブルのリンク」ダイアログボックスが表示されるので「dbo.Tサンプル」を選択、「パスワードの保存」をチェックして「OK」をクリック

「パスワードの保存」をクリック

「固有レコード識別子の選択」画面で主キーを設定したフィールドを選択して「OK」をクリック

ナビゲーションウインドウにリンクテーブルが表示されます。

リンクテーブルの更新

SQL Serverのテーブルに新規フィールド「商品名」を追加してみました。

Accessのリンクテーブルを開くと「商品名」フィールドが表示されていません。

リンクテーブルを右クリックして「リンクテーブルマネージャー」を開きます。

リンク先を更新するテーブルをチェックし、「OK」をクリック

リンクテーブルを開くと「商品名」フィールドが表示されました。

アプリ作成で学ぶ Visual Basic データベースプログラミング for SQL Server 2012