AccessからExcelを操作する
※動作確認済み
Sub Ctr_Excel()
Dim APP_Excel As Object 'Excel.Applicationオブジェクトの宣言
Dim Excel_WBK As Object 'Excel.Workbookオブジェクトの宣言
Dim Excel_WST As Object 'Excel.WorkSheetオブジェクトの宣言
Dim PTH As String '
PTH = Application.CurrentProject.Path & "\OUT_PUT.xlsx" 'Excelファイルのパスを指定
'※ Excelファイルが使用するAccessファイルと同じフォルダにある場合の表記
Set APP_Excel = CreateObject("Excel.Application") '実行時バインディング
Set Excel_WBK = APP_Excel.Workbooks.Open(PTH) 'ワークブックを開く
Set Excel_WST = Excel_WBK.Worksheets("Sheet1")
APP_Excel.Visible = True 'Excelアプリケーションを表示する
'ワークシートへの処理
'Excel_WST.Range("A1").Value = "Access"
'ワークシートのコピー作成
'Excel_WST.Copy after:=Excel_WST
'Excel_WBK.ActiveSheet.Name = "test"
'Excelを保存して閉じる
'Excel_WBK.Save 'ワークブックを保存する
Excel_WBK.Close 'ワークブックを閉じる
APP_Excel.Quit
End Sub
VBA内で文字列を「’」クォーテーションで囲む
※動作確認済み
Function Get_Kakutei_Waku(SG_No_N As String) As String
'作成者：瀧澤禮好
'作成日：2018/10/06
'変更日：2018/10/06
'VBA内で文字列を「’」クォーテーションで囲む
Dim SG_No_S As String '電番確定枠SG付き
'Dim SG_No_N As String '電番確定枠数字
SG_No_S = "'" & SG_No_N & "'"
Get_Kakutei_Waku = SG_No_S
Exit Function
End Function
DAOでカレントDBでのテーブル又はクエリを元にレコードセット処理を行う。
※動作確認済み
Sub ExecuteQuery_dao()
'作成者：瀧澤禮好
'作成日：2018/10/06
'変更日：2018/10/06
'クエリを元にレコードセット処理を行う。
Dim DAO_WS As Workspace
Dim DAO_DB As DAO.Database
Dim DAO_RS As DAO.Recordset
Dim DAO_FIL As DAO.Field
Dim ST As String
Dim CN As Long
Set DAO_WS = DBEngine.Workspaces(0)
Set DAO_DB = CurrentDb()
Set DAO_RS = DAO_DB.OpenRecordset("クエリ1") 'テーブル名又はクエリ名を設定。
CN = 0
Do Until DAO_RS.EOF 'レコードセットの最後まで繰り返す。
ST = DAO_RS![サブタイトル] '取得するフィールド名を指定。
DAO_RS.MoveNext '次のレコードへ移動
CN = CN + 1
Loop
DAO_RS.Close 'レコードセットを閉じる。
DAO_DB.Close 'データベースを閉じる。
DAO_WS.Close 'ワークスぺスを閉じる。
Set DAO_RS = Nothing 'オブジェクト変数の初期化。
Set DAO_DB = Nothing 'オブジェクト変数の初期化。
Set DAO_WS = Nothing 'オブジェクト変数の初期化。
End Sub
Yes/No型フィールドから最初のNoのレコードを抽出し、抽出したレコードのユニークなキーを使ってレコードを更新
※動作確認済み
Public STR_SeikyuSho_No As String
Sub Get_SeikyuSho_No()
'作成者：瀧澤禮好
'作成日：2018/10/06
'変更日：2018/10/06
'Yes/No型フィールドから最初のNoのレコードを抽出
'抽出したレコードのユニークなキーを使ってレコードを更新
Dim SQL_STR As String
STR_SeikyuSho_No = DLookup("ID", "tbl_テレビ録画", "録画完了 = NO")
'Yes/No型フィールドから最初のNoのレコードを抽出
'抽出したレコードのユニークなキーを使ってレコードを更新
SQL_STR = " UPDATE tbl_テレビ録画 SET tbl_テレビ録画.録画完了 = Yes, tbl_テレビ録画.収納ケース =
PC_Name_Get()" _
& " WHERE (((tbl_テレビ録画.ID)=" & STR_SeikyuSho_No & "));"
If DAO_TRANS(SQL_STR) = False Then
MsgBox "エラー", 16, ""
End If
Exit Sub
End Sub
DAOでカレントDBでのトランザクション処理
※動作確認済み
「DAO_DB.Execute SQL_STR」ステートメントでSQLを実行すれば、
テーブル設定など気にせずにカレントDBのトランザクション処理が可能。
Public Function DAO_TRANS(SQL_STR As String) As Boolean
'作成者：瀧澤禮好
'作成日：2018/10/06
'変更日：2018/10/06
'カレントDBでのトランザクション処理
Dim DAO_WKS As DAO.Workspace 'Workspaceオブジェクト格納場所
Dim DAO_DB As DAO.Database
Set DAO_WKS = DAO.DBEngine.Workspaces(0) 'Workspaceオブジェクトを取得
Set DAO_DB = CurrentDb()
On Error GoTo ERROR_TRANS 'トランザクション処理中にエラーが発生したらERR_TRANSへ
DAO_WKS.BeginTrans 'トランザクション開始
DAO_DB.Execute SQL_STR
DAO_WKS.CommitTrans '全てのトランザクションを反映させる
DAO_TRANS = True
Exit Function 'プロシージャ終了
ERROR_TRANS: 'トランザクションエラー処理
DAO_WKS.Rollback 'トランザクションを中止
DAO_TRANS = False
MsgBox "エラー", 16, "" 'エラーメッセージを表示
End Function
Sub ddd()
Dim SQL_STR As String
SQL_STR = " UPDATE tbl_テレビ録画 INNER JOIN tbl_特記事項 ON tbl_テレビ録画.ID = tbl_特記事項.連結ID
SET tbl_特記事項.更新日時 = Now()" _
& " WHERE (((tbl_テレビ録画.番組名)='幼女戦記'));"
If DAO_TRANS(SQL_STR) = False Then
MsgBox "エラー", 16, ""
End If
End Sub
AcSpreadSheetType列挙型（アクセス）2017/06/08
読了までの所要時間：2分
共同作成者
TransferSpreadsheetメソッドと共に使用して、インポート、エクスポート、またはリンクするスプレッドシートのタイプを指定します。
名 値 説明
acSpreadsheetTypeExcel3 0 Microsoft Excel 3.0形式
acSpreadsheetTypeExcel4 6 Microsoft Excel 4.0形式
acSpreadsheetTypeExcel5 5 Microsoft Excel 5.0形式
acSpreadsheetTypeExcel7 5 Microsoft Excel 95形式
acSpreadsheetTypeExcel8 8 Microsoft Excel 97形式
acSpreadsheetTypeExcel9 8 Microsoft Excel 2000形式
acSpreadsheetTypeExcel12 9 Microsoft Excel 2010フォーマット
acSpreadsheetTypeExcel12Xml 10 Microsoft Excel 2010/2013/2016 XML形式（.xlsx、.xlsm、.xlsb）
CSVデータを１行づつ取り込む
https://ameblo.jp/komasu/entry-10360634581.html
'FSO（FileSystemObject）を使う。
Public Sub IMPORT(FilePath As String)
Dim FSO As Object ’FSO
Dim txtS As Object 'CSVファイルを格納
Dim TxtL As String 'CSVから取り出した行
Dim Seq As Variant 'フィールドデータ
Dim Rec(8) As Variant 'データの保存箱
Dim I As Integer 'ループカウント用
'FileSystemObjectをセット
Set FSO = CreateObject("Scripting.FileSystemObject")
'引数で取得したファイルパスにファイルがあるかどうかを確認する。
If FSO.FileExists(FilePath) Then
'ファイルがあれば変数へセット
Set txtS = FSO.OpenTextFile(FilePath, 1)
Else
'なければ出る
Exit Sub
End If
'ループで１行ずつ読み込む
'AtEndOfStreamは、最後の行まで読むってこと
Do Until txtS.AtEndOfStream
'カレント行を格納
TxtL = txtS.ReadLine
'Split関数でカンマ区切りを分ける
Seq = Split(TxtL, ",")
'UBoundでフィールド数を確認
If UBound(Seq) >= 8 Then
'For で１フィールドずつ取得
For I = 0 To 8
Rec(I) = Seq(I)
Next I
End If
Loop
End Sub
クエリのSQLプロパティを取得
Function Get_SQL_ST(Q_Name As String) As String
'作成者：瀧澤 禮好
'作成日：2018/06/27
'更新日：2018/06/27
'クエリのSQLを取得
Get_SQL_ST = CurrentDb.QueryDefs(Q_Name).SQL
Exit Function
End Function
Sub sss()
'作成者：瀧澤 禮好
'作成日：2018/06/27
'更新日：2018/06/27
'クエリのSQLを取得
MsgBox Get_SQL_ST("qry_作業時間合計")
End Sub
※クエリの実態があれば、SQLプロパティの取得が可能。
以下のSQL文でクエリを作成すると、総てのクエリのSQLプロパティが取得できる、
SELECT MSysObjects.Name, MSysObjects.Type, Get_SQL_ST([MSysObjects]![Name]) AS
SQLプロパティ
FROM MSysObjects
WHERE (((MSysObjects.Type)=5));
csvをVBAを使ってエクセル形式で保存
Function CSV_To_Excel(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2017/11/04
'変更日：2017/11/05
'AccessでExcelを制御
Dim Excel As Application
Dim cnt As Integer
Dim appExcel As Excel.Application 'アプリケーション変数の宣言
Dim PTH_E As String
Dim targetBook As Workbook
Dim B_Name As String
Set appExcel = CreateObject("Excel.Application") 'アプリケーション変数にExcelを設定
cnt = Len(PTH)
PTH_E = Left(PTH, (cnt - 4))
B_Name = Get_Base_Name(PTH)
'csvファイルをエクセルで開く
Set targetBook = appExcel.Workbooks.Open(PTH)
' 1 〜 5 行目を削除
appExcel.Range("1:5").Delete ' 1 〜 5 行目を削除
'xlsx形式で保存
targetBook.SaveAs FileName:=PTH_E & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook
targetBook.Close
CSV_To_Excel = PTH_E & ".xlsx"
'CSVファイルの削除
'Kill PTH
End Function
Private Sub cmd_Csv_Link_Click()
'作成者：瀧澤禮好
'作成日：2017/11/04
'変更日：2017/11/05
DoCmd.SetWarnings False
Dim SQL_STR As String
Dim PTH As String
Dim PTH_E As String
If (MsgBox("JCBエクスポートファイルをインポートします！！OKですか？？？", 4) = 7) Then
Exit Sub
End If
PTH = FDFilePicker
If PTH = "" Then
Exit Sub
End If
SQL_STR = "DELETE JCB_DATA.*" _
& " FROM JCB_DATA;"
DoCmd.RunSQL SQL_STR, 1
'CSVデータをExcelに変換する。
PTH_E = CSV_To_Excel(PTH)
Dim B_Name As String
B_Name = Get_Base_Name(PTH)
'Excelデータをリンクテーブルに設定する。
DoCmd.TransferSpreadsheet acLink, acSpreadsheetTypeExcel12, "JCB_CSV", PTH_E,
True
SQL_STR = "INSERT INTO JCB_DATA" _
& " SELECT JCB_CSV.*" _
& " FROM JCB_CSV" _
& " WHERE (((JCB_CSV.[ご利用者]) Like '*1132*'));"
DoCmd.RunSQL SQL_STR, 1
DoCmd.DeleteObject acTable, "JCB_CSV"
'Excelファイルの削除
Kill PTH_E
End Sub
Excelを制御する・AccessVBA逆引き大全600の極意（536-540）
Excelファイルを表示する。:
Private Sub cmd_Click()
On Error Resume Next
Dim appExcel As Excel.Application
Dim wb As Excel.Workbook
Dim FPath As String
'ファイルのパス
FPath = "D:\AccessVBA\" & FName
'[AccessVBA]フォルダの指定したファイルを表示
Set appExcel = CreateObject("Excel.Application")
Set wb = appExcel.Workbooks.Open(FPath)
appExcel.Visible = True
Set wb = Nothing
Set appExcel = Nothing
End Sub
Excel枠シートのデータを表示する。:
Private Sub cmd_Click()
On Error Resume Next
Dim FPath As String
Dim i As Integer
Dim data(7) As String
FPath = DDEInitiate("Excel", "顧客.xls")
'5行目の2列目から7列目データを格納
For i = 1 To 7
data(i) = DDERequest(FPath, "R5C" & i + 1)
Next
'テキストボックスに表示
getData = data(1) & data(2) & data(3) & data(4) _
& data(5) & data(6) & data(7)
'チャンネルを閉じる
DDETerminate (FPath)
End Sub
Excelブックを新規作成する。:
Private Sub cmd_Click()
Dim appExcel As Excel.Application
Dim wb As Excel.Workbook
Dim wsh As Excel.Worksheet
Dim i As Integer
Dim FPath As String
'新規ブックを作成
Set appExcel = CreateObject("Excel.Application")
Set wb = appExcel.Workbooks.Add
Set wsh = wb.Worksheets(1)
'保存する場所を指定して、Excelのブックを保存
FPath = "D:\AccessVBA\" & FName
wb.SaveAs FPath
'作成したブックを表示
appExcel.Visible = True
Set wsh = Nothing
Set wb = Nothing
Set appExcel = Nothing
End Sub
Excelのワークシートにデータを出力する。:
Private Sub cmd_Click()
Dim appExcel As Excel.Application
Dim wb As Excel.Workbook
Dim wsh As Excel.Worksheet
Dim FPath As String
'Excelの新規ブックを作成
Set appExcel = CreateObject("Excel.Application")
Set wb = appExcel.Workbooks.Add
Set wsh = wb.Worksheets(1)
'フィールド名を出力
wsh.Range("A1").Value = Me.商品IDラベル.Caption
wsh.Range("B1").Value = Me.商品区分ラベル.Caption
wsh.Range("C1").Value = Me.商品コードラベル.Caption
wsh.Range("D1").Value = Me.商品名ラベル.Caption
wsh.Range("E1").Value = Me.表示価格ラベル.Caption
'データを出力
wsh.Range("A2").Value = Me.商品ID
wsh.Range("B2").Value = Me.商品区分
wsh.Range("C2").Value = Me.商品コード
wsh.Range("D2").Value = Me.商品名
wsh.Range("E2").Value = Me.表示価格
'書式の設定
wsh.Range("A1:E1").Font.Color = RGB(100, 250, 200)
wsh.Range("A1:E1").Font.Bold = True
'新規作成したブックを表示
appExcel.Visible = True
'変数[FPath]に取得するフォルダ名を代入
FPath = "D:\AccessVBA\商品出力.xls"
'ブックの保存
wb.SaveAs FPath
'オブジェクトの解放
Set appExcel = Nothing
Set wb = Nothing
Set wsh = Nothing
End Sub
Excelのワークシートからデータを取得する。:
Private Sub Form_Open(Cancel As Integer)
Dim appExcel As Excel.Application
Dim wb As Excel.Workbook
Dim wsh As Excel.Worksheet
Dim i As Integer
Dim FPath As String
'Excelのファイルからの参照
FPath = "D:\AccessVBA\海外旅行.xls"
Set wb = GetObject(FPath)
Set wsh = wb.Sheets("地域")
'コンボボックスに値を追加
For i = 2 To 11
combo.AddItem wsh.cells(i, 1)
Next i
wb.Close
Set wb = Nothing
Set appExcel = Nothing
End Sub
Private Sub txt_PTH_DblClick(Cancel As Integer)
'作成者：滝澤礼好
'作成日：2015/12/23
'変更日：2015/12/23
Me.txt_PTH = FDFilePicker
Get_Sheet_Name (Me.txt_PTH)
Me.cmb_Sheet_Name.RowSource = "qry_Sheet_Name"
End Sub
Public Function Get_Sheet_Name(PTH As String) As Boolean
'作成日：2015/12/23
'更新日：2015/12/23
'作成者：滝澤礼好
'AccessでExcelを制御
'Excelのシート名を総て取得
DoCmd.SetWarnings False
DoCmd.DeleteObject acTable, "tbl_Sheet_Name"
DoCmd.CopyObject "", "tbl_Sheet_Name", acTable, "tbl_Sheet_Name0"
Dim Moto_Book As Excel.Workbook 'ワークブック変数の宣言
Dim Moto_Sht As Excel.Worksheet 'ワークシート変数の宣言
Dim Moto_Rng As Excel.Range 'セルの変数宣言
Dim Moto_Book_Name As String '元ブック名格納変数
Dim Moto_Sht_Name As String '元シート名格納変数
Set Moto_Book = Excel.Workbooks.Open(PTH)
'シートをセット
Dim Sheet_CNT As Integer
Sheet_CNT = Sheets.Count
Dim i As Integer
For i = 1 To Sheet_CNT
Moto_Sht_Name = Worksheets(i).Name
[Forms]![frm_Main]![cmb_Sheet_Name] = Moto_Sht_Name
DoCmd.OpenQuery "qry_ADD_Sheet_Name", acViewNormal, acEdit
Next i
Moto_Book.Close True 'Bookをセーブして閉じる
appExcel.Quit 'アプリケーションを終了する
'オブジェクトの開放
Set appExcel = Nothing
Exit Function
End Function
'Access2013：Excelからイン.ポート
'DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "インポート先テーブル",
"フルパス￥Book名", True, "シート名"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, "インポート先テーブル",
"フルパス￥Book名", True, "シート名" 'xlsx
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "インポート先テーブル",
"フルパス￥Book名", True, "シート名" 'xls
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Option Compare Database
Function Get_File_Attributes(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2017/04/03
'変更日：2017/04/03
'ファイルの属性を設定します
Dim FSO As Object
Dim Att As Integer
Set FSO = CreateObject("Scripting.FileSystemObject")
Att = FSO.GetFile(PTH).Attributes
Set FSO = Nothing
Select Case Att
Case 0
Get_File_Attributes = "標準ファイル。どの属性も設定されない。"
Case 1
Get_File_Attributes = "読み取り専用ファイル。"
Case 2
Get_File_Attributes = "隠しファイル。"
Case 4
Get_File_Attributes = "システムファイル。"
Case 8
Get_File_Attributes = "ディスクドライブボリュームラベル。この属性を設定することは出来ない（値の取得のみ可能）。"
Case 16
Get_File_Attributes = "フォルダ。この属性を設定することは出来ない。"
Case 32
Get_File_Attributes = "アーカイブ属性が設定されている（前回のバックアップ以降に変更されていればアーカイブ属性はオン）。"
Case 64
Get_File_Attributes = "リンクまたはショートカット、この属性を設定することは出来ない（値の取得のみ可能）。"
Case 128
Get_File_Attributes = "圧縮ファイル。この属性を設定することは出来ない（値の取得のみ可能）。"
Case Else
Get_File_Attributes = "属性不明。"
End Select
'値 意味
'0 標準ファイル。どの属性も設定されない。
'1 読み取り専用ファイル。
'2 隠しファイル。
'4 システムファイル。
'8 ディスクドライブボリュームラベル。この属性を設定することは出来ない（値の取得のみ可能）。
'16 フォルダ。この属性を設定することは出来ない。
'32 アーカイブ属性が設定されている（前回のバックアップ以降に変更されていればアーカイブ属性はオン）。
'64 リンクまたはショートカット、この属性を設定することは出来ない（値の取得のみ可能）。
'128 圧縮ファイル。この属性を設定することは出来ない（値の取得のみ可能）。
Get_Error_Data ("Get_File_Attributes")
End Function
Function Get_File_DateCreated(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2017/04/02
'変更日：2017/04/02
'ファイルが作成された日付と時刻を返します
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Get_File_DateCreated = FSO.GetFile(PTH).DateCreated
Set FSO = Nothing
Get_Error_Data ("Get_File_DateCreated")
End Function
Function Get_File_DateLastAccessed(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2017/04/02
'変更日：2017/04/02
'ファイルが最後にアクセスされたときの日付と時刻を返します
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
''C:\Work\Book1.xlsが最後にアクセスされた日時を表示します
Get_File_DateLastAccessed = FSO.GetFile(PTH).DateLastAccessed
Set FSO = Nothing
Get_Error_Data ("Get_File_DateLastAccessed")
End Function
Function Get_File_DateLastModified(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2017/04/02
'変更日：2017/04/02
'ファイルが最後に更新されたときの日付と時刻を返します
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
''C:\Work\Book1.xlsが最後に更新された日時を表示します
Get_File_DateLastModified = FSO.GetFile(PTH).DateLastModified
Set FSO = Nothing
Get_Error_Data ("Get_File_DateLastModified")
End Function
Function Get_File_Drive(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2017/04/02
'変更日：2017/04/02
'ファイルが存在するドライブの名前を返します
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
''「C:」を表示します
Get_File_Drive = FSO.GetFile(PTH).Drive
Set FSO = Nothing
Get_Error_Data ("Get_File_Drive")
End Function
Function Get_File_Name_WSH(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2017/04/02
'変更日：2017/04/02
'ファイルの名前を返します
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Get_File_Name_WSH = FSO.GetFile(PTH).Name
Set FSO = Nothing
Get_Error_Data ("Get_File_Name_WSH")
End Function
Function Get_File_ParentFolder(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2017/04/02
'変更日：2017/04/02
'ファイルが存在するフォルダを返します
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
''「C:\Work」を表示します
Get_File_ParentFolder = FSO.GetFile(PTH).ParentFolder
Set FSO = Nothing
Get_Error_Data ("Get_File_ParentFolder")
End Function
Function Get_File_Path(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2017/04/02
'変更日：2017/04/02
'ファイルのパスを返します
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
''「C:\Work\Book1.xls」を表示します
Get_File_Path = FSO.GetFile(PTH).Path
Set FSO = Nothing
Get_Error_Data ("Get_File_Path")
End Function
Function Get_File_Size(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2017/04/02
'変更日：2017/04/02
'ファイルのサイズを返します
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
''C:\Work\Book1.xlsのサイズを表示します
Get_File_Size = FSO.GetFile(PTH).Size
Set FSO = Nothing
Get_Error_Data ("Get_File_Size")
End Function
Function Get_File_Type(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2017/04/02
'変更日：2017/04/02
'ファイルの種類を返します
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
''「Microsoft Office Excelワークシート」を表示します
Get_File_Type = FSO.GetFile(PTH).Type
Set FSO = Nothing
Get_Error_Data ("Get_File_Type")
End Function
Function FSO_DR_Check(Folder_CK As String) As Boolean
'作成者：瀧澤禮好
'作成日：2017/09/16
'変更日：2017/09/16
'ドライブ有無のチェック
Dim cFso As FileSystemObject 'オブジェクト変数宣言
Set cFso = New FileSystemObject '変数にオブジェクトの代入
If cFso.DriveExists(Folder_CK) Then
FSO_DR_Check = True 'ドライブ有り
Else
FSO_DR_Check = False 'ドライブ無し
End If
End Function
Function FSO_PH_Check(Folder_CK As String) As Boolean
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'フォルダー有無のチェック
Dim cFso As FileSystemObject 'オブジェクト変数宣言
Set cFso = New FileSystemObject '変数にオブジェクトの代入
If cFso.FolderExists(Folder_CK) Then
FSO_PH_Check = True 'フォルダー有り
Else
FSO_PH_Check = False 'フォルダー無し
End If
Get_Error_Data ("FSO_PH_Check")
End Function
Function FSO_FL_Check(File_CK As String) As Boolean
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'ファイル有無のチェック
Dim cFso As FileSystemObject 'オブジェクト変数宣言
Set cFso = New FileSystemObject '変数にオブジェクトの代入
If cFso.FileExists(File_CK) Then
FSO_FL_Check = True 'ファイル有り
Else
FSO_FL_Check = False 'ファイル無し
End If
Get_Error_Data ("FSO_FL_Check")
End Function
Function Get_Base_Name(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'※ファイルのベースネームを取得する。
'FSOを利用するので、「MicroSoft Scripting Runtime」の参照設定が必須！
Dim objFileSys As Object
Dim strPath As String
Set objFileSys = CreateObject("Scripting.FileSystemObject")
strPath = objFileSys.GetBaseName(PTH)
Get_Base_Name = strPath
Set objFileSys = Nothing
Get_Error_Data ("Get_Base_Name")
End Function
Function Get_kakuchoushi(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'※ファイルの拡張子を取得する。
'FSOを利用するので、「MicroSoft Scripting Runtime」の参照設定が必須！
Dim objFileSys As Object
Dim strPath As String
Set objFileSys = CreateObject("Scripting.FileSystemObject")
strPath = objFileSys.GetExtensionName(PTH)
Get_kakuchoushi = strPath
Set objFileSys = Nothing
Get_Error_Data ("Get_kakuchoushi")
End Function
Option Compare Database
Option Explicit
Public Function DAO_TRANS(SQL_STR As String) As Boolean
'作成者：瀧澤禮好
'作成日：2018/10/06
'変更日：2018/10/06
'カレントDBでのトランザクション処理
Dim DAO_WKS As DAO.Workspace 'Workspaceオブジェクト格納場所
Dim DAO_DB As DAO.Database
Set DAO_WKS = DAO.DBEngine.Workspaces(0) 'Workspaceオブジェクトを取得
Set DAO_DB = CurrentDb()
On Error GoTo ERROR_TRANS 'トランザクション処理中にエラーが発生したらERR_TRANSへ
DAO_WKS.BeginTrans 'トランザクション開始
DAO_DB.Execute SQL_STR
DAO_WKS.CommitTrans '全てのトランザクションを反映させる
DAO_TRANS = True
Exit Function 'プロシージャ終了
ERROR_TRANS: 'トランザクションエラー処理
DAO_WKS.Rollback 'トランザクションを中止
DAO_TRANS = False
MsgBox "エラー", 16, "" 'エラーメッセージを表示
End Function
Sub ddd()
Dim SQL_STR As String
SQL_STR = " UPDATE tbl_テレビ録画 INNER JOIN tbl_特記事項 ON tbl_テレビ録画.ID = tbl_特記事項.連結ID
SET tbl_特記事項.更新日時 = Now()" _
& " WHERE (((tbl_テレビ録画.番組名)='幼女戦記'));"
'テーブルの指定は、,で区切れば可能（"tbl_テレビ録画,tbl_テレビ録画2"）
If DAO_TRANS(SQL_STR) = False Then
MsgBox "エラー", 16, ""
End If
End Sub
Option Compare Database
Option Explicit
Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA"
( _
ByVal hwnd As Long, _
ByVal pszPath As String, _
ByVal psa As Long) As Long
Public Function MkFolder(FL As String) As Boolean
'作成者：瀧澤禮好
'作成日：2016/07/15
'変更日：2016/08/18
'多重層のフォルダ作成
'フォルダの存在確認
If FSO_PH_Check(FL) = True Then
MkFolder = True
Else
'多重層のフォルダ作成
Dim rc As Long
Dim Target As String
Target = FL
rc = SHCreateDirectoryEx(0&, Target, 0&)
If rc = 0 Then
'正常終了
MkFolder = True
Else
'異常終了
MkFolder = False
End If
End If
Get_Error_Data ("MkFolder")
End Function
Public Function Make_Folder(FL As String) As Boolean
'作成者：瀧澤禮好
'作成日：2016/07/15
'変更日：2016/07/27
'多重層のフォルダ作成
'フォルダの存在確認
If FSO_PH_Check(FL) = True Then
Make_Folder = True
Else
'多重層のフォルダ作成
Dim rc As Long
Dim Target As String
Target = FL
rc = SHCreateDirectoryEx(0&, Target, 0&)
If rc = 0 Then
'正常終了
Make_Folder = True
Else
'異常終了
Make_Folder = False
End If
End If
Get_Error_Data ("Make_Folder")
End Function
Public Function PC_Name_Get() As String
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'コンピュータ名の取得
Dim PC As String
PC = Environ("ComputerName") '環境変数の取得
PC_Name_Get = PC
Get_Error_Data ("PC_Name_Get")
End Function
Public Function User_Name_Get() As String
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'ユーザー名の取得
Dim User_Name
User_Name = Environ("UserName") '環境変数の取得
User_Name_Get = User_Name
Get_Error_Data ("User_Name_Get")
End Function
Public Function OS_Name_Get() As String
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'OS名の取得
Dim OS_Name
OS_Name = Environ("OS") '環境変数の取得
OS_Name_Get = OS_Name
Get_Error_Data ("OS_Name_Get")
End Function
Function Get_Time_Stamp(File_Name As String) As String
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'ファイルデータスタンプ（更新日時）の取得
Dim GTS As String
GTS = FileDateTime(File_Name)
Get_Time_Stamp = GTS
Get_Error_Data ("Get_Time_Stamp")
End Function
Function Get_ClipBord0(String_Data As String) As Boolean
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'クリップボードにコピー
'※参照設定でFM2.0オブジェクトライブラリをチェックする
'格納場所（64bit）⇒c:\windows\syswow64\fm20.dll
On Error GoTo Err_Tasc
Dim CB0 As String
CB0 = String_Data
With New MSForms.DataObject
.SetText CB0 '変数の値をオブジェクトに代入
.PutInClipboard 'クリップボードにコピー
End With
Get_ClipBord0 = True
Get_Error_Data ("Get_ClipBord0")
Exit Function
Err_Tasc:
Get_ClipBord0 = False
Get_Error_Data ("Get_ClipBord0")
Exit Function
End Function
Public Function GetCurBD(BDate As Variant) As Variant
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'概要 誕生日より今日現在の年齢を計算します
'引数 BDate : 誕生日
'返り値 年齢(誕生日がNullのときはNullを返します)
Dim GetBD As Variant
If Not IsNull(BDate) Then
'引数の誕生日が指定されているとき
'誕生日と今日の日付の年の差を年齢とする
GetBD = DateDiff("yyyy", BDate, Date)
If DateSerial(Year(Date), Month(BDate), Day(BDate)) > Date Then
'その年の誕生日がまだ来ていないときはマイナス１する
GetBD = GetBD - 1
End If
Else
'引数の誕生日が指定されていないときはNullを設定
GetBD = Null
End If
'返り値を設定
GetCurBD = GetBD
Get_Error_Data ("GetCurBD")
End Function
Function Make_Fl(Folder As String) As Boolean
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'フォルダーの作成
On Error GoTo ERROR_TASK
Dim MFL As String
Dim ct As Integer
ct = Len(Folder)
ct = ct - 1
MFL = Left(Folder, ct)
MkDir (MFL)
Make_Fl = True
Get_Error_Data ("Make_Fl")
Exit Function
ERROR_TASK:
Make_Fl = False
Get_Error_Data ("Make_Fl")
Exit Function
End Function
Function Week_Day_Name(WN As Date) As String
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'曜日の取得
Dim Week_Name As String
Week_Name = WeekdayName(Weekday(WN))
Week_Day_Name = Week_Name
Get_Error_Data ("Week_Day_Name")
End Function
Public Function FDFolderPicker()
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'[参照] ダイアログ ボックスの FileDialog オブジェクトを作成します。
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
'選択した各アイテムのパスを保存す変数を宣言します。
Dim vrtSelectedItem As Variant
'プロパティの設定
With fd
.Title = "ファイルダイアログ（フォルダ参照）"
.InitialView = msoFileDialogViewDetails
.InitialFileName = CurrentProject.Path
'[参照] ダイアログ ボックスを表示します。
If .Show = -1 Then
'ユーザーがアクション ボタンをクリックした場合
For Each vrtSelectedItem In .SelectedItems
FDFolderPicker = vrtSelectedItem
Next vrtSelectedItem
Else
'ユーザーが [キャンセル] をクリックした場合
End If
End With
'オブジェクトの変数に Nothing を設定します。
Set fd = Nothing
Get_Error_Data ("FDFolderPicker")
End Function
Public Function FDFilePicker()
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'[参照] ダイアログ ボックスの FileDialog オブジェクトを作成します。
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'選択した各アイテムのパスを保存す変数を宣言します。
Dim vrtSelectedItem As Variant
'プロパティの設定
With fd
.Title = "ファイルダイアログ（ファイル参照）"
.InitialFileName = CurrentProject.Path
'フィルターの設定
.Filters.Clear
.Filters.Add "テキスト", "*.txt; *.csv"
.Filters.Add "エクセル", "*.xls"
.Filters.Add "Access", "*.mdb;*.accdb"
.Filters.Add "イメージ", "*.gif; *.jpg; *.jpeg"
.Filters.Add "すべてのファイル", "*.*"
.FilterIndex = 5
.InitialView = msoFileDialogViewDetails
.AllowMultiSelect = False
'[参照] ダイアログ ボックスを表示します。
If .Show = -1 Then
'ユーザーがアクション ボタンをクリックした場合
For Each vrtSelectedItem In .SelectedItems
FDFilePicker = vrtSelectedItem
Next vrtSelectedItem
Else
'ユーザーが [キャンセル] をクリックした場合
End If
End With
'オブジェクトの変数に Nothing を設定します。
Set fd = Nothing
Get_Error_Data ("FDFilePicker")
End Function
Function Hankaku(STR_STR As String) As String
'参照設定「Microsoft Script Regular Expressions 5.5」
'正規表現を使って検索、抽出した文字列を返す。
'作成者：瀧澤禮好
'作成日：2016/10/09
'更新日：2016/10/09
On Error Resume Next
'正規表現で半角文字検索
Dim strSample
Dim regPattern
Dim colMatches
Dim objMatch
Dim Seiki_Str As String
Dim Kekka As String
'正規表現のパターンを設定
Seiki_Str = "[ -~]+"
'文字列変数「Kekka」の初期化
Kekka = ""
strSample = STR_STR
Set regPattern = New RegExp
regPattern.Pattern = Seiki_Str '検索の正規表現
regPattern.Global = True
Set colMatches = regPattern.Execute(strSample)
For Each objMatch In colMatches
Kekka = Kekka & objMatch
Next
Dim CN As Long
CN = Len(Kekka)
If CN = 0 Then
Hankaku = "半角文字は見つかりませんでした！"
Else
Hankaku = Kekka
End If
Exit Function
End Function
Sub Re_Conect()
'作成者：瀧澤禮好
'作成日：2016/10/31
'更新日：2016/10/31
On Error GoTo Err_Job
'データMDBにリンクを更新します。
'リンク更新失敗したら Access終了します。
'===============================================
Dim strIniFile As String
Dim strIniFile_Chk As String
Dim Kakuchoushi As String
Dim str_CN_MDB_Name As String
Dim TBL_RE_CNT As TableDef
Dim boo_CNT_UP As Boolean
Dim Pass_Word As String
Pass_Word = ";pwd=" & "ut-kokuzou.jp"
str_CN_MDB_Name = FDFilePicker
strIniFile_Chk = Get_Base_Name(str_CN_MDB_Name)
Kakuchoushi = "." & Get_kakuchoushi(str_CN_MDB_Name)
strIniFile_Chk = strIniFile_Chk & Kakuchoushi
If (MsgBox("リンク先MDBは「" & str_CN_MDB_Name & "」です。OKですか？？", 36) = 7) Then
Get_Error_Data ("Re_Conect")
Exit Sub
End If
'接続ファイル名の確認
If strIniFile_Chk = "健康管理記録蓄積be.mdb" Then
GoTo PSW_CK
Else
MsgBox "選択したファイルはリンクMDBではありません！", 48
Get_Error_Data ("Re_Conect")
Exit Sub
End If
PSW_CK:
'パスワードの有無
If (MsgBox("バックエンドにパスワードが付いていますか？？", 36) = 7) Then
GoTo CH_CNT
Else
Pass_Word = InputBox("パスワードを入力してください！", "Re_Conect", "*****")
If Pass_Word = "" Then
GoTo PSW_CK
End If
Pass_Word = ";pwd=" & Pass_Word
str_CN_MDB_Name = str_CN_MDB_Name & Pass_Word
End If
CH_CNT:
' データベースのすべてのテーブルをループします。
For Each TBL_RE_CNT In CurrentDb.TableDefs
' テーブルに接続文字列があるとき
If Len(TBL_RE_CNT.Connect) > 0 Then
TBL_RE_CNT.Connect = _
";DATABASE=" & str_CN_MDB_Name
' テーブルのリンクを更新
Err = 0
On Error Resume Next
TBL_RE_CNT.RefreshLink
'エラーがあったら
If Err <> 0 Then
MsgBox TBL_RE_CNT.Name & _
Err.Description, vbCritical, _
"リンク更新失敗"
Application.Quit 'Access終了
End If
End If
Next TBL_RE_CNT
MsgBox "リンク再接続が完了しました！", 64
END_JOB:
Get_Error_Data ("Re_Conect")
Exit Sub
Err_Job:
MsgBox "システムエラーです！システム担当者に連絡してください！", 16
Get_Error_Data ("Re_Conect")
Exit Sub
End Sub
Function Create_Link_Table(PTH As Variant, Moto_TBL As Variant, Saki_TBL As
Variant) As Boolean
'作成者：瀧澤禮好
'作成日：2016/10/31
'更新日：2016/10/31
'PTH リンク元のフルパスのAccessDB名（拡張子付き）
'Moto_TBL リンク元のテーブル名
'Saki_TBL リンク先のテーブル名
Dim db As DAO.Database
Dim tbldf As DAO.TableDef
Set db = CurrentDb
Set tbldf = db.CreateTableDef(Saki_TBL) 'リンク先
tbldf.Connect = ";DATABASE=" & PTH & ";TABLE=" & Moto_TBL 'リンク元
tbldf.SourceTableName = Moto_TBL 'リンク元"
db.TableDefs.Append tbldf
Set tbldf = Nothing: Set db = Nothing
Application.RefreshDatabaseWindow
Create_Link_Table = True
Get_Error_Data ("Create_Link_Table")
Exit Function
Err_Task:
Create_Link_Table = False
Get_Error_Data ("Create_Link_Table")
Exit Function
End Function
Function Get_File_Path_Instr(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2018/03/01
'変更日：2018/03/04
'ファイルの格納フォルダを返す。
Dim Kakuchoushi As String
Dim File_Name As String
Dim Len_Kakuchoushi As Integer
Dim Len_File_Name As Integer
Dim Len_PTH As Integer
Dim RE_PTH As String
On Error Resume Next
If PTH = "" Then
Get_File_Path_Instr = ""
Get_Error_Data ("Get_File_Path_Instr")
Exit Function
End If
Len_PTH = Len(PTH)
File_Name = Get_BaceName_Instr(PTH)
Len_File_Name = Len(File_Name)
Kakuchoushi = Get_kakuchoushi_Instr(PTH)
Len_Kakuchoushi = Len(Kakuchoushi)
RE_PTH = Left(PTH, (Len_PTH - (Len_File_Name + Len_Kakuchoushi + 2)))
Get_File_Path_Instr = RE_PTH
Get_Error_Data ("Get_File_Path_Instr")
Exit Function
End Function
Function Get_kakuchoushi_Instr(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2018/03/02
'変更日：2018/03/02
'※ファイルの拡張子を取得する。
Dim PTH_Len As Integer 'フルパスの長さ
Dim COMMA_Point As Integer 'コンマの位置
Dim PTH_Point As Integer '拡張子の長さ
Dim PTH_OUT As String '拡張子の格納先
PTH_Len = Len(PTH) 'フルパスの長さ取得
COMMA_Point = InStrRev(PTH, ".") 'カンマの位置を右から走査して取得
PTH_Point = PTH_Len - (COMMA_Point) 'フルパスの長さからコンマ位置を差し引く
PTH_OUT = Right(PTH, PTH_Point) '右からフルパスの長さからコンマ位置を差し引いた文字文取得
Get_kakuchoushi_Instr = PTH_OUT '拡張子を返す
Get_Error_Data ("Get_kakuchoushi_Instr")
Exit Function
End Function
Function Get_BaceName_Instr(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2018/03/03
'変更日：2018/03/03
'※ファイルのベース名を取得する。
Dim PTH_Len As Integer 'フルパスの長さ
Dim COMMA_Point As Integer 'コンマの位置
Dim PTH_Point As Integer '拡張子の長さ
Dim PTH_OUT As String '拡張子の格納先
PTH_Len = Len(PTH) 'フルパスの長さ取得
COMMA_Point = InStrRev(PTH, "\") '\の位置を右から走査して取得
PTH_Point = PTH_Len - (COMMA_Point) 'フルパスの長さから\位置を差し引く
PTH_OUT = Right(PTH, PTH_Point) '右からフルパスの長さから\位置を差し引いた文字文取得
COMMA_Point = InStrRev(PTH_OUT, ".") '拡張子のカンマを取得
PTH_OUT = Left(PTH_OUT, COMMA_Point - 1) '拡張子のカンマの前迄を取得
Get_BaceName_Instr = PTH_OUT 'ファイルのベース名をを返す
Exit Function
End Function
Function Get_SQL_ST(Q_Name As String) As String
'作成者：瀧澤 禮好
'作成日：2018/06/27
'更新日：2018/06/27
'クエリのSQLを取得
Get_SQL_ST = CurrentDb.QueryDefs(Q_Name).SQL
Exit Function
End Function
Function Get_Window_Title(Get_Win_Title As String) As Boolean
'作成者：瀧澤禮好
'作成日：2018/08/14
'変更日：2018/08/14
'ウインドウのタイトルを取得する。
Dim OBJ_MS_Word As Object
Set OBJ_MS_Word = CreateObject("Word.Application") 'ワードを起動
If OBJ_MS_Word.Tasks.Exists(Get_Win_Title) Then 'ワードのタイトル取得機能で検索
'起動している
Get_Window_Title = True
Else
'起動していない
Get_Window_Title = False
End If
OBJ_MS_Word.Quit
Set OBJ_MS_Word = Nothing
Exit Function
End Function
Function CH_SQ(SG_No_N As String) As String
'作成者：瀧澤禮好
'作成日：2018/10/06
'変更日：2019/03/27
'VBA内で文字列を「’」クォーテーションで囲む(SQL文内での文字列変数)
CH_SQ = "'" & SG_No_N & "'"
Exit Function
End Function
Function Amari(Moto_Su As Integer, Jyo_Su As Integer) As Integer
'作成者：瀧澤禮好
'作成日：2019/03/27
'変更日：2019/03/27
'余りを求める（Mod関数）
'Moto_Su 元の値
'Jyo_Su 除数
Amari = Moto_Su Mod Jyo_Su
Exit Function
End Function
Option Compare Database
Option Explicit
Public OUT_TXT As String
Function Serch_Double_Chk()
'作成者：瀧澤禮好
'作成日：2019/12/20
'変更日：2019/12/20
'ファイルの有無を確認する
Dim My_Name As String
OUT_TXT = CurrentProject.Path & "\"
My_Name = CurrentProject.Name
My_Name = Get_BaceName_Instr(My_Name)
OUT_TXT = OUT_TXT & My_Name & ".TXT"
If FSO_FL_Check(OUT_TXT) = True Then
MsgBox "「" & CurrentProject.Name & "」は既に起動しています", 16
DoCmd.Quit acQuitSaveAll
Else
Call Make_Double_Chk
End If
Exit Function
End Function
Sub Make_Double_Chk()
'作成者：瀧澤禮好
'作成日：2019/12/20
'変更日：2019/12/20
Dim My_Name As String
Dim Line_No_O As String
OUT_TXT = CurrentProject.Path & "\"
My_Name = CurrentProject.Name
My_Name = Get_BaceName_Instr(My_Name)
OUT_TXT = OUT_TXT & My_Name & ".TXT"
Line_No_O = OUT_TXT
Call Print_Out_Txt(OUT_TXT, Line_No_O)
Exit Sub
End Sub
Sub Kill_Double_Chk()
'作成者：瀧澤禮好
'作成日：2019/12/20
'変更日：2019/12/20
On Error Resume Next
Dim My_Name As String
OUT_TXT = CurrentProject.Path & "\"
My_Name = CurrentProject.Name
My_Name = Get_BaceName_Instr(My_Name)
OUT_TXT = OUT_TXT & My_Name & ".TXT"
Kill OUT_TXT
Exit Sub
End Sub
Sub Print_Out_Txt(OUT_TXT As String, Line_No_O As String)
'作成者：瀧澤禮好
'作成日：2019/12/20
'変更日：2019/12/20
'テキストファイルに出力
Dim F_No As Integer
F_No = FreeFile
'Open OUT_TXT For Append As #F_No '追加きモード
Open OUT_TXT For Output As #F_No '上書きモード
Print #F_No, Line_No_O 'テキストファイルに出力
Close #F_No
Exit Sub
End Sub
Function Get_BaceName_Instr(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2019/12/20
'変更日：2019/12/20
'※ファイルのベース名を取得する。
Dim PTH_Len As Integer 'フルパスの長さ
Dim COMMA_Point As Integer 'コンマの位置
Dim PTH_Point As Integer '拡張子の長さ
Dim PTH_OUT As String '拡張子の格納先
PTH_Len = Len(PTH) 'フルパスの長さ取得
COMMA_Point = InStrRev(PTH, "\") '\の位置を右から走査して取得
PTH_Point = PTH_Len - (COMMA_Point) 'フルパスの長さから\位置を差し引く
PTH_OUT = Right(PTH, PTH_Point) '右からフルパスの長さから\位置を差し引いた文字文取得
COMMA_Point = InStrRev(PTH_OUT, ".") '拡張子のカンマを取得
PTH_OUT = Left(PTH_OUT, COMMA_Point - 1) '拡張子のカンマの前迄を取得
Get_BaceName_Instr = PTH_OUT 'ファイルのベース名をを返す
Exit Function
End Function
Function FSO_FL_Check(File_CK As String) As Boolean
'作成者：瀧澤禮好
'作成日：2019/12/20
'変更日：2019/12/20
'ファイル有無のチェック
Dim cFso As FileSystemObject 'オブジェクト変数宣言
Set cFso = New FileSystemObject '変数にオブジェクトの代入
If cFso.FileExists(File_CK) Then
FSO_FL_Check = True 'ファイル有り
Else
FSO_FL_Check = False 'ファイル無し
End If
Exit Function
End Function
Option Compare Database
Option Explicit
Public Ronri_Enzan
Sub Make_qry_PGD_DATA(Enzan_Shi As String)
'作成者：瀧澤禮好
'作成日：2019/12/20
'変更日：2019/12/20
Dim アプリケーション種別 As Variant
Dim 属性種別 As Variant
Dim 処理動作目的 As Variant
Dim コード名 As Variant
Dim コードの説明 As Variant
Dim サンプルコード As Variant
Dim Check_Flag As Long
Dim SQL_STR As String
Dim WHERE_ITEM As String
Dim アプリケーション種別_SQL As String
Dim 属性種別_SQL As String
Dim 処理動作目的_SQL As String
Dim コード名_SQL As String
Dim コードの説明_SQL As String
Dim サンプルコード_SQL As String
If Enzan_Shi = "AND" Then
Ronri_Enzan = " AND "
Else
Ronri_Enzan = " OR "
End If
アプリケーション種別_SQL = "Usys_tbl_PGD.[アプリケーション種別] =
[Forms]![frm_Serch]![cbo_アプリケーション種別]"
属性種別_SQL = " Usys_tbl_PGD.[属性種別]=[Forms]![frm_Serch]![cbo_属性種別]"
処理動作目的_SQL = " Usys_tbl_PGD.処理動作目的 Like " & "'*" &
Forms![frm_Serch]![txt_処理動作目的] & "*'"
コード名_SQL = " Usys_tbl_PGD.コード名 Like " & "'*" & Forms![frm_Serch]![txt_コード名] &
"*'"
コードの説明_SQL = " Usys_tbl_PGD.コードの説明 Like " & "'*" &
Forms![frm_Serch]![txt_コードの説明] & "*'"
サンプルコード_SQL = " Usys_tbl_PGD.サンプルコード Like " & "'*" &
Forms![frm_Serch]![txt_サンプルコード] & "*'"
'qry_PGD_DATA
SQL_STR = ""
Check_Flag = 0
アプリケーション種別 = [Forms]![frm_Serch].[Form]![cbo_アプリケーション種別]
If IsNull(アプリケーション種別) = True Then
Check_Flag = Check_Flag + 0
Else
Check_Flag = Check_Flag + 1
End If
属性種別 = [Forms]![frm_Serch].[Form]![cbo_属性種別]
If IsNull(属性種別) = True Then
Check_Flag = Check_Flag + 0
Else
Check_Flag = Check_Flag + 10
End If
処理動作目的 = [Forms]![frm_Serch].[Form]![txt_処理動作目的]
If IsNull(処理動作目的) = True Then
Check_Flag = Check_Flag + 0
Else
Check_Flag = Check_Flag + 100
End If
コード名 = [Forms]![frm_Serch].[Form]![txt_コード名]
If IsNull(コード名) = True Then
Check_Flag = Check_Flag + 0
Else
Check_Flag = Check_Flag + 1000
End If
コードの説明 = [Forms]![frm_Serch].[Form]![txt_コードの説明]
If IsNull(コードの説明) = True Then
Check_Flag = Check_Flag + 0
Else
Check_Flag = Check_Flag + 10000
End If
サンプルコード = [Forms]![frm_Serch].[Form]![txt_サンプルコード]
If IsNull(サンプルコード) = True Then
Check_Flag = Check_Flag + 0
Else
Check_Flag = Check_Flag + 100000
End If
Select Case Check_Flag
Case 0
'選択無し
GoTo ALL_ITEM
Case 1
'アプリケーション種別
WHERE_ITEM = アプリケーション種別_SQL
GoTo SELECT_ITEM
Case 10
'属性種別
WHERE_ITEM = 属性種別_SQL
GoTo SELECT_ITEM
Case 11
'属性種別+アプリケーション種別
WHERE_ITEM = 属性種別_SQL & Ronri_Enzan & アプリケーション種別_SQL
GoTo SELECT_ITEM
Case 100
'処理動作目的
WHERE_ITEM = 処理動作目的_SQL
GoTo SELECT_ITEM
Case 101
'処理動作目的+アプリケーション種別
WHERE_ITEM = 処理動作目的_SQL & Ronri_Enzan & アプリケーション種別_SQL
GoTo SELECT_ITEM
Case 110
'処理動作目的+属性種別
WHERE_ITEM = 処理動作目的_SQL & Ronri_Enzan & 属性種別_SQL
GoTo SELECT_ITEM
Case 111
'処理動作目的+属性種別+アプリケーション種別
WHERE_ITEM = 処理動作目的_SQL & Ronri_Enzan & 属性種別_SQL & Ronri_Enzan & アプリケーション種別_SQL
GoTo SELECT_ITEM
Case 1000
'コード名
WHERE_ITEM = コード名_SQL
GoTo SELECT_ITEM
Case 1001
'コード名+アプリケーション種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 1010
'コード名+属性種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 1011
'コード名+属性種別+アプリケーション種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 1111
'コード名+処理動作目的+属性種別+アプリケーション種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 10000
'コードの説明
WHERE_ITEM = コードの説明_SQL
GoTo SELECT_ITEM
Case 10001
'コードの説明+アプリケーション種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 10010
'コードの説明+属性種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 10011
'コードの説明+属性種別+アプリケーション種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 10100
'コードの説明+処理動作目的
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 10101
'コードの説明+処理動作目的+アプリケーション種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 10111
'コードの説明+処理動作目的+属性種別+アプリケーション種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 11111
'コードの説明+コード名+処理動作目的+属性種別+アプリケーション種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 100000
'サンプルコード
WHERE_ITEM = サンプルコード_SQL
GoTo SELECT_ITEM
Case 100001
'サンプルコード+アプリケーション種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 100010
'サンプルコード+属性種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 100011
'サンプルコード+属性種別+アプリケーション種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 100100
'サンプルコード+処理動作目的
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 100101
'サンプルコード+処理動作目的+アプリケーション種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 100110
'サンプルコード+処理動作目的+属性種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 100111
'サンプルコード+処理動作目的+属性種別+アプリケーション種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 101000
'サンプルコード+コード名
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 101001
'サンプルコード+コード名+アプリケーション種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 101010
'サンプルコード+コード名+属性種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 101011
'サンプルコード+コード名+属性種別+アプリケーション種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 101100
'サンプルコード+コード名+処理動作目的
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 101101
'サンプルコード+コード名+処理動作目的+アプリケーション種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 101110
'サンプルコード+コード名+処理動作目的+属性種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 101111
'サンプルコード+コード名+処理動作目的+属性種別+アプリケーション種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 110000
'サンプルコード+コードの説明
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 110001
'サンプルコード+コードの説明+アプリケーション種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 110010
'サンプルコード+コードの説明+属性種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 110011
'サンプルコード+コードの説明+属性種別+アプリケーション種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 110100
'サンプルコード+コードの説明+処理動作目的
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 110101
'サンプルコード+コードの説明+処理動作目的+アプリケーション種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 110110
'サンプルコード+コードの説明+処理動作目的+属性種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 110111
'サンプルコード+コードの説明+処理動作目的+属性種別+アプリケーション種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 111000
'サンプルコード+コードの説明+コード名
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 111001
'サンプルコード+コードの説明+コード名+アプリケーション種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 111010
'サンプルコード+コードの説明+コード名+属性種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 111011
'サンプルコード+コードの説明+コード名+属性種別+アプリケーション種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 111100
'サンプルコード+コードの説明+コード名+処理動作目的
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 111101
'サンプルコード+コードの説明+コード名+処理動作目的+アプリケーション種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 111110
'サンプルコード+コードの説明+コード名+処理動作目的+属性種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case 111111
'サンプルコード+コードの説明+コード名+処理動作目的+属性種別+アプリケーション種別
WHERE_ITEM = ""
GoTo SELECT_ITEM
Case Else
'エラー
End Select
SELECT_ITEM:
Make_Query:
'qry_紹介案件管理_All
SQL_STR = " SELECT * " _
& " FROM Usys_tbl_PGD" _
& " WHERE " & WHERE_ITEM & ";"
Debug.Print SQL_STR
Debug.Print Check_Flag
CurrentDb.QueryDefs("qry_PGD_DATA").SQL = SQL_STR
Exit Sub
ALL_ITEM:
'qry_紹介案件管理_All
SQL_STR = " SELECT * " _
& " FROM Usys_tbl_PGD;"
CurrentDb.QueryDefs("qry_PGD_DATA").SQL = SQL_STR
'Debug.Print SQL_STR
'Debug.Print Check_Flag
Exit Sub
End Sub
Function DQ(IT As String) As String
'作成者：瀧澤禮好
'作成日：2019/12/20
'変更日：2019/12/20
DQ = "'" & IT & "'"
Exit Function
End Function
Function Create_Link_Table(PTH As Variant, Moto_TBL As Variant, Saki_TBL As
Variant) As Boolean
'PTH リンク元のフルパスのAccessDB名（拡張子付き）
'Moto_TBL リンク元のテーブル名
'Saki_TBL リンク先のテーブル名
Dim db As DAO.Database
Dim tbldf As DAO.TableDef
Set db = CurrentDb
Set tbldf = db.CreateTableDef(Saki_TBL) 'リンク先
tbldf.Connect = ";DATABASE=" & PTH & ";TABLE=" & Moto_TBL 'リンク元
tbldf.SourceTableName = Moto_TBL 'リンク元"
db.TableDefs.Append tbldf
Set tbldf = Nothing: Set db = Nothing
Application.RefreshDatabaseWindow
Create_Link_Table = True
Exit Function
Err_Task:
Create_Link_Table = False
Exit Function
End Function
Option Compare Database
Option Explicit
Public Function Tbl_Re_Conec(PTH As String, DB_Name As String, Tb_Name As
String) As Boolean
'作成日：2017/09/15
'更新日：2017/09/15
'作成者：瀧澤 禮好
'DAO.を使ってハードリンクの再設定を行う。
'参照設定でDAOをチェックする事。
'ODBC接続や複数のmdb接続で一括でハードリンクが変更出来ない場合に、リンクするテーブルを指定して実施。
'関数化しているので、フルパス、mdb名、テーブル名を引数に記述して連続して動かす事も可能。
'※事前にハードリンクのテーブルが設定してある事。
On Error GoTo Error_Task
Dim db As DAO.Database
Dim tb As DAO.TableDef
Dim str_CN_MDB_Name As String
Dim chk As String
chk = Right(PTH, 1)
If chk <> "\" Then
PTH = PTH & "\"
End If
Set db = CurrentDb
Set tb = db.TableDefs(Tb_Name)
str_CN_MDB_Name = ";DATABASE=" & PTH & DB_Name & ";TABLE=" & Tb_Name
tb.Connect = str_CN_MDB_Name
tb.RefreshLink ' リンク情報の更新
Tbl_Re_Conec = True
Exit Function
Error_Task:
Tbl_Re_Conec = False
Exit Function
End Function
Sub ccc()
If Tbl_Re_Conec("C:\Access_Back_End\テレビ番組記録", "テレビ番組記録be.mdb", "tbl_テレビ録画") =
True Then
Else
MsgBox "1"
End If
If Tbl_Re_Conec("C:\Access_Back_End\テレビ番組記録", "テレビ番組記録be.mdb", "tbl_特記事項") =
True Then
Else
MsgBox "2"
End If
MsgBox "ccc ok!"
End Sub
Sub ooo()
If Tbl_Re_Conec("O:\BackUp\Access_Back_End\テレビ番組記録", "テレビ番組記録be.mdb",
"tbl_テレビ録画") = True Then
Else
MsgBox "1"
End If
If Tbl_Re_Conec("O:\BackUp\Access_Back_End\テレビ番組記録", "テレビ番組記録be.mdb",
"tbl_特記事項") = True Then
Else
MsgBox "2"
End If
MsgBox "ddd ok!"
End Sub
Function FSO_DR_Check(Folder_CK As String) As Boolean
'作成者：瀧澤禮好
'作成日：2017/09/16
'変更日：2017/09/16
'ドライブ有無のチェック
Dim cFso As FileSystemObject 'オブジェクト変数宣言
Set cFso = New FileSystemObject '変数にオブジェクトの代入
If cFso.DriveExists(Folder_CK) Then
FSO_DR_Check = True 'ドライブ有り
Else
FSO_DR_Check = False 'ドライブ無し
End If
End Function
Option Compare Database
Option Explicit
Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA"
( _
ByVal hwnd As Long, _
ByVal pszPath As String, _
ByVal psa As Long) As Long
Public Function MkFolder(FL As String) As Boolean
'作成者：瀧澤禮好
'作成日：2016/07/15
'変更日：2016/08/18
'多重層のフォルダ作成
'フォルダの存在確認
If FSO_PH_Check(FL) = True Then
MkFolder = True
Else
'多重層のフォルダ作成
Dim RC As Long
Dim Target As String
Target = FL
RC = SHCreateDirectoryEx(0&, Target, 0&)
If RC = 0 Then
'正常終了
MkFolder = True
Else
'異常終了
MkFolder = False
End If
End If
Get_Error_Data ("MkFolder")
End Function
Public Function Make_Folder(FL As String) As Boolean
'作成者：瀧澤禮好
'作成日：2016/07/15
'変更日：2016/07/27
'多重層のフォルダ作成
'フォルダの存在確認
If FSO_PH_Check(FL) = True Then
Make_Folder = True
Else
'多重層のフォルダ作成
Dim RC As Long
Dim Target As String
Target = FL
RC = SHCreateDirectoryEx(0&, Target, 0&)
If RC = 0 Then
'正常終了
Make_Folder = True
Else
'異常終了
Make_Folder = False
End If
End If
Get_Error_Data ("Make_Folder")
End Function
Public Function PC_Name_Get() As String
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'コンピュータ名の取得
Dim PC As String
PC = Environ("ComputerName") '環境変数の取得
PC_Name_Get = PC
Get_Error_Data ("PC_Name_Get")
End Function
Public Function User_Name_Get() As String
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'ユーザー名の取得
Dim User_Name
User_Name = Environ("UserName") '環境変数の取得
User_Name_Get = User_Name
Get_Error_Data ("User_Name_Get")
End Function
Public Function OS_Name_Get() As String
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'OS名の取得
Dim OS_Name
OS_Name = Environ("OS") '環境変数の取得
OS_Name_Get = OS_Name
Get_Error_Data ("OS_Name_Get")
End Function
Function Get_Time_Stamp(File_Name As String) As String
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'ファイルデータスタンプ（更新日時）の取得
Dim GTS As String
GTS = FileDateTime(File_Name)
Get_Time_Stamp = GTS
Get_Error_Data ("Get_Time_Stamp")
End Function
Function Get_ClipBord0(String_Data As String) As Boolean
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'クリップボードにコピー
'※参照設定でFM2.0オブジェクトライブラリをチェックする
'格納場所（64bit）⇒c:\windows\syswow64\fm20.dll
On Error GoTo Err_Tasc
Dim CB0 As String
CB0 = String_Data
With New MSForms.DataObject
.SetText CB0 '変数の値をオブジェクトに代入
.PutInClipboard 'クリップボードにコピー
End With
Get_ClipBord0 = True
Get_Error_Data ("Get_ClipBord0")
Exit Function
Err_Tasc:
Get_ClipBord0 = False
Get_Error_Data ("Get_ClipBord0")
Exit Function
End Function
Public Function GetCurBD(BDate As Variant) As Variant
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'概要 誕生日より今日現在の年齢を計算します
'引数 BDate : 誕生日
'返り値 年齢(誕生日がNullのときはNullを返します)
Dim GetBD As Variant
If Not IsNull(BDate) Then
'引数の誕生日が指定されているとき
'誕生日と今日の日付の年の差を年齢とする
GetBD = DateDiff("yyyy", BDate, Date)
If DateSerial(Year(Date), Month(BDate), Day(BDate)) > Date Then
'その年の誕生日がまだ来ていないときはマイナス１する
GetBD = GetBD - 1
End If
Else
'引数の誕生日が指定されていないときはNullを設定
GetBD = Null
End If
'返り値を設定
GetCurBD = GetBD
Get_Error_Data ("GetCurBD")
End Function
Function FSO_PH_Check(Folder_CK As String) As Boolean
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'フォルダー有無のチェック
Dim cFso As FileSystemObject 'オブジェクト変数宣言
Set cFso = New FileSystemObject '変数にオブジェクトの代入
If cFso.FolderExists(Folder_CK) Then
FSO_PH_Check = True 'フォルダー有り
Else
FSO_PH_Check = False 'フォルダー無し
End If
Get_Error_Data ("FSO_PH_Check")
End Function
Function FSO_FL_Check(File_CK As String) As Boolean
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'ファイル有無のチェック
Dim cFso As FileSystemObject 'オブジェクト変数宣言
Set cFso = New FileSystemObject '変数にオブジェクトの代入
If cFso.FileExists(File_CK) Then
FSO_FL_Check = True 'ファイル有り
Else
FSO_FL_Check = False 'ファイル無し
End If
Get_Error_Data ("FSO_FL_Check")
End Function
Function Make_Fl(Folder As String) As Boolean
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'フォルダーの作成
On Error GoTo ERROR_TASK
Dim MFL As String
Dim ct As Integer
ct = Len(Folder)
ct = ct - 1
MFL = Left(Folder, ct)
MkDir (MFL)
Make_Fl = True
Get_Error_Data ("Make_Fl")
Exit Function
ERROR_TASK:
Make_Fl = False
Get_Error_Data ("Make_Fl")
Exit Function
End Function
Function Week_Day_Name(WN As Date) As String
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'曜日の取得
Dim Week_Name As String
Week_Name = WeekdayName(Weekday(WN))
Week_Day_Name = Week_Name
Get_Error_Data ("Week_Day_Name")
End Function
Public Function FDFolderPicker()
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'[参照] ダイアログ ボックスの FileDialog オブジェクトを作成します。
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
'選択した各アイテムのパスを保存す変数を宣言します。
Dim vrtSelectedItem As Variant
'プロパティの設定
With fd
.Title = "ファイルダイアログ（フォルダ参照）"
.InitialView = msoFileDialogViewDetails
.InitialFileName = CurrentProject.Path
'[参照] ダイアログ ボックスを表示します。
If .Show = -1 Then
'ユーザーがアクション ボタンをクリックした場合
For Each vrtSelectedItem In .SelectedItems
FDFolderPicker = vrtSelectedItem
Next vrtSelectedItem
Else
'ユーザーが [キャンセル] をクリックした場合
End If
End With
'オブジェクトの変数に Nothing を設定します。
Set fd = Nothing
Get_Error_Data ("FDFolderPicker")
End Function
Public Function FDFilePicker()
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'[参照] ダイアログ ボックスの FileDialog オブジェクトを作成します。
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'選択した各アイテムのパスを保存す変数を宣言します。
Dim vrtSelectedItem As Variant
'プロパティの設定
With fd
.Title = "ファイルダイアログ（ファイル参照）"
.InitialFileName = CurrentProject.Path
'フィルターの設定
.Filters.Clear
.Filters.Add "テキスト", "*.txt; *.csv"
.Filters.Add "エクセル", "*.xls"
.Filters.Add "Access", "*.mdb;*.accdb"
.Filters.Add "イメージ", "*.gif; *.jpg; *.jpeg"
.Filters.Add "すべてのファイル", "*.*"
.FilterIndex = 5
.InitialView = msoFileDialogViewDetails
.AllowMultiSelect = False
'[参照] ダイアログ ボックスを表示します。
If .Show = -1 Then
'ユーザーがアクション ボタンをクリックした場合
For Each vrtSelectedItem In .SelectedItems
FDFilePicker = vrtSelectedItem
Next vrtSelectedItem
Else
'ユーザーが [キャンセル] をクリックした場合
End If
End With
'オブジェクトの変数に Nothing を設定します。
Set fd = Nothing
Get_Error_Data ("FDFilePicker")
End Function
Function Get_Base_Name(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'※ファイルのベースネームを取得する。
'FSOを利用するので、「MicroSoft Scripting Runtime」の参照設定が必須！
Dim objFileSys As Object
Dim strPath As String
Set objFileSys = CreateObject("Scripting.FileSystemObject")
strPath = objFileSys.GetBaseName(PTH)
Get_Base_Name = strPath
Set objFileSys = Nothing
Get_Error_Data ("Get_Base_Name")
End Function
Function Get_kakuchoushi(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'※ファイルの拡張子を取得する。
'FSOを利用するので、「MicroSoft Scripting Runtime」の参照設定が必須！
Dim objFileSys As Object
Dim strPath As String
Set objFileSys = CreateObject("Scripting.FileSystemObject")
strPath = objFileSys.GetExtensionName(PTH)
Get_kakuchoushi = strPath
Set objFileSys = Nothing
Get_Error_Data ("Get_kakuchoushi")
End Function
Function Hankaku(STR_STR As String) As String
'参照設定「Microsoft Script Regular Expressions 5.5」
'正規表現を使って検索、抽出した文字列を返す。
'作成者：瀧澤禮好
'作成日：2016/10/09
'更新日：2016/10/09
On Error Resume Next
'正規表現で半角文字検索
Dim strSample
Dim regPattern
Dim colMatches
Dim objMatch
Dim Seiki_Str As String
Dim Kekka As String
'正規表現のパターンを設定
Seiki_Str = "[a-zA-Z]" '
'文字列変数「Kekka」の初期化
Kekka = ""
strSample = STR_STR
Set regPattern = New RegExp
regPattern.Pattern = Seiki_Str '検索の正規表現
regPattern.Global = True
Set colMatches = regPattern.Execute(strSample)
For Each objMatch In colMatches
Kekka = Kekka & objMatch
Next
Dim CN As Long
CN = Len(Kekka)
If CN = 0 Then
Hankaku = "見つかりませんでした！"
Else
Hankaku = Kekka
End If
Exit Function
End Function
Sub Re_Conect()
'作成者：瀧澤禮好
'作成日：2016/10/31
'更新日：2016/10/31
On Error GoTo Err_Job
'データMDBにリンクを更新します。
'リンク更新失敗したら Access終了します。
'===============================================
Dim strIniFile As String
Dim strIniFile_Chk As String
Dim kakuchoushi As String
Dim str_CN_MDB_Name As String
Dim TBL_RE_CNT As TableDef
Dim boo_CNT_UP As Boolean
Dim Pass_Word As String
Pass_Word = ";pwd=" & "ut-kokuzou.jp"
str_CN_MDB_Name = FDFilePicker
strIniFile_Chk = Get_Base_Name(str_CN_MDB_Name)
kakuchoushi = "." & Get_kakuchoushi(str_CN_MDB_Name)
strIniFile_Chk = strIniFile_Chk & kakuchoushi
If (MsgBox("リンク先MDBは「" & str_CN_MDB_Name & "」です。OKですか？？", 36) = 7) Then
Get_Error_Data ("Re_Conect")
Exit Sub
End If
'接続ファイル名の確認
If strIniFile_Chk = "健康管理記録蓄積be.mdb" Then
GoTo PSW_CK
Else
MsgBox "選択したファイルはリンクMDBではありません！", 48
Get_Error_Data ("Re_Conect")
Exit Sub
End If
PSW_CK:
'パスワードの有無
If (MsgBox("バックエンドにパスワードが付いていますか？？", 36) = 7) Then
GoTo CH_CNT
Else
Pass_Word = InputBox("パスワードを入力してください！", "Re_Conect", "*****")
If Pass_Word = "" Then
GoTo PSW_CK
End If
Pass_Word = ";pwd=" & Pass_Word
str_CN_MDB_Name = str_CN_MDB_Name & Pass_Word
End If
CH_CNT:
' データベースのすべてのテーブルをループします。
For Each TBL_RE_CNT In CurrentDb.TableDefs
' テーブルに接続文字列があるとき
If Len(TBL_RE_CNT.Connect) > 0 Then
TBL_RE_CNT.Connect = _
";DATABASE=" & str_CN_MDB_Name
' テーブルのリンクを更新
Err = 0
On Error Resume Next
TBL_RE_CNT.RefreshLink
'エラーがあったら
If Err <> 0 Then
MsgBox TBL_RE_CNT.Name & _
Err.Description, vbCritical, _
"リンク更新失敗"
Application.Quit 'Access終了
End If
End If
Next TBL_RE_CNT
MsgBox "リンク再接続が完了しました！", 64
END_JOB:
Get_Error_Data ("Re_Conect")
Exit Sub
Err_Job:
MsgBox "システムエラーです！システム担当者に連絡してください！", 16
Get_Error_Data ("Re_Conect")
Exit Sub
End Sub
Sub Make_BAT(CSV_File_Name As String, STR_Grep As String)
'作成者：瀧澤 禮好
'作成日：2020/02/08
'更新日：2020/02/08
'「法人番号」の元データCSVを「Get_Select_Data.csv」に名前を変えてコピーするバッチを作成して起動。
Dim Input_File As String
Dim Output_File As String
Dim BAT_File As String
Dim File_Name As String
Dim FSobj As Object
Dim WshShell As Object
'一行目はヘッダー、二行目以降は抽出データ
Input_File = CSV_File_Name
Output_File = CurrentProject.Path & "\Get_Select_Data.csv"
'前に使ったファイルを削除
On Error Resume Next
Kill Output_File
'正規表現でヘッダーとデータを抽出
BAT_File = "Findstr " & ".*媒体名.* " & Input_File & " > " & Output_File _
& vbCrLf & "Findstr " & ".*" & STR_Grep & ".* " & Input_File & " >> " &
Output_File
Set FSobj = CreateObject("Scripting.FileSystemObject")
File_Name = CurrentProject.Path & "\Copy_CSV.bat"
Set FSobj = FSobj.OpenTextFile(File_Name, 8, True)
FSobj.WriteLine BAT_File
Set FSobj = Nothing
Set WshShell = CreateObject("Wscript.Shell")
WshShell.Run "" & File_Name & "", 1, True
'0,非表示
'1,通常のウィンドウ（アクティブ）
'2,最小化のウィンドウ（アクティブ）
'3,最大化のウィンドウ（アクティブ）
'4,通常のウィンドウ（非アクティブ）
'5,現在のサイズのウィンドウ（アクティブ）
'6,非アクティブな最小化ウィンドウ
' 7,最小化ウィンドウ（アクティブなウィンドウは変更されない）
'8,現在のサイズのウィンドウ（アクティブなウィンドウは変更されない）
'9,元のサイズのウィンドウ（アクティブ）
'10,プログラムの状態により表示を決定
Set WshShell = Nothing
'起動し終えたバッチファイルを削除
Kill CurrentProject.Path & "\Copy_CSV.bat"
Exit Sub
End Sub
Function Make_PDF(PTH_Excel As String, PTH_PDF As String, WS_N As String) As
Boolean
'作成者：瀧澤禮好
'作成日：2018/10/08
'変更日：2018/11/15
'PTH_Excel:PDF変換するExcelのフルパス（フォロルダ、ファイル名、拡張子まで総て）
PTH_PDF:変換したPDFのフルパス（フォロルダ、ファイル名、拡張子まで総て） WS_N:エクセルのワークシート名
'保存したExcelブックをPDFに印刷する。
DoEvents 'OSへメモリを移す。
On Error GoTo Error_Job
Dim APP_Excel As Excel.Application 'アプリケーション変数の宣言
Dim Excek_WBK As Excel.Workbook 'ワークブック変数の宣言
Dim Excek_WST As Excel.Worksheet 'ワークシート変数の宣言
Dim F_Name As String '保存先フォルダパス＆ファイル名
F_Name = PTH_PDF
Set APP_Excel = CreateObject("Excel.Application") '実行時バインディング
Set Excek_WBK = APP_Excel.Workbooks.Open(PTH_Excel) '既存ワークブックのオープン
Set Excek_WST = Excek_WBK.Worksheets(WS_N) 'ワークシート変数にWorksheets(WS_N)を設定
APP_Excel.Worksheets(WS_N).Select 'ワークシート変数にWorksheets(WS_N)を設定
'アクティブになったシートをPDFに変換する。
APP_Excel.ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=F_Name
'このステータスで「実行時エラー:1004」が発生する場合がある（原因は不明）
'上記ステートメントで「実行時エラー:1004」が発生してもPDFは作成される事を確認（2018/11/15）。
'アクティブなブックを閉じる。
APP_Excel.ActiveWorkbook.Close
Set Excek_WST = Nothing
Set Excek_WBK = Nothing
APP_Excel.Quit 'アプリケーションの終了
Set APP_Excel = Nothing 'メモリーの解放
DoEvents 'OSへメモリを移す。
Make_PDF = True
Exit Function
Error_Job:
'Debug.Print Err.Number
'実行時エラー1004対応
'アクティブなブックを閉じる。
APP_Excel.ActiveWorkbook.Close
Set Excek_WST = Nothing
Set Excek_WBK = Nothing
APP_Excel.Quit 'アプリケーションの終了
Set APP_Excel = Nothing 'メモリーの解放
DoEvents 'OSへメモリを移す。
Make_PDF = False
Exit Function
End Function
--------------------------------------------------------------------------------
ADOトランザクション処理：
参照設定：
コード：
Public Function Get_PGD_Data() As Boolean
'作成者：瀧澤禮好
'作成日：2016/04/27
'変更日：2016/07/12
'「frm_MAIN」フォームのオープン(新検索ロジック用：2016/07/12)
'DoCmd.OpenForm "frm_MAIN", acNormal, "", "", , acNormal
'ADOでのレコードセットによるフォームへのデータ添付
On Error GoTo Error_JOB
'**********ADOによるDB接続「Usys_tbl_PGD」**********
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Set cn = CurrentProject.Connection
Set rs = New ADODB.Recordset
cn.BeginTrans 'トランザクション(ADO)開始
rs.CursorType = adOpenKeyset
rs.Open "Usys_tbl_PGD", cn
'**********検索設定**********
Dim kensaku_key As Variant
kensaku_key = [Forms]![frm_PGD].[frm_PGD_DATA].[Form]![ID]
rs.MoveFirst '最初のレコードに移動
rs.Find "[ID] ='" & kensaku_key & " '" 'IDを検索
If rs.EOF Then
'**********切断「Usys_tbl_PGD」**********
rs.Close
cn.CommitTrans 'トランザクション(ADO)正常終了
Set rs = Nothing
cn.Close
Set cn = Nothing
Exit Function
Else
'**********「frm_MAIN」への転記**********
[Forms]![frm_MAIN]![txt_ID] = rs![ID]
[Forms]![frm_MAIN]![cbo_アプリケーション種別] = rs![アプリケーション種別]
[Forms]![frm_MAIN]![cbo_属性種別] = rs![属性種別]
[Forms]![frm_MAIN]![txt_処理動作目的] = rs![処理動作目的]
[Forms]![frm_MAIN]![txt_コード名] = rs![コード名]
[Forms]![frm_MAIN]![txt_コードの説明] = rs![コードの説明]
[Forms]![frm_MAIN]![txt_サンプルコード] = rs![サンプルコード]
[Forms]![frm_MAIN]![txt_ハイパーリンク] = rs![ハイパーリンク]
'**********切断「Usys_tbl_PGD」**********
rs.Close
cn.CommitTrans 'トランザクション(ADO)正常終了
Set rs = Nothing
cn.Close
Set cn = Nothing
End If
[Forms]![frm_MAIN]![cmd_ADD_UPDATE].Caption = "更新(&U:)"
Call Len_Str
Get_PGD_Data = True
Exit Function
Error_JOB:
rs.Close
cn.RollbackTrans 'トランザクション(ADO)異常終了
Set rs = Nothing
cn.Close
Set cn = Nothing
Get_PGD_Data = False
End Function
DAOトランザクション処理：
参照設定：
コード：
Public Function DAO_TRANS(SQL_STR As String) As Boolean
'作成者：瀧澤禮好
'作成日：2022/05/05
'変更日：2022/05/05
'カレントDBでのトランザクション処理(DAO)
Dim DAO_WKS As DAO.Workspace 'Workspaceオブジェクト格納場所
Dim DAO_DB As DAO.Database
Set DAO_WKS = DAO.DBEngine.Workspaces(0) 'Workspaceオブジェクトを取得
Set DAO_DB = CurrentDb()
On Error GoTo ERROR_TRANS 'トランザクション処理中にエラーが発生したらERR_TRANSへ
DAO_WKS.BeginTrans 'トランザクション開始
DAO_DB.Execute SQL_STR
DAO_WKS.CommitTrans '全てのトランザクションを反映させる
DAO_TRANS = True
Exit Function 'プロシージャ終了
ERROR_TRANS: 'トランザクションエラー処理
DAO_WKS.Rollback 'トランザクションを中止
DAO_TRANS = False
MsgBox "エラー", 16, "" 'エラーメッセージを表示
End Function
テーブルハードリンク：
テーブル構造：
Usys_Table_Name_XX
ID オートナンバー型
テーブル名 短いテキスト
テーブル名m 短いテキスト
リンクファイル 短いテキスト
参照設定：
コード：
Sub Create_Link_Table(PTH As Variant, Moto_TBL As Variant, Saki_TBL As Variant)
'作成者：瀧澤禮好
'作成日：2022/07/29
'更新日：2022/07/29
'自動ハードリンク
'PTH リンク元のフルパスのAccessDB名（拡張子付き）
'Moto_TBL リンク元のテーブル名
'Saki_TBL リンク先のテーブル名
Dim db As DAO.Database
Dim tbldf As DAO.TableDef
Set db = CurrentDb
Set tbldf = db.CreateTableDef(Saki_TBL) 'リンク先
tbldf.Connect = ";DATABASE=" & PTH & ";TABLE=" & Moto_TBL 'リンク元
tbldf.SourceTableName = Moto_TBL 'リンク元"
db.TableDefs.Append tbldf
Set tbldf = Nothing: Set db = Nothing
Application.RefreshDatabaseWindow
Exit Sub
End Sub
Sub Link_Table()
'作成者：瀧澤禮好
'作成日：2021/12/04
'変更日：2021/12/04
'自動ハードリンク
Dim For_cnt As Integer
Dim cnt As Integer
Dim Feeld_Name As String
Dim File_Name As String
Dim Feeld_NameX As String
On Error Resume Next
DoCmd.SetWarnings False
cnt = DCount("ID", "Usys_Table_Name_XX")
For For_cnt = 1 To cnt
DoEvents
Feeld_Name = DLookup("テーブル名m", "Usys_Table_Name_XX", "ID=" & For_cnt)
Feeld_NameX = DLookup("テーブル名", "Usys_Table_Name_XX", "ID=" & For_cnt)
File_Name = DLookup("リンクファイル", "Usys_Table_Name_XX", "ID=" & For_cnt)
DoCmd.DeleteObject acTable, Feeld_Name 'リンクテーブルの削除
Call Create_Link_Table(File_Name, Feeld_Name, Feeld_NameX) 'テーブルのリンク
Next For_cnt
End Sub
Sub Disconnect_Table()
'作成者：瀧澤禮好
'作成日：2021/12/04
'変更日：2021/12/04
Dim For_cnt As Integer
Dim cnt As Integer
Dim Feeld_Name As String
Dim File_Name As String
On Error Resume Next
DoCmd.SetWarnings False
cnt = DCount("ID", "Usys_Table_Name_XX")
For For_cnt = 1 To cnt
DoEvents
Feeld_Name = DLookup("テーブル名", "Usys_Table_Name_XX", "ID=" & For_cnt)
File_Name = DLookup("リンクファイル", "Usys_Table_Name_XX", "ID=" & For_cnt)
DoCmd.DeleteObject acTable, Feeld_Name 'リンクテーブルの削除
Next For_cnt
'MsgBox "OK!"
Exit Sub
End Sub
Function CSV_Link(Moto_CSV As String, Saki_Table As String) As Boolean
'作成者：瀧澤禮好
'作成日：2022/08/16
'変更日：2022/08/16
'On Error GoTo Error_Task
DoCmd.SetWarnings False
DoCmd.DeleteObject acTable, Saki_Table
'CSVファイルをテーブルとして、ハードリンクする。
DoCmd.TransferText acLinkDelim, "", Saki_Table, Moto_CSV, True, "" 'ヘッダー有り(True)
CSV_Link = True
Exit Function
Error_Task:
CSV_Link = False
Exit Function
End Function
Sub Table_Copy()
'作成者：瀧澤禮好
'作成日：2022/07/29
'更新日：2022/07/29
'テーブルのコピー
On Error Resume Next
DoCmd.SetWarnings False
DoCmd.DeleteObject acTable, "Usys_tbl_Houjin_No_Sabun_x"'テーブルの削除
DoCmd.CopyObject "", "Usys_tbl_Houjin_No_Sabun_x", acTable, "tbl_00"'テーブルのコピー
Exit Sub
End Sub
ファイルダイアログ表示：
参照設定：
コード：
Public Function FDFilePicker()
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'[参照] ダイアログ ボックスの FileDialog オブジェクトを作成します。
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'選択した各アイテムのパスを保存す変数を宣言します。
Dim vrtSelectedItem As Variant
'プロパティの設定
With fd
.Title = "ファイルダイアログ（ファイル参照）"
.InitialFileName = CurrentProject.Path
'フィルターの設定
.Filters.Clear
.Filters.Add "テキスト", "*.txt; *.csv"
.Filters.Add "エクセル", "*.xls"
.Filters.Add "Access", "*.mdb;*.accdb"
.Filters.Add "イメージ", "*.gif; *.jpg; *.jpeg"
.Filters.Add "すべてのファイル", "*.*"
.FilterIndex = 5
.InitialView = msoFileDialogViewDetails
.InitialFileName = CurrentProject.Path
.AllowMultiSelect = False
'[参照] ダイアログ ボックスを表示します。
If .Show = -1 Then
'ユーザーがアクション ボタンをクリックした場合
For Each vrtSelectedItem In .SelectedItems
FDFilePicker = vrtSelectedItem
Next vrtSelectedItem
Else
'ユーザーが [キャンセル] をクリックした場合
End If
End With
'オブジェクトの変数に Nothing を設定します。
Set fd = Nothing
'Get_Error_Data ("FDFilePicker")
End Function
フォルダーダイアログ表示：
参照設定：
コード：
Public Function FDFolderPicker()
'作成者：瀧澤禮好
'作成日：2022/08/16
'変更日：2022/08/16
'[参照] ダイアログ ボックスの FileDialog オブジェクトを作成します。
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
'選択した各アイテムのパスを保存す変数を宣言します。
Dim vrtSelectedItem As Variant
'プロパティの設定
With fd
.Title = "ファイルダイアログ（フォルダ参照）"
.InitialView = msoFileDialogViewDetails
.InitialFileName = CurrentProject.Path
'[参照] ダイアログ ボックスを表示します。
If .Show = -1 Then
'ユーザーがアクション ボタンをクリックした場合
For Each vrtSelectedItem In .SelectedItems
FDFolderPicker = vrtSelectedItem
Next vrtSelectedItem
Else
'ユーザーが [キャンセル] をクリックした場合
End If
End With
'オブジェクトの変数に Nothing を設定します。
Set fd = Nothing
End Function
フォルダー作成：
参照設定：
API呼び出しコード：
Declare PtrSafe Function SHCreateDirectoryEx Lib "shell32" Alias
"SHCreateDirectoryExA" ( _
ByVal hwnd As Long, _
ByVal pszPath As String, _
ByVal psa As Long) As Long
コード：
Public Function Make_Folder(FL As String) As Boolean
'作成者：瀧澤禮好
'作成日：2016/07/15
'変更日：2016/07/27
'多重層のフォルダ作成
'フォルダの存在確認
If FSO_PH_Check(FL) = True Then
Make_Folder = True
Else
'多重層のフォルダ作成
Dim rc As Long
Dim Target As String
Target = FL
rc = SHCreateDirectoryEx(0&, Target, 0&)
If rc = 0 Then
'正常終了
Make_Folder = True
Else
'異常終了
Make_Folder = False
End If
End If
'Get_Error_Data ("Make_Folder")
End Function
スリープ：
参照設定：
API呼び出しコード：
コード：
正規表現：
参照設定：
「Microsoft Script Regular Expressions 5.5」
コード：
Function Seiki_Hyougen(STR_STR As String, Seiki_Str As String) As String
'参照設定「Microsoft Script Regular Expressions 5.5」
'正規表現を使って検索、抽出した文字列を返す。
'作成者：瀧澤禮好
'作成日：2021/12/04
'変更日：2021/12/04
On Error Resume Next
'正規表現で半角文字検索
Dim strSample
Dim regPattern
Dim colMatches
Dim objMatch
Dim Kekka As String
'正規表現のパターンを設定
'文字列変数「Kekka」の初期化
Kekka = ""
strSample = STR_STR
Set regPattern = New RegExp
regPattern.Pattern = Seiki_Str '検索の正規表現
'regPattern.Global = True
regPattern.Global = False
Set colMatches = regPattern.Execute(strSample)
For Each objMatch In colMatches
Kekka = Kekka & objMatch
Next
Dim CN As Long
CN = Len(Kekka)
If CN = 0 Then
Seiki_Hyougen = "No Data"
Else
Seiki_Hyougen = Kekka
End If
Exit Function
End Function
VBA内で文字列を「’」クォーテーションで囲む(SQL文内での文字列変数)]
参照設定：
コード：
Function CH_SQ(SG_No_N As String) As String
'作成者：瀧澤禮好
'作成日：2022/07/29
'更新日：2022/07/29
'VBA内で文字列を「’」クォーテーションで囲む(SQL文内での文字列変数)
CH_SQ = "'" & SG_No_N & "'"
Exit Function
End Function
タイムスタンプ：
参照設定：
コード：
Function Get_Now() As String
'作成者：瀧澤禮好
'作成日：2022/07/31
'更新日：2022/07/31
Get_Now = Format(Now, "yyyymmddhhnnss")
Exit Function
End Function
タスクの実行：
参照設定：
コード：
Function Kick_Job(File_Name As String) As Boolean
'作成者：瀧澤禮好
'作成日：2022/08/16
'変更日：2022/08/16
'タスクの実行
On Error GoTo Error_Task
Dim JOB_RUN '変数型は不明
'Shell関数で「Rundll32.exe」を呼び出してタスクの実行
JOB_RUN = Shell("Rundll32.exe url.dll,FileProtocolHandler" & " " & File_Name,
vbNormalFocus)
Kick_Job = True
Exit Function
Error_Task:
Kick_Job = False
Exit Function
End Function
ナビゲーションウィンドウを非表示にする：
参照設定：
コード：
'ナビゲーションウィンドウを非表示にする
'DoCmd.SelectObject acForm, "", True
'DoCmd.RunCommand acCmdWindowHide
ADOでのレコードセットによるフォームへのデータ添付：
参照設定：
コード：
Public Function View_Rireki(tbl_Name As String, tbl_cnt As Variant) As Boolean
'作成者：瀧澤禮好
'作成日：2022/02/05
'変更日：2022/02/05
'ADOでのレコードセットによるフォームへのデータ添付
'On Error GoTo Error_JOB
'**********ADOによるDB接続「tbl_Name」**********
DoEvents
Dim CN As ADODB.Connection
Dim rs As ADODB.Recordset
Set CN = CurrentProject.Connection 'カレントDBへの接続
Set rs = New ADODB.Recordset
CN.BeginTrans 'トランザクション(ADO)開始
rs.CursorType = adOpenKeyset 'キーセットカーソル
rs.Open tbl_Name, CN
'**********検索設定**********
'Dim kensaku_key As Variant
Dim kensaku_key As Variant
kensaku_key = tbl_cnt '[Forms]![frm_View_Fram].[frm_Data_All].[Form]![法人番号]
rs.MoveFirst '最初のレコードに移動
rs.Find "[ID] ='" & kensaku_key & " '" '項番を検索
If rs.EOF Then
'**********切断「tbl_Name」**********
rs.Close
CN.CommitTrans 'トランザクション(ADO)正常終了
Set rs = Nothing
CN.Close
Set CN = Nothing
Exit Function
Else
'**********「frm_Open_Rec」への転記**********
[Forms]![frm_変更履歴_Update]![txt_一連番号] = rs![Id]
[Forms]![frm_変更履歴_Update]![txt_法人番号] = rs![法人番号]
[Forms]![frm_変更履歴_Update]![txt_変更履歴] = rs![変更履歴]
'**********切断「Usys_tbl_PGD」**********
rs.Close
CN.CommitTrans 'トランザクション(ADO)正常終了
Set rs = Nothing
CN.Close
Set CN = Nothing
End If
View_Rireki = True
Exit Function
Error_JOB:
rs.Close
CN.RollbackTrans 'トランザクション(ADO)異常終了
Set rs = Nothing
CN.Close
Set CN = Nothing
View_Rireki = False
End Function
最適化：
参照設定：
コード：
Function Saitekika(PTH As String) As Boolean
'作成者：瀧澤禮好
'作成日：2018/02/03
'変更日：2021/05/21
DoCmd.SetWarnings False '応答メッセージ省略
Dim mdb_Name As String
Dim Dir_Folder As String
Dim KKS As String
Dim Base_Name As String
Dim Time_Stamp As String
Dir_Folder = Get_File_ParentFolder(PTH)
Base_Name = Get_Base_Name(PTH)
'Debug.Print PTH
On Error GoTo Error_Task
Time_Stam = Format(Now, "yyyymmddHHMMSS")
KKS = Get_kakuchoushi(PTH)
'Debug.Print Dir_Folder
If KKS = "mdb" Then
GoTo Go_Conp
Else
If KKS = "accdb" Then
GoTo Go_Conp
Else
Saitekika = True
'Get_Error_Data ("Saitekika")
Exit Function
End If
End If
Go_Conp:
'バッチ起動で最適化
'Call Make_And_Go_Bat(PTH)
'Saitekika = True
'Exit Function
mdb_Name = "\new_" & Base_Name & Time_Stam
'Debug.Print mdb_Name
newPath = Dir_Folder & mdb_Name & "." & KKS '←注意 同じ名前のファイルが無いように設定
'Debug.Print newPath
'最適化後のmdbを別の名前で作成。
thePath = PTH
'Debug.Print newPath
'Debug.Print thePath
DBEngine.CompactDatabase thePath, newPath
Kill_DB:
'削除←元のmdbを削除します 注意！！
Kill thePath
'名前変更
Name newPath As thePath
'MsgBox "最適化成功です！", 64, "cmd_Comp_Click"
Saitekika = True
'Get_Error_Data ("Saitekika")
Exit Function
Error_Task:
MsgBox "パスワードが違います！", 16, "cmd_Comp_Click"
'Debug.Print Err.Description
Saitekika = True
'Get_Error_Data ("Saitekika")
Exit Function
End Function
環境変数の取得：
参照設定：
コード：
Public Function PC_Name_Get() As String
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'コンピュータ名の取得
Dim PC As String
PC = Environ("ComputerName") '環境変数の取得
PC_Name_Get = PC
'Get_Error_Data ("PC_Name_Get")
End Function
Public Function User_Name_Get() As String
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'ユーザー名の取得
Dim User_Name
User_Name = Environ("UserName") '環境変数の取得
User_Name_Get = User_Name
'Get_Error_Data ("User_Name_Get")
End Function
Public Function OS_Name_Get() As String
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'OS名の取得
Dim OS_Name
OS_Name = Environ("OS") '環境変数の取得
OS_Name_Get = OS_Name
'Get_Error_Data ("OS_Name_Get")
End Function
FileSystemObject：
参照設定：
コード：
Function FSO_FL_Check(File_CK As String) As Boolean
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'ファイル有無のチェック
Dim cFso As FileSystemObject 'オブジェクト変数宣言
Set cFso = New FileSystemObject '変数にオブジェクトの代入
If cFso.FileExists(File_CK) Then
FSO_FL_Check = True 'ファイル有り
Else
FSO_FL_Check = False 'ファイル無し
End If
'Get_Error_Data ("FSO_FL_Check")
End Function
Function Make_Fl(Folder As String) As Boolean
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'フォルダーの作成
On Error GoTo Error_Task
Dim MFL As String
Dim ct As Integer
ct = Len(Folder)
ct = ct - 1
MFL = Left(Folder, ct)
MkDir (MFL)
Make_Fl = True
'Get_Error_Data ("Make_Fl")
Exit Function
Error_Task:
Make_Fl = False
'Get_Error_Data ("Make_Fl")
Exit Function
End Function
Function Week_Day_Name(WN As Date) As String
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'曜日の取得
Dim Week_Name As String
Week_Name = WeekdayName(Weekday(WN))
Week_Day_Name = Week_Name
'Get_Error_Data ("Week_Day_Name")
End Function
Function Get_Base_Name(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'※ファイルのベースネームを取得する。
'FSOを利用するので、「MicroSoft Scripting Runtime」の参照設定が必須！
Dim objFileSys As Object
Dim strPath As String
Set objFileSys = CreateObject("Scripting.FileSystemObject")
strPath = objFileSys.GetBaseName(PTH)
Get_Base_Name = strPath
Set objFileSys = Nothing
''Get_Error_Data ("Get_Base_Name")
End Function
Function Get_kakuchoushi(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2016/02/26
'※ファイルの拡張子を取得する。
'FSOを利用するので、「MicroSoft Scripting Runtime」の参照設定が必須！
Dim objFileSys As Object
Dim strPath As String
Set objFileSys = CreateObject("Scripting.FileSystemObject")
strPath = objFileSys.GetExtensionName(PTH)
Get_kakuchoushi = strPath
Set objFileSys = Nothing
''Get_Error_Data ("Get_kakuchoushi")
End Function
Function Get_File_Attributes(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2017/04/03
'変更日：2017/04/03
'ファイルの属性を設定します
Dim FSO As Object
Dim Att As Integer
Set FSO = CreateObject("Scripting.FileSystemObject")
Att = FSO.GetFile(PTH).Attributes
Set FSO = Nothing
Select Case Att
Case 0
Get_File_Attributes = "標準ファイル。どの属性も設定されない。"
Case 1
Get_File_Attributes = "読み取り専用ファイル。"
Case 2
Get_File_Attributes = "隠しファイル。"
Case 4
Get_File_Attributes = "システムファイル。"
Case 8
Get_File_Attributes = "ディスクドライブボリュームラベル。この属性を設定することは出来ない（値の取得のみ可能）。"
Case 16
Get_File_Attributes = "フォルダ。この属性を設定することは出来ない。"
Case 32
Get_File_Attributes = "アーカイブ属性が設定されている（前回のバックアップ以降に変更されていればアーカイブ属性はオン）。"
Case 64
Get_File_Attributes = "リンクまたはショートカット、この属性を設定することは出来ない（値の取得のみ可能）。"
Case 128
Get_File_Attributes = "圧縮ファイル。この属性を設定することは出来ない（値の取得のみ可能）。"
Case Else
Get_File_Attributes = "属性不明。"
End Select
'値 意味
'0 標準ファイル。どの属性も設定されない。
'1 読み取り専用ファイル。
'2 隠しファイル。
'4 システムファイル。
'8 ディスクドライブボリュームラベル。この属性を設定することは出来ない（値の取得のみ可能）。
'16 フォルダ。この属性を設定することは出来ない。
'32 アーカイブ属性が設定されている（前回のバックアップ以降に変更されていればアーカイブ属性はオン）。
'64 リンクまたはショートカット、この属性を設定することは出来ない（値の取得のみ可能）。
'128 圧縮ファイル。この属性を設定することは出来ない（値の取得のみ可能）。
'Get_Error_Data ("Get_File_Attributes")
End Function
Function Get_File_DateCreated(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2017/04/02
'変更日：2017/04/02
'ファイルが作成された日付と時刻を返します
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Get_File_DateCreated = FSO.GetFile(PTH).DateCreated
Set FSO = Nothing
'Get_Error_Data ("Get_File_DateCreated")
End Function
Function Get_File_DateLastAccessed(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2017/04/02
'変更日：2017/04/02
'ファイルが最後にアクセスされたときの日付と時刻を返します
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
''C:\Work\Book1.xlsが最後にアクセスされた日時を表示します
Get_File_DateLastAccessed = FSO.GetFile(PTH).DateLastAccessed
Set FSO = Nothing
'Get_Error_Data ("Get_File_DateLastAccessed")
End Function
Function Get_File_DateLastModified(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2017/04/02
'変更日：2017/04/02
'ファイルが最後に更新されたときの日付と時刻を返します
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
''C:\Work\Book1.xlsが最後に更新された日時を表示します
Get_File_DateLastModified = FSO.GetFile(PTH).DateLastModified
Set FSO = Nothing
'Get_Error_Data ("Get_File_DateLastModified")
End Function
Function Get_File_Drive(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2017/04/02
'変更日：2017/04/02
'ファイルが存在するドライブの名前を返します
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
''「C:」を表示します
Get_File_Drive = FSO.GetFile(PTH).Drive
Set FSO = Nothing
'Get_Error_Data ("Get_File_Drive")
End Function
Function Get_File_Name_WSH(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2017/04/02
'変更日：2017/04/02
'ファイルの名前を返します
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Get_File_Name_WSH = FSO.GetFile(PTH).Name
Set FSO = Nothing
'Get_Error_Data ("Get_File_Name_WSH")
End Function
Function Get_File_ParentFolder(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2017/04/02
'変更日：2017/04/02
'ファイルが存在するフォルダを返します
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
''「C:\Work」を表示します
Get_File_ParentFolder = FSO.GetFile(PTH).ParentFolder
Set FSO = Nothing
'Get_Error_Data ("Get_File_ParentFolder")
End Function
Function Get_File_Path(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2017/04/02
'変更日：2017/04/02
'ファイルのパスを返します
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
''「C:\Work\Book1.xls」を表示します
Get_File_Path = FSO.GetFile(PTH).Path
Set FSO = Nothing
'Get_Error_Data ("Get_File_Path")
End Function
Function Get_File_Size(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2017/04/02
'変更日：2017/04/02
'ファイルのサイズを返します
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
''C:\Work\Book1.xlsのサイズを表示します
Get_File_Size = FSO.GetFile(PTH).Size
Set FSO = Nothing
'Get_Error_Data ("Get_File_Size")
End Function
Function Get_File_Type(PTH As String) As String
'作成者：瀧澤禮好
'作成日：2017/04/02
'変更日：2017/04/02
'ファイルの種類を返します
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
''「Microsoft Office Excelワークシート」を表示します
Get_File_Type = FSO.GetFile(PTH).Type
Set FSO = Nothing
'Get_Error_Data ("Get_File_Type")
End Function
フォームの開閉を確認：
参照設定：
コード：
Function Get_Form_Open_Close(Form_Name As String) As String
'作成者：瀧澤禮好
'作成日：2017/04/09
'変更日：2017/04/09
'フォームの開閉を確認し、状態を文字列で返す。
If SysCmd(acSysCmdGetObjectState, acForm, Form_Name) = 0 Then
Get_Form_Open_Close = "CLOSE"
Else
Get_Form_Open_Close = "OPEN"
End If
'Get_Error_Data ("Get_Form_Open_Close")
End Function
バッチファイルを起動する：
参照設定：
コード：
Sub Run_Bat_File(PTH As String)
'作成者：瀧澤禮好
'作成日：2017/04/06
'変更日：2017/04/16
'バッチファイルを非表示で起動する
Dim WshShell As Object
Set WshShell = CreateObject("Wscript.Shell")
WshShell.Run PTH, 0, True
Set WshShell = Nothing
'0,非表示
'1,通常のウィンドウ（アクティブ）
'2,最小化のウィンドウ（アクティブ）
'3,最大化のウィンドウ（アクティブ）
'4,通常のウィンドウ（非アクティブ）
'5,現在のサイズのウィンドウ（アクティブ）
'6,非アクティブな最小化ウィンドウ
'7,最小化ウィンドウ（アクティブなウィンドウは変更されない）
'8,現在のサイズのウィンドウ（アクティブなウィンドウは変更されない）
'9,元のサイズのウィンドウ（アクティブ）
'10,プログラムの状態により表示を決定
End Sub
MsgBox関数
If (MsgBox("「" & myfile & "」の最適化を開始します！！OKですか？？？", 4) = 7) Then
Exit Sub
End If
* ※上記コードの意味：ボタンの種類は「4（[はい]ボタンと[いいえ]ボタンを表示）」で、戻り値が「7（[いいえ]）」を押したら、処理を中断する。
MsgBox("メッセージ文字列",579,"タイトル文字列")
* ※「579」はボタンの種類（3）、アイコンのスタイル（64）、標準ボタン（512）、ボックスの状態(0)の合計(579)
書式：
ret = MsgBox(prompt[,buttons][,title])
※戻り値(ret)：
文字列： 値：意味
vbOK 1 OK
vbCancel 2 キャンセル
vbAbort 3 中止
vbRetry 4 再試行
vbIgnore 5 無視
vbYes 6 はい
vbNo 7 いいえ
※表示されるメッセージ(prompt)
※名前月引数(buttons)※以下の引数の合計値を指定。
文字列： 値：意味
vbOKOnly 0 OKボタンのみ表示
vbOKCancel 1 OKボタンとキャンセルボタンを表示
vbAbortRetryIgnore 2 中止、再試行、無視の３つのボタンを表示
vbYesNoCancel 3 はい、いいえ、およびキャンセルの３つのボタンを表示
vbYesNo 4 はい、いいえボタンを表示
vbRetryCancel 5 再試行、キャンセルボタンを表示
vbCritical 16 警告メッセージアイコンを表示
vbQuestion 32 問い合わせメッセージアイコンを表示
vbExcelamtion 48 注意メッセージアイコンを表示
vbInformation 64 情報メッセージアイコンを表示
vbDefultButton1 0 第１ボタンを標準ボタンにする
vbDefultButton2 256 第２ボタンを標準ボタンにする
vbDefultButton3 512 第３ボタンを標準ボタンにする
vbDefultButton4 768 第４ボタンを標準ボタンにする
vbApplicationModal 0 アプリケーションモーダルに設定。応答するまで、選択中のアプリケーションが中断される。
vbSytemModal 4096 システムモーダル設定。応答するまで、総てのアプリケーションが中断される。
vbMsgBoxHelpButton 16384 ヘルプボタンの追加
vbMsgBoxSetForeground 65536 最全面のウィンドウとして表示
vbMsgBoxRight 524288 テキストを右寄せで表示
vbMsgBoxRtlReading 1048576 テキストを右から左の方向で表示
※タイトルバーに表示する文字列(title)