色んな所で共通して使えそうな処理のサンプルまとめです。
標準モジュールに記載して利用します。
Option Compare Database
Option Explicit
Declare PtrSafe Function ShowWindow Lib "user32" ( _
ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Declare PtrSafe Function SetWindowPos Lib "user32" ( _
ByVal hwnd As LongPtr, _
ByVal hWndInsertAfter As LongPtr, _
ByVal x As Long, _
ByVal y As Long, _
ByVal cx As Long, _
ByVal cy As Long, _
ByVal wFlags As Long) As Long
Public Const HWND_TOPMOST = -1
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOMOVE = &H2
Public Const TWIP As Integer = 567
Public cn As ADODB.Connection
'----------------------------------------------------------------------------
' 外部AccessファイルのADODB.Connectionを作成
'----------------------------------------------------------------------------
Public Function GetDbConn()
On Error GoTo ErrorHandler
Dim path As String
Dim strcn As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
path = "Z:\外部データ.accdb"
If fso.FileExists(path) Then
strcn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source = " & path
Set cn = CreateObject("ADODB.Connection")
cn.CommandTimeout = 5
cn.Open strcn
Else
If Not cn Is Nothing Then
If cn.State = adStateOpen Then cn.Close
Set cn = Nothing
End If
End If
Exit Function
ErrorHandler:
Call ShowErrMsg("外部ACCESSファイルへの接続に失敗しました。")
End
End Function
'----------------------------------------------------------------------------
' Summary: １つ上のフォルダを取得返却
'----------------------------------------------------------------------------
Public Function GetParentPath() As String
Dim n1 As Integer
Dim n2 As Integer
Dim path As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
path = ""
'一つ上の階層からファイル指定
n2 = 0
Do
n2 = n2 + 1
n1 = InStr(n2, Application.CurrentProject.path, "\")
If n1 <> 0 Then n2 = n1
Loop While n1 <> 0
path = Left(Application.CurrentProject.path, n2 - 1)
GetParentPath = path
End Function
'----------------------------------------------------------------------------
' Summary. ファンクションキー操作.
' param KeyCode KeyDownイベントコード
' param F Form
'----------------------------------------------------------------------------
Function ModFunctionKey(KeyCode As Integer, F As Form)
On Error GoTo ErrorHandler
Select Case KeyCode
Case vbKeyF1
KeyCode = 0
If (F.F1.Enabled) Then F.F1_Click
Case vbKeyF2
KeyCode = 0
If (F.F2.Enabled) Then F.F2_Click
Case vbKeyF3
KeyCode = 0
If (F.F3.Enabled) Then F.F3_Click
Case vbKeyF4
KeyCode = 0
If (F.F4.Enabled) Then F.F4_Click
Case vbKeyF5
KeyCode = 0
If (F.F5.Enabled) Then F.F5_Click
Case vbKeyF6
KeyCode = 0
If (F.F6.Enabled) Then F.F6_Click
Case vbKeyF7
KeyCode = 0
If (F.F7.Enabled) Then F.F7_Click
Case vbKeyF8
KeyCode = 0
If (F.F8.Enabled) Then F.F8_Click
Case vbKeyF9
KeyCode = 0
If (F.F9.Enabled) Then F.F9_Click
Case vbKeyF10
KeyCode = 0
If (F.F10.Enabled) Then F.F10_Click
Case vbKeyF11
KeyCode = 0
If (F.F11.Enabled) Then F.F11_Click
Case vbKeyF12
KeyCode = 0
If (F.F12.Enabled) Then F.F12_Click
End Select
Exit Function
ErrorHandler:
If Not (Err = 2465) Then Call ShowErrMsg
End Function
'----------------------------------------------------------------------------
' Summary. Window操作.
' param intSw 0:非表示,2:アクティブ最小化,6:最小化
'----------------------------------------------------------------------------
Public Function AccWindow(intSw As Integer)
AccWindow = ShowWindow(Application.hWndAccessApp, intSw)
End Function
'フォームを常に最前面に表示
Function TopMost(F As Form)
Call SetWindowPos( _
F.hwnd, HWND_TOPMOST, 0, 0, 0, 0, _
SWP_NOMOVE Or SWP_NOSIZE)
End Function
'----------------------------------------------------------------------------
' Summary. エラーメッセージ表示.
' param msg エラーメッセージ
'----------------------------------------------------------------------------
Public Function ShowErrMsg(Optional ByVal msg As String = "")
If Err.Number = 0 And msg = "" Then Exit Function
If msg = "" Then
MsgBox "[No:" & Err.Number & "]" & Err.Description, vbCritical, "エラーが発生しました。"
Else
MsgBox msg, vbCritical
End If
End Function
'----------------------------------------------------------------------------
' Summary. 文字列置換処理.
' Description. 改行コードをvbCrLfに置換して返却します.
' param value 置換対象文字列
' return String
'----------------------------------------------------------------------------
Public Function ConvNewLineToLF(ByVal value As Variant) As String
ConvNewLineToLF = Replace(Replace(value, "\r\n", vbCrLf), "\r", vbCrLf)
End Function
'----------------------------------------------------------------------------
' Summary. 文字列置換処理.
' Description. 半角全角スペースを削除して返却します.
' param value 置換対象文字列
' return String
'----------------------------------------------------------------------------
Function DeleteSpace(ByVal value As Variant) As String
DeleteSpace = Replace(Replace(value, " ", ""), " ", "")
End Function
'----------------------------------------------------------------------------
' Summary. 文字列置換処理.
' Description. 改行コードvbCrLfをを削除して返却します.
' param value 置換対象文字列
' return String
'----------------------------------------------------------------------------
Function DeleteCrLf(ByVal value As Variant) As String
DeleteCrLf = Replace(value, vbCrLf, "")
End Function
'----------------------------------------------------------------------------
' Summary. 外部Access起動用.
' Description. 起動側Load()プロシージャ内にてCommand()関数で受け取り.
' param fileName accessファイル名
' param param コマンドライン引数
'----------------------------------------------------------------------------
Function OpenAccess(ByVal fileName As String, Optional ByVal param As String = "")
On Error GoTo ErrorHandler
Dim strAppName As String
Dim cmd As String: cmd = ""
If param <> "" Then cmd = " /cmd " & param
strAppName = "MsAccess.exe " & Application.CurrentProject.path & "\module\" & fileName & cmd
Call Shell(strAppName, 1)
ExitOpenMdb:
Exit Function
ErrorHandler:
Call ShowErrMsg
Resume ExitOpenMdb
End Function
'----------------------------------------------------------------------------
' Summary. ファイル選択ダイアログ表示.
' Description. 例 "Excel ﾌｧｲﾙ" ,"*.xlsx" "CSVﾌｧｲﾙ", "*.csv"
' param caption キャプション
' param fileType ファイル名.拡張子
' return ファイルパス
'----------------------------------------------------------------------------
Public Function GetFilePath( _
Optional ByVal caption As String = "*", _
Optional ByVal fileType As String = "*.*") As String
Dim strPath As String
Dim objDialog As Object
Set objDialog = Application.FileDialog(1)
With objDialog
.AllowMultiSelect = False
'ファイル フィルタのコレクション追加
With .Filters
.Clear
.Add caption, fileType
End With
If .Show = True Then
strPath = .SelectedItems(1)
Else
'キャンセル
strPath = ""
End
End If
End With
GetFilePath = strPath
End Function
'----------------------------------------------------------------------------
' Summary. フォルダ選択ダイアログ表示.
' return フォルダパス
'----------------------------------------------------------------------------
Public Function GetFolderPath() As String
On Error GoTo ErrorHandler
With Application.FileDialog(4)
.Title = "保存先のフォルダを選択してください"
.AllowMultiSelect = False '複数ファイル選択を不可
'初期フォルダはシステムに任せる
'.InitialFileName = CurrentProject.path & "\"
If .Show = -1 Then
'フォルダパスを返却
GetFolderPath = .SelectedItems(1)
Else
'未選択時は空文字返却
GetFolderPath = ""
End If
End With
Exit Function
ErrorHandler:
Call ShowErrMsg
End Function
'----------------------------------------------------------------------------
' Summary: ファイル出力
'----------------------------------------------------------------------------
Public Sub OutputFile(value As Variant, Optional fileName As String = "log.txt")
Dim lngFileNum As Long
Dim strLogFile As String
strLogFile = CurrentProject.path & "\" & fileName
lngFileNum = FreeFile()
Open strLogFile For Append As #lngFileNum
Print #lngFileNum, value
Close #lngFileNum
End Sub
'----------------------------------------------------------------------------
' Summary: プロパティ出力
'----------------------------------------------------------------------------
Public Sub ListControlProps(ByRef frm As Form)
Dim ctl As Control
Dim prp As Property
On Error GoTo props_err
For Each ctl In frm.Controls
Debug.Print ctl.Properties("Name")
For Each prp In ctl.Properties
'Debug.Print vbTab & prp.Name & " = " & prp.value
Call OutputFile(vbTab & prp.Name & " = " & prp.value, "properies.txt")
Next prp
Next ctl
props_exit:
Set ctl = Nothing
Set prp = Nothing
Exit Sub
props_err:
If Err = 2187 Then
Debug.Print vbTab & prp.Name & " = Only available at design time."
Resume Next
Else
Debug.Print vbTab & prp.Name & " = Error Occurred: " & Err.Description
Resume Next
End If
End Sub
