ADOを使って画面上の入力内容をデータベースに更新するサンプルです。
VBAでデータベースを更新するということは．．．
それもマスタ登録系プログラムを作成するということは結構本格的なプログラムを用意しようという計画があるのだと思います。
1人で登録するためのプログラムであればこのページのような方法でも良いのでしょうが、 社内の多数の方に作成したプログラム(マクロが搭載されているワークブック)を配布するのであれば、 「配布の問題」が付いてくることを念頭に置いて下さい。 安易に手がけると後で問題が発生することになります。
本格的にプログラムを用意するのであれば、VisualBasic.NETで開発し、ClickOnceで現場配給させるような仕組みにした方が、後で苦労することが避けられます。
このページの説明はあくまでもサンプルとしてのものであって、この方法自体をお勧めしているわけではありません。
1人で登録するためのプログラムであればこのページのような方法でも良いのでしょうが、 社内の多数の方に作成したプログラム(マクロが搭載されているワークブック)を配布するのであれば、 「配布の問題」が付いてくることを念頭に置いて下さい。 安易に手がけると後で問題が発生することになります。
本格的にプログラムを用意するのであれば、VisualBasic.NETで開発し、ClickOnceで現場配給させるような仕組みにした方が、後で苦労することが避けられます。
このページの説明はあくまでもサンプルとしてのものであって、この方法自体をお勧めしているわけではありません。
- これは、配属マスタの変更を行なうというサンプルです。
-
(画像をクリックすると、このページのサンプルがダウンロードできます)
「MDB(ACCDB)配属登録変更.xlsm」を開きます。即座に、配属一覧が表示されます。
今回は一覧表示だけではなく、ここから社員コードの行を選択してその社員の部署や役職を変更するというサンプルです。
どれかの社員コードの行を選択すると、
このように「配属情報の登録・変更」の画面が表示されます。
今回のサンプルは、データベース(MDB又はACCDB)への更新を行なうケースの説明のためのもので、あまり複雑な要素を持ち込みたくなかったので、社員コードあたりの部署・配属の変更の更新のみとしています。
配属マスタ(MST_HAIZOKU)は人事異動などの対応で開始日、終了日のフィールドを持っていますが、新しい開始日での追加登録の機能は盛り込んでおらず、先頭の開始日(入社日)時点のレコードの更新のみとなります。
「配属情報の登録・変更」の画面では、部署、役職がプルダウンで変更でき、「登録」ボタンのクリックで配属マスタ(MST_HAIZOKU)が更新されて、配属一覧のシートも合わせて更新されるようになっています。
以降はこのサンプルのソースコードの説明になります。
- 最初は「ThisWorkbook」です。
-
「ThisWorkbook」では起動時のイベントで一覧表示を行なうことや、保存時に一覧表示をクリアなどを行ないます。
途中の共用できる各機能は標準モジュールに実装させて呼び出しているので、後述します。'*************************************************************************************************** ' ADOでAccessデータベースを更新する ThisWorkbook(Class) ' ' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!] '*************************************************************************************************** ' [参照設定] ' ・Microsoft Active Data Object 2.x Library(2.8 or Later) '*************************************************************************************************** ' 変更日付 Rev 変更履歴内容----------------------------------------------------------------------> ' 16/12/31(1.0.0)新規作成 ' 19/11/24(1.1.0)Workbook_BeforeSaveがOfficeの自動保存に影響されないように修正 '*************************************************************************************************** Option Explicit '*************************************************************************************************** ' ■■■ ワークブックイベント ■■■ '*************************************************************************************************** '* 処理名 ：Workbook_BeforeSave '* 機能 ：ブックの保存前イベント '--------------------------------------------------------------------------------------------------- '* 返り値 ：(なし) '* 引数 ：(既定) '--------------------------------------------------------------------------------------------------- '* 作成日 ：2016年12月31日 '* 作成者 ：井上 治 '* 更新日 ：2019年11月24日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項： '*************************************************************************************************** Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) '----------------------------------------------------------------------------------------------- ' シート初期化は手動保存時のみとする If SaveAsUI Then Call GP_ClearSheet(ThisWorkbook.Worksheets(1)) End If ThisWorkbook.Worksheets(1).Range("$A$1").Select End Sub '*************************************************************************************************** '* 処理名 ：Workbook_Open '* 機能 ：ブックを開く '--------------------------------------------------------------------------------------------------- '* 返り値 ：(なし) '* 引数 ：(なし) '--------------------------------------------------------------------------------------------------- '* 作成日 ：2016年12月31日 '* 作成者 ：井上 治 '* 更新日 ：2016年12月31日 '* 更新者 ：井上 治 '* 機能説明：本ブックと同じフォルダにある｢SampleCorp1.mdb｣から配属データを取得してシートに展開 '* 注意事項： '*************************************************************************************************** Private Sub Workbook_Open() '----------------------------------------------------------------------------------------------- Dim dbCon As ADODB.Connection ' ADODB.Connection Dim dbRes As ADODB.Recordset ' ADODB.Recordset Dim objSh As Worksheet ' Excel.Worksheet Dim strSQL As String ' SQL文編集WORK Dim strToday As String ' SQL文本日編集WORK Dim lngRow As Long ' 行INDEX '----------------------------------------------------------------------------------------------- ' データベースへの接続 If Not FP_GetSqlConnection(dbCon) Then Exit Sub '----------------------------------------------------------------------------------------------- ' 参照SQL文の編集・発行 strToday = "#" & Format(Date, "yyyy-MM-dd") & "#" strSQL = FP_GetSqlCommon strSQL = strSQL & " WHERE S.[NYUSYA_YMD]<=" & strToday strSQL = strSQL & " AND (S.[TAISYOKU_YMD] IS NULL OR S.[TAISYOKU_YMD]>" & strToday & ")" strSQL = strSQL & " ORDER BY H.[SCD];" ' 参照SQL文の発行 Set dbRes = New ADODB.Recordset dbRes.Open strSQL, dbCon, adOpenKeyset, adLockReadOnly '----------------------------------------------------------------------------------------------- ' 画面描画更新停止 Call GP_StopSCUPD ' シート初期化 Set objSh = ThisWorkbook.Worksheets(1) Call GP_ClearSheet(objSh) '----------------------------------------------------------------------------------------------- lngRow = 1 ' 先頭レコードからEOFまで繰り返す Do Until dbRes.EOF ' 行を加算 lngRow = lngRow + 1 ' 一覧シート1行分の編集 Call GP_SetSheetRow(objSh, dbRes, lngRow) ' 次のレコードに移る dbRes.MoveNext Loop '----------------------------------------------------------------------------------------------- ' レコードセット、データベース接続を閉じる dbRes.Close Set dbRes = Nothing dbCon.Close Set dbCon = Nothing ' 画面描画更新復帰 Call GP_StartSCUPD Range("$A$1").Select ' 保存済み状態にする ThisWorkbook.Saved = True End Sub '------------------------------------------<< End of Source >>--------------------------------------
- 次は「Sheet1」です。
-
「Sheet1」で行なっているのは、シート上のセルを選択した時にその行の社員コードについての登録変更画面を表示させます。
登録変更画面で更新が行なわれた時は、当該行だけをデータベース(MDB又はACCDB)から参照し直して一覧表示も更新させます。
'*************************************************************************************************** ' ADOでAccessデータベースを更新する Sheet1(Class) ' ' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!] '*************************************************************************************************** ' [参照設定] ' ・Microsoft Active Data Object 2.x Library(2.8 or Later) '*************************************************************************************************** ' 変更日付 Rev 変更履歴内容----------------------------------------------------------------------> ' 16/12/31(1.0.0)新規作成 '*************************************************************************************************** Option Explicit '=================================================================================================== Private g_lngFormLeft As Long ' フォーム位置(横) Private g_lngFormTop As Long ' フォーム位置(縦) '*************************************************************************************************** ' ■■■ ワークシートイベント ■■■ '*************************************************************************************************** '* 処理名 ：Worksheet_SelectionChange '* 機能 ：選択セル変更イベント '--------------------------------------------------------------------------------------------------- '* 返り値 ：(なし) '* 引数 ：(既定) '--------------------------------------------------------------------------------------------------- '* 作成日 ：2016年12月31日 '* 作成者 ：井上 治 '* 更新日 ：2016年12月31日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項： '*************************************************************************************************** Private Sub Worksheet_SelectionChange(ByVal Target As Range) '----------------------------------------------------------------------------------------------- ' 複数セル選択自は無視 If Target.Count > 1 Then Exit Sub ' 2行目以降でA列に社員コードがあることが条件 If Target.Row < 2 Or Cells(Target.Row, 1).Value = "" Then Exit Sub '----------------------------------------------------------------------------------------------- Dim lngRow As Long ' 行INDEX Dim strScd As String ' 社員コード Dim blnReturnValue As Boolean ' 処理結果 lngRow = Target.Row strScd = Cells(lngRow, 1).Value With FRM_HAIZOKU ' 表示位置の再現 If ((g_lngFormLeft <> 0) Or (g_lngFormTop <> 0)) Then .StartUpPosition = 0 .Left = g_lngFormLeft .Top = g_lngFormTop Else .StartUpPosition = 2 End If .prpScd = strScd .Show ' 結果と表示位置を退避 blnReturnValue = .prpReturnValue g_lngFormLeft = .Left g_lngFormTop = .Top End With ' 登録されていたら一覧を更新(対象行のみ) If blnReturnValue Then Call GP_UpdateRow(lngRow, strScd) End If End Sub '*************************************************************************************************** ' ■■■ サブ処理 ■■■ '*************************************************************************************************** '* 処理名 ：GP_UpdateRow '* 機能 ：一覧行の更新 '--------------------------------------------------------------------------------------------------- '* 返り値 ：(なし) '* 引数 ：Arg1 = 行INDEX(Long) '* Arg2 = 社員コード(String) '--------------------------------------------------------------------------------------------------- '* 作成日 ：2016年12月31日 '* 作成者 ：井上 治 '* 更新日 ：2016年12月31日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項： '*************************************************************************************************** Private Sub GP_UpdateRow(ByVal lngRow As Long, ByVal strScd As String) '----------------------------------------------------------------------------------------------- Dim dbCon As ADODB.Connection ' ADODB.Connection Dim dbRes As ADODB.Recordset ' ADODB.Recordset Dim strSQL As String ' SQL文編集WORK '----------------------------------------------------------------------------------------------- ' データベースへの接続 If Not FP_GetSqlConnection(dbCon) Then Exit Sub '----------------------------------------------------------------------------------------------- ' 参照SQL文の編集・発行 strSQL = FP_GetSqlCommon strSQL = strSQL & " WHERE H.[SCD]='" & strScd & "'" strSQL = strSQL & " ORDER BY H.[KAISHI_YMD] DESC;" ' 参照SQL文の発行 Set dbRes = New ADODB.Recordset dbRes.Open strSQL, dbCon, adOpenKeyset, adLockReadOnly '----------------------------------------------------------------------------------------------- ' 一覧シート1行分の編集 Call GP_SetSheetRow(Me, dbRes, lngRow) '----------------------------------------------------------------------------------------------- ' レコードセット、データベースを閉じる dbRes.Close Set dbRes = Nothing dbCon.Close Set dbCon = Nothing ' 保存済み状態にする ThisWorkbook.Saved = True End Sub '------------------------------------------<< End of Source >>--------------------------------------
- 次は「登録変更画面(FRM_HAIZOKU)」です。
-
上記シートの「Worksheet_SelectionChange」イベント内から呼び出される「登録変更画面(FRM_HAIZOKU)」です。
初回表示時は部署コンボリスト、役職コンボリストの生成を行ない、引き渡された社員コードの配属情報を表示させます。
登録ボタンの処理では変更された部署コード、役職コードについて配属マスタ(MST_HAIZOKU)への更新を行ない、呼び出し元へは更新の有無のみ通知します。
部署と役職のコンボリストを作成する処理で、テーブル要素をADODB.RecordsetのRecordCountプロパティで取得しているのですが、 64ビット版OfficeではこのプロパティがLongLong型になっているということで「型不一致エラー」になってしまいました。 「#If Win64 Then」で判断させても良いのですが、そのようなデータ件数にはならないので「CLng」による型変換を追加しています。'*************************************************************************************************** ' ADOでAccessデータベースを更新する FRM_HAIZOKU(UserForm) ' ' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!] '*************************************************************************************************** ' [参照設定] ' ・Microsoft Active Data Object 2.x Library(2.8 or Later) '*************************************************************************************************** ' 変更日付 Rev 変更履歴内容----------------------------------------------------------------------> ' 16/12/31(1.0.0)新規作成 ' 19/11/24(1.1.0)64ビット版OfficeのdbRes.RecordCountの｢型不一致エラー｣対応⇒LongLong型 '*************************************************************************************************** Option Explicit '=================================================================================================== ' 共通定数 Private Const g_cnsTitle As String = "配属情報の登録・変更" '--------------------------------------------------------------------------------------------------- ' 状態制御 Private g_blnFirstShown As Boolean ' 初回表示判定 '--------------------------------------------------------------------------------------------------- ' 受け渡し変数 Private g_strScd As String ' 社員コード Private g_blnReturnValue As Boolean ' 処理結果 '--------------------------------------------------------------------------------------------------- ' 読み出し時点の各コード退避 Private g_strPrevBusyoCd As String ' 部署コード Private g_strPrevYakuCd As String ' 役職コード '--------------------------------------------------------------------------------------------------- ' コンボリストに対応したコードテーブル Private g_tblBusyoCd() As String ' 部署コードテーブル Private g_tblYakuCd() As String ' 役職コードテーブル '*************************************************************************************************** ' ■■■ フォームイベント ■■■ '*************************************************************************************************** '* 処理名 ：UserForm_Activate '* 機能 ：フォーム初期表示 '--------------------------------------------------------------------------------------------------- '* 返り値 ：(なし) '* 引数 ：(なし) '--------------------------------------------------------------------------------------------------- '* 作成日 ：2016年12月31日 '* 作成者 ：井上 治 '* 更新日 ：2016年12月31日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項： '*************************************************************************************************** Private Sub UserForm_Activate() '----------------------------------------------------------------------------------------------- Dim dbCon As ADODB.Connection ' ADODB.Connection g_blnReturnValue = False ' 登録ボタンは不活性にする BTN_OK.Enabled = False ' データベースへの接続 If Not FP_GetSqlConnection(dbCon) Then Me.Hide Exit Sub End If ' 初回表示の場合はコンボ設定を行なう If g_blnFirstShown Then ' 部署コンボの初期登録 Call GP_SetBusyoCombo(dbCon) ' 役職コンボの初期登録 Call GP_SetYakuCombo(dbCon) g_blnFirstShown = False End If '----------------------------------------------------------------------------------------------- ' 対象者配属情報の表示 Call GP_SetHaizokuInfo(dbCon) ' データベース接続を閉じる dbCon.Close Set dbCon = Nothing ' 登録ボタンは活性にする BTN_OK.Enabled = True End Sub '*************************************************************************************************** '* 処理名 ：UserForm_Initialize '* 機能 ：フォーム初期化 '--------------------------------------------------------------------------------------------------- '* 返り値 ：(なし) '* 引数 ：(なし) '--------------------------------------------------------------------------------------------------- '* 作成日 ：2016年12月31日 '* 作成者 ：井上 治 '* 更新日 ：2016年12月31日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項： '*************************************************************************************************** Private Sub UserForm_Initialize() '----------------------------------------------------------------------------------------------- g_blnFirstShown = True End Sub '*************************************************************************************************** '* 処理名 ：UserForm_QueryClose '* 機能 ：フォーム閉鎖動作 '--------------------------------------------------------------------------------------------------- '* 返り値 ：(なし) '* 引数 ：(既定) '--------------------------------------------------------------------------------------------------- '* 作成日 ：2016年12月31日 '* 作成者 ：井上 治 '* 更新日 ：2016年12月31日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項： '*************************************************************************************************** Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) '----------------------------------------------------------------------------------------------- ' ユーザー操作で閉じられる時はHideに切替え If CloseMode = vbFormControlMenu Then g_blnReturnValue = False Cancel = True Me.Hide End If End Sub '*************************************************************************************************** ' ■■■ コントロールイベント ■■■ '*************************************************************************************************** '* 処理名 ：BTN_OK_Click '* 機能 ：｢登録｣ボタンイベント(Click) '--------------------------------------------------------------------------------------------------- '* 返り値 ：(なし) '* 引数 ：(なし) '--------------------------------------------------------------------------------------------------- '* 作成日 ：2016年12月31日 '* 作成者 ：井上 治 '* 更新日 ：2016年12月31日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項： '*************************************************************************************************** Private Sub BTN_OK_Click() '----------------------------------------------------------------------------------------------- Dim dbCon As ADODB.Connection ' ADODB.Connection Dim dbCmd As ADODB.Command ' ADODB.Command Dim strBusyoCd As String ' 選択部署コード Dim strYakuCd As String ' 選択役職コード Dim strSQL As String ' SQL文編集WORK Dim blnUpdate As Boolean ' フォーム登録内容チェック If Not FP_CheckForm(strBusyoCd, strYakuCd) Then Exit Sub '----------------------------------------------------------------------------------------------- ' データベースへの接続 If Not FP_GetSqlConnection(dbCon) Then Me.Hide Exit Sub End If ' 更新SQL文の編集 strSQL = "UPDATE MST_HAIZOKU SET " ' 部署コードに変異があるか If strBusyoCd <> g_strPrevBusyoCd Then blnUpdate = True strSQL = strSQL & "BUSYO_CD='" & strBusyoCd & "'" End If ' 役職コードに変異があるか If strYakuCd <> g_strPrevYakuCd Then If blnUpdate Then strSQL = strSQL & "," End If strSQL = strSQL & "YAKU_CD='" & strYakuCd & "'" End If strSQL = strSQL & " WHERE [SCD]='" & g_strScd & "';" ' コマンド発行 Set dbCmd = New ADODB.Command dbCmd.ActiveConnection = dbCon dbCmd.CommandText = strSQL dbCmd.Execute ' データベース接続を閉じる dbCon.Close Set dbCon = Nothing g_blnReturnValue = True Me.Hide End Sub '*************************************************************************************************** ' ■■■ サブ処理 ■■■ '*************************************************************************************************** '* 処理名 ：FP_CheckForm '* 機能 ：フォーム登録内容チェック '--------------------------------------------------------------------------------------------------- '* 返り値 ：チェック成否(Boolean) '* 引数 ：Arg1 = 選択部署コード(String) '* Arg2 = 選択役職コード(String) '--------------------------------------------------------------------------------------------------- '* 作成日 ：2016年12月31日 '* 作成者 ：井上 治 '* 更新日 ：2016年12月31日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項： '*************************************************************************************************** Private Function FP_CheckForm(ByRef strBusyoCd As String, ByRef strYakuCd As String) As Boolean '----------------------------------------------------------------------------------------------- Dim strMSG As String ' メッセージ ' 部署コンボ If CBO_BUSYO.ListIndex < 0 Then Call GP_AppendMessage(strMSG, "「部署」が選択されていません。") Else ' 選択された部署コードを得る strBusyoCd = g_tblBusyoCd(CBO_BUSYO.ListIndex) End If ' 役職コンボ If CBO_YAKU.ListIndex < 0 Then Call GP_AppendMessage(strMSG, "「役職」が選択されていません。") Else ' 選択された役職コードを得る strYakuCd = g_tblYakuCd(CBO_YAKU.ListIndex) End If ' 変更あるか If ((strBusyoCd = g_strPrevBusyoCd) And (strYakuCd = g_strPrevYakuCd)) Then Call GP_AppendMessage(strMSG, "何も変更されていません。") End If '----------------------------------------------------------------------------------------------- If strMSG = "" Then FP_CheckForm = True Else MsgBox strMSG, vbExclamation, g_cnsTitle FP_CheckForm = False End If End Function '*************************************************************************************************** '* 処理名 ：GP_SetBusyoCombo '* 機能 ：部署コンボの初期登録 '--------------------------------------------------------------------------------------------------- '* 返り値 ：(なし) '* 引数 ：Arg1 = ADODB.Connection(Object) '--------------------------------------------------------------------------------------------------- '* 作成日 ：2016年12月31日 '* 作成者 ：井上 治 '* 更新日 ：2019年11月24日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項： '*************************************************************************************************** Private Sub GP_SetBusyoCombo(ByRef dbCon As ADODB.Connection) '----------------------------------------------------------------------------------------------- Dim dbRes As ADODB.Recordset ' ADODB.Recordset Dim lngIx As Long ' テーブル用INDEX Dim lngIxMax As Long ' 〃上限 Dim tblRec() As String ' レコードテーブル Dim strSQL As String ' SQL文編集域 ' 参照SQL文の編集 strSQL = "SELECT BUSYO_CD" ' (00)部署コード strSQL = strSQL & ",BUSYO_NM" ' (01)部署名 strSQL = strSQL & " FROM MST_BUSYO" strSQL = strSQL & " ORDER BY BUSYO_CD;" ' 参照SQL文の発行 Set dbRes = New ADODB.Recordset dbRes.Open strSQL, dbCon, adOpenKeyset, adLockReadOnly '----------------------------------------------------------------------------------------------- lngIxMax = CLng(dbRes.RecordCount) - 1 ReDim g_tblBusyoCd(lngIxMax), tblRec(lngIxMax) lngIx = -1 ' 先頭レコードからEOFまで繰り返す Do Until dbRes.EOF lngIx = lngIx + 1 g_tblBusyoCd(lngIx) = dbRes.Fields(0).Value tblRec(lngIx) = dbRes.Fields(0).Value & " " & dbRes.Fields(1).Value ' 次のレコードに移る dbRes.MoveNext Loop ' レコードセットを閉じる dbRes.Close Set dbRes = Nothing '----------------------------------------------------------------------------------------------- ' コンボに登録 CBO_BUSYO.List() = tblRec End Sub '*************************************************************************************************** '* 処理名 ：GP_SetYakuCombo '* 機能 ：役職コンボの初期登録 '--------------------------------------------------------------------------------------------------- '* 返り値 ：(なし) '* 引数 ：Arg1 = ADODB.Connection(Object) '--------------------------------------------------------------------------------------------------- '* 作成日 ：2016年12月31日 '* 作成者 ：井上 治 '* 更新日 ：2019年11月24日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項： '*************************************************************************************************** Private Sub GP_SetYakuCombo(ByRef dbCon As ADODB.Connection) '----------------------------------------------------------------------------------------------- Dim dbRes As ADODB.Recordset ' ADODB.Recordset Dim lngIx As Long ' テーブル用INDEX Dim lngIxMax As Long ' 〃上限 Dim tblRec() As String ' レコードテーブル Dim strSQL As String ' SQL文編集域 ' 参照SQL文の編集 strSQL = "SELECT YAKU_CD" ' (00)部署コード strSQL = strSQL & ",YAKU_NM" ' (01)部署名 strSQL = strSQL & " FROM MST_YAKU" strSQL = strSQL & " ORDER BY YAKU_CD;" ' 参照SQL文の発行 Set dbRes = New ADODB.Recordset dbRes.Open strSQL, dbCon, adOpenKeyset, adLockReadOnly '----------------------------------------------------------------------------------------------- lngIxMax = CLng(dbRes.RecordCount) - 1 ReDim g_tblYakuCd(lngIxMax), tblRec(lngIxMax) lngIx = -1 ' 先頭レコードからEOFまで繰り返す Do Until dbRes.EOF lngIx = lngIx + 1 g_tblYakuCd(lngIx) = dbRes.Fields(0).Value tblRec(lngIx) = dbRes.Fields(0).Value & " " & dbRes.Fields(1).Value ' 次のレコードに移る dbRes.MoveNext Loop ' レコードセットを閉じる dbRes.Close Set dbRes = Nothing '----------------------------------------------------------------------------------------------- ' コンボに登録 CBO_YAKU.List() = tblRec End Sub '*************************************************************************************************** '* 処理名 ：GP_SetHaizokuInfo '* 機能 ：対象者配属情報の表示 '--------------------------------------------------------------------------------------------------- '* 返り値 ：(なし) '* 引数 ：Arg1 = ADODB.Connection(Object) '--------------------------------------------------------------------------------------------------- '* 作成日 ：2016年12月31日 '* 作成者 ：井上 治 '* 更新日 ：2016年12月31日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項：このサンプルでは異動に関する考慮はしていません '*************************************************************************************************** Private Sub GP_SetHaizokuInfo(ByRef dbCon As ADODB.Connection) '----------------------------------------------------------------------------------------------- Dim dbRes As ADODB.Recordset ' ADODB.Recordset Dim strSQL As String ' SQL文編集域 ' 参照SQL文の編集 strSQL = FP_GetSqlCommon strSQL = strSQL & " WHERE H.[SCD]='" & g_strScd & "'" strSQL = strSQL & " ORDER BY S.[NYUSYA_YMD] DESC;" ' 参照SQL文の発行 Set dbRes = New ADODB.Recordset dbRes.Open strSQL, dbCon, adOpenKeyset, adLockReadOnly ' フォーム上に配置 TXT_SCD.Text = g_strScd TXT_SNAME.Text = dbRes.Fields(1).Value TXT_NYUSYA_YMD.Text = dbRes.Fields(7).Value TXT_KAISHI_YMD.Text = dbRes.Fields(9).Value g_strPrevBusyoCd = dbRes.Fields(2).Value g_strPrevYakuCd = dbRes.Fields(4).Value CBO_BUSYO.ListIndex = FP_GetListIndex(g_strPrevBusyoCd, g_tblBusyoCd) CBO_YAKU.ListIndex = FP_GetListIndex(g_strPrevYakuCd, g_tblYakuCd) ' レコードセットを閉じる dbRes.Close Set dbRes = Nothing End Sub '*************************************************************************************************** '* 処理名 ：FP_GetListIndex '* 機能 ：コードテーブルから該当INDEXを取得 '--------------------------------------------------------------------------------------------------- '* 返り値 ：(なし) '* 引数 ：Arg1 = 対象コード(String) '* Arg2 = コードテーブル(Array:String) '--------------------------------------------------------------------------------------------------- '* 作成日 ：2016年12月31日 '* 作成者 ：井上 治 '* 更新日 ：2016年12月31日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項：このサンプルでは異動に関する考慮はしていません '*************************************************************************************************** Private Function FP_GetListIndex(ByVal strCode As String, ByRef tblCode() As String) As Long '----------------------------------------------------------------------------------------------- Dim lngIx As Long ' テーブル用INDEX FP_GetListIndex = -1 Do While lngIx <= UBound(tblCode) If tblCode(lngIx) = strCode Then FP_GetListIndex = lngIx Exit Do End If ' 次へ lngIx = lngIx + 1 Loop End Function '*************************************************************************************************** ' ■■■ プロパティ ■■■ '*************************************************************************************************** ' 社員コード(String) '--------------------------------------------------------------------------------------------------- Public Property Let prpScd(ByVal Value As String) g_strScd = Value End Property '=================================================================================================== ' 処理結果(Boolean) '--------------------------------------------------------------------------------------------------- Public Property Get prpReturnValue() As Boolean prpReturnValue = g_blnReturnValue End Property '------------------------------------------<< End of Source >>--------------------------------------
- 最後は共通関数等を収容するモジュール(ADO_Module4)です。
-
ここには複数箇所で共用される関数などが収容されていますが、特に重要なのは「データベースへの接続(FP_GetSqlConnection)」です。
データベースへの接続は必要の都度行ない、データ授受が完了したらすぐに切断させるため、数カ所から呼び出されます。 古くは開いた時点で接続し、閉じる段階で切断するような方法でレスポンスを維持させる対応を行なっていたようですが、現在の推奨はこのように都度接続・切断になっています。 この方法でもADO側の「接続プール」に実際の接続は安全な形で保持されているのでレスポンスは悪化しません。
'*************************************************************************************************** ' ADOでAccessデータベースを更新する ADO_Module4(Module) ' ' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!] '*************************************************************************************************** ' [参照設定] ' ・Microsoft Scripting Runtime ' ・Windows Script Host Object Model ' ・Microsoft Active Data Objects 2.x Library '*************************************************************************************************** ' 変更日付 Rev 変更履歴内容----------------------------------------------------------------------> ' 16/12/31(1.0.0)新規作成 ' 19/11/24(1.1.0)MDB/ACCDB兼用版として再作成 '*************************************************************************************************** Option Explicit '=================================================================================================== Private Const g_cnsFilter = "MDB(ACCDB)ファイル (*.mdb;*.accdb),*.mdb;*.accdb" Private Const g_cnsADO_Connect1 = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=""" '*************************************************************************************************** ' ■■■ 共通サブ処理 ■■■ '*************************************************************************************************** '* 処理名 ：FP_GetSqlConnection '* 機能 ：データベースへの接続 '--------------------------------------------------------------------------------------------------- '* 返り値 ：処理成否(Boolean) '* 引数 ：Arg1 = ADODB.Connection(Object) '--------------------------------------------------------------------------------------------------- '* 作成日 ：2016年12月31日 '* 作成者 ：井上 治 '* 更新日 ：2019年11月24日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項： '*************************************************************************************************** Public Function FP_GetSqlConnection(ByRef dbCon As ADODB.Connection) As Boolean '----------------------------------------------------------------------------------------------- Dim objFso As FileSystemObject ' FileSystemObject Dim objWsh As WshShell ' WshShell Dim objSh As Worksheet ' Worksheet Dim vntFilename As Variant ' ファイル名(受取) Dim strFilename As String ' フルパスファイル名 Dim strConnection As String ' 接続文字列 Dim strCurrentPathSV As String ' カレントフォルダ(退避) FP_GetSqlConnection = False '----------------------------------------------------------------------------------------------- Set objSh = ThisWorkbook.Worksheets(1) ' J1セルにMDB(ACCDB)ファイル名があるか strFilename = Trim(objSh.Cells(1, 10).Value) ' ファイルが実在するか If strFilename <> "" Then Set objFso = New FileSystemObject ' 実在しなければファイル名を消去 If Not objFso.FileExists(strFilename) Then strFilename = "" Set objFso = Nothing End If ' ファイル名未登録か If strFilename = "" Then ' MDB(ACCDB)ファイル名の受け取り Set objWsh = New WshShell ' 一旦、カレントフォルダを退避 strCurrentPathSV = objWsh.CurrentDirectory ' 本ブックのフォルダをカレントフォルダに設定 objWsh.CurrentDirectory = ThisWorkbook.Path ' ｢開く｣ダイアログでファイル名の受け取り vntFilename = Application.GetOpenFilename(g_cnsFilter, , _ "配属データを参照するMDB(ACCDB)ファイルを指定して下さい。") ' カレントフォルダの復旧 objWsh.CurrentDirectory = strCurrentPathSV Set objWsh = Nothing ' キャンセル確認 If VarType(vntFilename) = vbBoolean Then Exit Function strFilename = vntFilename objSh.Cells(1, 10).Value = strFilename End If ' 接続文字列の編集 strConnection = g_cnsADO_Connect1 & strFilename & """;" '----------------------------------------------------------------------------------------------- On Error Resume Next ' 接続を確立する Set dbCon = New ADODB.Connection dbCon.Open strConnection ' クライアントカーソル設定(MDBでは関係ないかも) dbCon.CursorLocation = adUseClient ' 処理成否判定 If Err.Number = 0 Then FP_GetSqlConnection = True Else MsgBox Err.Description, vbCritical, "データベースへの接続" FP_GetSqlConnection = False End If On Error GoTo 0 End Function '*************************************************************************************************** '* 処理名 ：FP_GetSqlCommon '* 機能 ：一覧参照用SQL文共通部編集 '--------------------------------------------------------------------------------------------------- '* 返り値 ：一覧参照用SQL文共通部(String) '* 引数 ：(なし) '--------------------------------------------------------------------------------------------------- '* 作成日 ：2016年12月31日 '* 作成者 ：井上 治 '* 更新日 ：2016年12月31日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項： '*************************************************************************************************** Public Function FP_GetSqlCommon() As String '----------------------------------------------------------------------------------------------- Dim strSQL As String ' SQL文編集WORK strSQL = "SELECT H.[SCD]" ' (00)社員コード strSQL = strSQL & ",S.[KANJI_SEI]+S.[KANJI_MEI]" ' (01)氏名(漢字) strSQL = strSQL & ",H.[BUSYO_CD]" ' (02)部署コード strSQL = strSQL & ",B.[BUSYO_NM]" ' (03)部署名 strSQL = strSQL & ",H.[YAKU_CD]" ' (04)役職コード strSQL = strSQL & ",Y.[YAKU_NM]" ' (05)役職名 strSQL = strSQL & ",S.[KANA_SEI]+S.[KANA_MEI]" ' (06)氏名(カナ) strSQL = strSQL & ",S.[NYUSYA_YMD]" ' (07)入社日 strSQL = strSQL & ",S.[TAISYOKU_YMD]" ' (08)退職日 strSQL = strSQL & ",H.[KAISHI_YMD]" ' (09)開始日 strSQL = strSQL & " FROM ((([MST_HAIZOKU] AS H" strSQL = strSQL & " INNER JOIN [MST_SYAIN] AS S ON H.[SCD]=S.[SCD])" strSQL = strSQL & " LEFT OUTER JOIN [MST_BUSYO] AS B ON H.[BUSYO_CD]=B.[BUSYO_CD])" strSQL = strSQL & " LEFT OUTER JOIN [MST_YAKU] AS Y ON H.[YAKU_CD]=Y.[YAKU_CD])" FP_GetSqlCommon = strSQL End Function '*************************************************************************************************** '* 処理名 ：GP_ClearSheet '* 機能 ：シート初期化 '--------------------------------------------------------------------------------------------------- '* 返り値 ：(なし) '* 引数 ：Arg1 = Excel.Worksheet(Object) '--------------------------------------------------------------------------------------------------- '* 作成日 ：2016年12月31日 '* 作成者 ：井上 治 '* 更新日 ：2016年12月31日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項： '*************************************************************************************************** Public Sub GP_ClearSheet(ByRef objSh As Worksheet) '----------------------------------------------------------------------------------------------- With objSh If .FilterMode Then .ShowAllData .Rows("2:" & .Rows.Count).ClearContents End With End Sub '*************************************************************************************************** '* 処理名 ：GP_SetSheetRow '* 機能 ：一覧シート1行分の編集 '--------------------------------------------------------------------------------------------------- '* 返り値 ：(なし) '* 引数 ：Arg1 = Excel.Worksheet(Object) '* Arg2 = ADODB.Recordset(Object) '* Arg3 = 現在行(Long) '--------------------------------------------------------------------------------------------------- '* 作成日 ：2016年12月31日 '* 作成者 ：井上 治 '* 更新日 ：2016年12月31日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項： '*************************************************************************************************** Public Sub GP_SetSheetRow(ByRef objSh As Worksheet, _ ByRef dbRes As ADODB.Recordset, _ ByVal lngRow As Long) '----------------------------------------------------------------------------------------------- Dim lngCol As Long ' 列INDEX ' 全列をシートに展開 For lngCol = 0 To 8 objSh.Cells(lngRow, lngCol + 1).Value = dbRes.Fields(lngCol).Value Next lngCol End Sub '*************************************************************************************************** '* 処理名 ：GP_StopSCUPD '* 機能 ：画面描画更新停止 '--------------------------------------------------------------------------------------------------- '* 返り値 ：(なし) '* 引数 ：(なし) '--------------------------------------------------------------------------------------------------- '* 作成日 ：2016年12月31日 '* 作成者 ：井上 治 '* 更新日 ：2016年12月31日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項： '*************************************************************************************************** Public Sub GP_StopSCUPD() '----------------------------------------------------------------------------------------------- With Application .ScreenUpdating = False ' .EnableCancelKey = xlDisabled .Calculation = xlCalculationManual ' .Interactive = False ' .Cursor = xlWait .EnableEvents = False End With End Sub '*************************************************************************************************** '* 処理名 ：GP_StartSCUPD '* 機能 ：画面描画更新復帰 '--------------------------------------------------------------------------------------------------- '* 返り値 ：(なし) '* 引数 ：(なし) '--------------------------------------------------------------------------------------------------- '* 作成日 ：2016年12月31日 '* 作成者 ：井上 治 '* 更新日 ：2016年12月31日 '* 更新者 ：井上 治 '* 機能説明： '* 注意事項： '*************************************************************************************************** Public Sub GP_StartSCUPD() '----------------------------------------------------------------------------------------------- With Application If .Calculation <> xlCalculationAutomatic Then .Calculation = xlCalculationAutomatic End If .Cursor = xlDefault .EnableCancelKey = xlInterrupt .EnableEvents = True .Interactive = True .StatusBar = False .ScreenUpdating = True End With End Sub '*************************************************************************************************** '* 処理名 ：GP_AppendMessage '* 機能 ：エラーメッセージ累積 '--------------------------------------------------------------------------------------------------- '* 返り値 ：(なし) '* 引数 ：Arg1 = 表示用累積メッセージ(String) '* Arg2 = 今回追加メッセージ(String) '--------------------------------------------------------------------------------------------------- '* 作成日 ：2016年12月31日 '* 作成者 ：井上 治 '* 更新日 ：2016年12月31日 '* 更新者 ：井上 治 '* 機能説明：改行を加えながらメッセージを追加する '* 注意事項： '*************************************************************************************************** Public Sub GP_AppendMessage(ByRef strMSG As String, ByRef strADDMSG As String) '----------------------------------------------------------------------------------------------- If strMSG <> "" Then strMSG = strMSG & vbCrLf strMSG = strMSG & strADDMSG End Sub '------------------------------------------<< End of Source >>--------------------------------------
Accessを持たない環境でMDB(ACCDB)を使いたい方へ
以下のようなツールをご用意していますので、合わせてご利用下さい。
・「MDB(ACCDB)生成／テーブル定義取得ツール」
⇒ワークシート上に登録したテーブル定義内容で実際にMDB（データベース）ファイルを作成したり、
現存するMDB（データベース）ファイルの定義内容を取得するツールです。
・「MDB(ACCDB)データ取得ツール」
⇒SQL文の検証や、データの調査・修正を行なうツールです。
・「MDB(ACCDB)生成／テーブル定義取得ツール」
⇒ワークシート上に登録したテーブル定義内容で実際にMDB（データベース）ファイルを作成したり、
現存するMDB（データベース）ファイルの定義内容を取得するツールです。
・「MDB(ACCDB)データ取得ツール」
⇒SQL文の検証や、データの調査・修正を行なうツールです。