'***************************************************************************************************
' MDB(ACCDB)データ取得ツール
'
' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
' 変更日付 Rev 変更履歴内容---------------------------------------------------------------------->
' 06/02/24(1.0.0)新規作成
'***************************************************************************************************
Option Explicit
'***************************************************************************************************
' ■■■ 起動プロシージャ ■■■
'***************************************************************************************************
'* 処理名 :TEST
'* 機能 :テスト用起動プロシージャ
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2006年02月24日
'* 作成者 :井上 治
'* 更新日 :2006年02月24日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Sub TEST()
'-----------------------------------------------------------------------------------------------
FRM_SQL.Show
End Sub
'------------------------------------------<< End of Source >>--------------------------------------
'***************************************************************************************************
' MDB(ACCDB)データ取得ツール(処理フォーム)
'
' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
' [参照設定]
' ・Microsoft ActiveX Data Objects 2.x Library
' ・Microsoft Scripting Runtime
' ・Windows Script Host Object Model
'***************************************************************************************************
' 変更日付 Rev 変更履歴内容---------------------------------------------------------------------->
' 06/02/24(1.0.0)新規作成
' 17/03/09(1.1.0)ACCDB対応による機能追加、記述整理
' 17/03/10(1.1.0)コマンド処理に対する処理結果(件数)表示の改善、投入SQL文の保持機能を追加
' 19/11/24(1.2.0)接続文字列を「ACE.OLEDB.12.0」に一元化、ドラッグ&ドロップ対応を追加
'***************************************************************************************************
Option Explicit
'---------------------------------------------------------------------------------------------------
Const cnsADO_CONNECT = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="""
Const cnsMDBFileNameIni = "MDBFileName.Ini"
Private g_strMDBName As String ' 既定MDB名
Private g_strMDBPath As String ' 既定フォルダ
#If VBA7 Then
' ウィンドウハンドルを返す
Private Declare PtrSafe Function FindWindow Lib "USER32.dll" Alias "FindWindowA" _
(ByVal lpClassName As Any, ByVal lpWindowName As Any) As LongPtr
#Else
' ウィンドウハンドルを返す
Private Declare Function FindWindow Lib "USER32.dll" Alias "FindWindowA" _
(ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long
#End If
'***************************************************************************************************
' ■■■ フォームイベント ■■■
'***************************************************************************************************
'* 処理名 :UserForm_Initialize
'* 機能 :フォーム初期化
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2017年03月10日
'* 作成者 :井上 治
'* 更新日 :2019年11月24日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub UserForm_Activate()
'-----------------------------------------------------------------------------------------------
LBL_RESULT.Caption = ""
modDragFiles.g_lngHwnd = FindWindow("ThunderDFrame", Me.Caption)
' サブクラス開始
Call modDragFiles.GP_StartSubClass(Me)
End Sub
'***************************************************************************************************
'* 処理名 :UserForm_Initialize
'* 機能 :フォーム初期化
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2006年02月24日
'* 作成者 :井上 治
'* 更新日 :2017年03月10日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub UserForm_Initialize()
'-----------------------------------------------------------------------------------------------
Dim objFso As FileSystemObject ' FileSystemObject
Dim objTs As TextStream ' TextStream
Dim strFilename As String ' ファイル名
Dim strSQL As String ' SQL文
'-----------------------------------------------------------------------------------------------
' iniファイルより設定(MDBファイル名)を取得
Set objFso = New FileSystemObject
strFilename = FP_GetIniFilename(objFso)
' ファイルがあるか
If objFso.FileExists(strFilename) Then
Set objTs = objFso.OpenTextFile(strFilename, ForReading)
' レコードがあるか
If Not objTs.AtEndOfStream Then
g_strMDBName = objTs.ReadLine
End If
objTs.Close
Set objTs = Nothing
' 実在するか
If objFso.FileExists(g_strMDBName) Then
TXT_MDB.Text = g_strMDBName
g_strMDBPath = objFso.GetFile(g_strMDBName).ParentFolder.Path
Else
g_strMDBName = ""
End If
ElseIf ActiveSheet.PageSetup.LeftFooter <> "" Then
' 左フッタから直前のMDBファイル名を取得
TXT_MDB.Text = ActiveSheet.PageSetup.LeftFooter
End If
Set objFso = Nothing
'-----------------------------------------------------------------------------------------------
' SQL文が保持されているか(SQLSheet)
strSQL = Worksheets("SQLSheet").Range("$A$1").Value
' 保持されていれば再表示
If strSQL <> "" Then
TXT_SQL.Text = strSQL
End If
End Sub
'***************************************************************************************************
'* 処理名 :UserForm_Terminate
'* 機能 :フォーム終了イベント
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2019年11月24日
'* 作成者 :井上 治
'* 更新日 :2019年11月24日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub UserForm_Terminate()
'-----------------------------------------------------------------------------------------------
' サブクラス終了
Call modDragFiles.GP_EndSubClass(0)
End Sub
'***************************************************************************************************
' ■■■ コントロールイベント ■■■
'***************************************************************************************************
'* 処理名 :CMD_MDB_Click
'* 機能 :「MDBファイル名」の「参照」ボタンClickイベント
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2006年02月24日
'* 作成者 :井上 治
'* 更新日 :2017年03月09日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub CMD_MDB_Click()
'-----------------------------------------------------------------------------------------------
Dim objWsh As WshShell ' WshShell
Dim strCurrentPathSV As String ' カレントフォルダ退避
Dim vntFilename As Variant ' ファイル名受け取りWORK
Set objWsh = New WshShell
' カレントフォルダ退避
On Error Resume Next
strCurrentPathSV = objWsh.CurrentDirectory
On Error GoTo 0
' 設定フォルダに移動
If g_strMDBPath <> "" And g_strMDBPath <> strCurrentPathSV Then
objWsh.CurrentDirectory = g_strMDBPath
End If
' ファイル名の受け取り
vntFilename = Application.GetOpenFilename( _
"Accessデータベース (*.mdb;*.mde;*.accdb),*.mdb;*.mde;*.accdb", , _
"Accessデータベースの指定")
' カレントフォルダ復旧
If strCurrentPathSV <> "" And strCurrentPathSV <> objWsh.CurrentDirectory Then
objWsh.CurrentDirectory = strCurrentPathSV
End If
Set objWsh = Nothing
' キャンセル処置
If VarType(vntFilename) = vbBoolean Then Exit Sub
TXT_MDB.Text = vntFilename
End Sub
'***************************************************************************************************
'* 処理名 :CMD_OK_Click
'* 機能 :「SQL発行」ボタンClickイベント
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2006年02月24日
'* 作成者 :井上 治
'* 更新日 :2017年03月10日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub CMD_OK_Click()
'-----------------------------------------------------------------------------------------------
Dim strMDBName As String ' MDBファイル名
Dim strSQL As String ' SQL文
Dim dbCon As ADODB.Connection ' ADODB.Connection
Dim dbRes As ADODB.Recordset ' ADODB.Recordset
Dim dbCmd As ADODB.Command ' ADODB.Command
Dim objFso As FileSystemObject ' FileSystemObject
Dim objTs As TextStream ' TextStream
Dim objSh As Worksheet ' Worksheet
Dim strFilename As String ' ファイル名
Dim COL As Long ' カラムINDEX
Dim lngIx As Long ' テーブルINDEX
Dim lngDate As Long, dteDate As Date ' 日付WORK
'-----------------------------------------------------------------------------------------------
LBL_RESULT.Caption = ""
' 入力内容チェック
If Not FP_CheckForm(dbCon, strMDBName, strSQL) Then Exit Sub
'-----------------------------------------------------------------------------------------------
' SQL文のコマンドにより処理を判断
On Error GoTo OK_Click_SQLERR
' SELECTで始まっていないか
If StrConv(Left(strSQL, 6), vbUpperCase) <> "SELECT" Then
' コマンド処理
Set dbCmd = New ADODB.Command
dbCmd.ActiveConnection = dbCon
dbCmd.CommandText = strSQL
dbCmd.Execute lngIx, , adCmdText
Set dbCmd = Nothing
LBL_RESULT.Caption = CStr(lngIx) & "件更新しました。"
On Error GoTo 0
dbCon.Close
Set dbCon = Nothing
Exit Sub
End If
'-----------------------------------------------------------------------------------------------
' SELECT文の場合はレコードセットの取得
Set dbRes = New ADODB.Recordset
dbRes.Open strSQL, dbCon, adOpenKeyset, adLockReadOnly
On Error GoTo 0
' レコード無し
If dbRes.EOF Then
LBL_RESULT.Caption = "※表示対象の有効データがありません。"
dbRes.Close
Set dbRes = Nothing
dbCon.Close
Set dbCon = Nothing
Exit Sub
End If
' 画面描画・イベント・自動計算停止
Call GP_StopUpdScreen
'-----------------------------------------------------------------------------------------------
' シートに展開
Set objSh = ActiveSheet
With objSh
.Cells.ClearContents
' 見出し作成
For COL = 1 To dbRes.Fields.Count
lngIx = COL - 1
' 見出し名
.Cells(1, COL).Value = dbRes.Fields(lngIx).Name
' Typeによりカラムの書式を変更
With .Columns(COL)
Select Case dbRes.Fields(lngIx).Type
Case 2, 3, 17, 20, 131 ' 数値(整数)
.NumberFormatLocal = "#,##0;[赤]-#,##0"
.HorizontalAlignment = xlHAlignRight
Case 4, 5, 6, 14 ' 数値(実数、通貨)
.NumberFormatLocal = "#,##0.000;[赤]-#,##0.000"
.HorizontalAlignment = xlHAlignRight
Case 7 ' 日付
' 先頭行の状態で見分ける
If IsDate(dbRes.Fields(lngIx).Value) Then
dteDate = dbRes.Fields(lngIx).Value
lngDate = CLng(dteDate)
If lngDate <> dteDate Then
.NumberFormatLocal = "yyyy/mm/dd hh:mm"
Else
.NumberFormatLocal = "yyyy/mm/dd"
End If
Else
.NumberFormatLocal = "yyyy/mm/dd"
End If
.HorizontalAlignment = xlHAlignCenter
Case Else ' その他(文字扱い)
.NumberFormatLocal = "@"
.HorizontalAlignment = xlHAlignLeft
End Select
End With
Next COL
' レコードセットからまとめて転記する
.Range("A2").CopyFromRecordset dbRes
' 画面スクロール位置を左上端に戻す
ActiveWindow.ScrollRow = 2
ActiveWindow.ScrollColumn = 1
.Range("A2").Select
' オートフィルタの再設定
If .AutoFilterMode = True Then
.AutoFilterMode = False
End If
.Range(.Cells(1, 1), .Cells(1, COL - 1)).AutoFilter
' カラム幅の自動設定
.Columns.AutoFit
' 左フッタにMDB名を登録
.PageSetup.LeftFooter = strMDBName
End With
dbRes.Close
Set dbRes = Nothing
dbCon.Close
Set dbCon = Nothing
' SQL文を保持
Worksheets("SQLSheet").Range("$A$1").Value = strSQL
'-----------------------------------------------------------------------------------------------
If strMDBName <> g_strMDBName Then
' iniファイルにMDB設定(ファイル名)を書き込み
Set objFso = New FileSystemObject
strFilename = FP_GetIniFilename(objFso)
' フォルダが特定できている場合は出力(テンプレート対応)
If strFilename <> cnsMDBFileNameIni Then
Set objTs = objFso.CreateTextFile(strFilename, True)
objTs.WriteLine strMDBName
objTs.Close
Set objTs = Nothing
End If
Set objFso = Nothing
g_strMDBName = strMDBName
End If
' 画面描画・イベント・自動計算再開
Call GP_StartUpdScreen
' フォームを消去
Unload Me
' 参照ツールなのでブックは非保存化
ThisWorkbook.Saved = True
Exit Sub
'===================================================================================================
' SQL投入エラー処理
OK_Click_SQLERR:
LBL_RESULT.Caption = Err.Description
Err.Clear
On Error Resume Next
Set dbRes = Nothing
dbCon.Close
Set dbCon = Nothing
' 画面描画・イベント・自動計算再開
Call GP_StartUpdScreen
End Sub
'***************************************************************************************************
' ■■■ サブ処理 ■■■
'***************************************************************************************************
'* 処理名 :FP_CheckForm
'* 機能 :入力内容チェック
'---------------------------------------------------------------------------------------------------
'* 返り値 :チェック成否(Boolean)
'* 引数 :Arg1 = ADODB.Connection(Object) ※戻り値
'* Arg2 = MDBファイル名(String) ※戻り値
'* Arg3 = 入力SQL文(String) ※戻り値
'---------------------------------------------------------------------------------------------------
'* 作成日 :2017年03月09日
'* 作成者 :井上 治
'* 更新日 :2019年11月24日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_CheckForm(ByRef dbCon As ADODB.Connection, _
ByRef strMDBName As String, _
ByRef strSQL As String) As Boolean
'-----------------------------------------------------------------------------------------------
Dim objFso As FileSystemObject ' FileSystemObject
Dim strExt As String ' 拡張子
Dim strConnectString As String ' 接続文字列
FP_CheckForm = False
' 未入力チェック
LBL_RESULT.Caption = ""
' MDBファイル名
If Trim(TXT_MDB.Text) = "" Then
LBL_RESULT.Caption = "「MDBファイル名」が指定されていません。"
Exit Function
End If
strMDBName = Trim(TXT_MDB.Text)
Set objFso = New FileSystemObject
' ファイル存在
If Not objFso.FileExists(strMDBName) Then
LBL_RESULT.Caption = "「MDBファイル名」が実在しません。"
Set objFso = Nothing
Exit Function
End If
strExt = UCase(objFso.GetExtensionName(strMDBName))
Set objFso = Nothing
' 拡張子
If ((strExt <> "MDB") And (strExt <> "MDE") And (strExt <> "ACCDB")) Then
LBL_RESULT.Caption = "「MDBファイル名」が形式(拡張子)が違います。"
Exit Function
End If
' SQL文
If Trim(TXT_SQL.Text) = "" Then
LBL_RESULT.Caption = "「SQL」が指定されていません。"
Exit Function
End If
strSQL = Trim(TXT_SQL.Text)
' MDBに接続
On Error Resume Next
Set dbCon = New ADODB.Connection
' 接続文字列を編集し接続
strConnectString = cnsADO_CONNECT & strMDBName & """;"
dbCon.Open strConnectString
' エラーか
If Err.Number <> 0 Then
LBL_RESULT.Caption = "MDBファイルに接続できません。" & vbCrLf & _
Err.Description
Err.Clear
On Error GoTo 0
Set dbCon = Nothing
Exit Function
End If
On Error GoTo 0
FP_CheckForm = True
End Function
'***************************************************************************************************
'* 処理名 :FP_GetIniFilename
'* 機能 :INIファイル名取得
'---------------------------------------------------------------------------------------------------
'* 返り値 :INIファイル名(String)
'* 引数 :Arg1 = FileSystemObject(Object)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2017年03月09日
'* 作成者 :井上 治
'* 更新日 :2017年03月09日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_GetIniFilename(ByRef objFso As FileSystemObject) As String
'-----------------------------------------------------------------------------------------------
Dim intNumber As Integer ' Err.Number
On Error Resume Next
FP_GetIniFilename = objFso.BuildPath(ThisWorkbook.Path, cnsMDBFileNameIni)
intNumber = Err.Number
On Error GoTo 0
' 現在パス取得不成功(テンプレート?)
If intNumber <> 0 Then
Dim objWsh As New WshShell ' WshShell
Set objWsh = New WshShell
FP_GetIniFilename = objFso.BuildPath(objWsh.CurrentDirectory, cnsMDBFileNameIni)
Set objWsh = Nothing
End If
End Function
'***************************************************************************************************
'* 処理名 :GP_StopUpdScreen
'* 機能 :画面描画停止
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2017年03月09日
'* 作成者 :井上 治
'* 更新日 :2017年03月09日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_StopUpdScreen()
'-----------------------------------------------------------------------------------------------
' 画面描画・イベント・自動計算停止
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub
'***************************************************************************************************
'* 処理名 :GP_StartUpdScreen
'* 機能 :画面描画再開
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2017年03月09日
'* 作成者 :井上 治
'* 更新日 :2017年03月09日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_StartUpdScreen()
'-----------------------------------------------------------------------------------------------
' 画面描画・イベント・自動計算再開
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
'***************************************************************************************************
' ■■■ サブ処理 ■■■
'***************************************************************************************************
'* 処理名 :GP_ShowFileList
'* 機能 :ファイル名のリスト表示
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2019年11月24日
'* 作成者 :井上 治
'* 更新日 :2019年11月24日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Friend Sub GP_ShowFileList()
'-----------------------------------------------------------------------------------------------
If g_lngTblEntFileMax >= 0 Then
TXT_MDB.Text = g_tblEntFile(0)
End If
End Sub
'------------------------------------------<< End of Source >>--------------------------------------
![]() |
←GetDataFromMDB1.zip (32KB) |