'***************************************************************************************************
' 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 >>--------------------------------------
'***************************************************************************************************
' 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 >>--------------------------------------
'***************************************************************************************************
' 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で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 >>--------------------------------------