解析ツール.accdb
frm_Main：
Option Compare Database
Option Explicit
Public PTH As Variant
Private Sub cmd_Quit_Click()
'作成者：瀧澤禮好
'作成日：2019/01/06
'変更日：2019/01/08
'
Dim SQL_STR As String
DoCmd.SetWarnings False
SQL_STR = "DELETE Usys_Objects.* FROM Usys_Objects;"
DoCmd.RunSQL SQL_STR, -1
SQL_STR = "DELETE Usys_Query.* FROM Usys_Query;"
DoCmd.RunSQL SQL_STR, -1
DoCmd.Quit acQuitSaveAll
Exit Sub
End Sub
Private Sub cmd_ReTry_Click()
'作成者：瀧澤禮好
'作成日：2019/01/09
'変更日：2019/01/11
'
On Error GoTo Error_Task
Dim Len_PTH As Variant
PTH = Me.txt_PTH
If IsNull(PTH) = True Then
Exit Sub
Else
Len_PTH = Len(PTH)
'対象AccessファイルのMSysObjectsを名前を変えてハードリンク
If Create_Link_Table(PTH, "MSysObjects", "USys_Get_Objects") = False
Then
MsgBox "エラーが発生しました！", 16, "txt_PTH_DblClick"
Exit Sub
Else
End If
'オブジェクトの一覧を取得（テーブル、クエリ、フォーム、レポート、モジュール、マクロ、リンク等）
Call Make_Usys_Objects
'
'クエリの名前を取得してテーブルに転記、SQLプロパティを取得してテーブルに転記
Call Make_Usys_Query
End If
'必要なデータを取得したら、リンクを解除
DoCmd.DeleteObject acTable, "USys_Get_Objects"
MsgBox "解析完了！", 64, "cmd_ReTry_Click"
Exit Sub
Error_Task:
DoCmd.DeleteObject acTable, "USys_Get_Objects"
MsgBox "解析完了エラー！", 16, "cmd_ReTry_Click"
Exit Sub
End Sub
Private Sub cmd_オブジェクト一覧_Click()
'作成者：瀧澤禮好
'作成日：2019/01/11
'変更日：2019/01/11
'
If IsNull(Me.txt_Export_PTH) = True Then
MsgBox "「エクスポート先」が空白です！", 16, ""
Exit Sub
End If
Dim PTH As String
Dim chk As String
PTH = Me.txt_Export_PTH
Call Folder_Look_Up(PTH)
If Right(PTH, 1) = "\" Then
Else
PTH = PTH & "\"
End If
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml,
"オブジェクト一覧", PTH & "オブジェクト一覧_" & Time_Stamp_Get & ".xlsx", False, ""
MsgBox "「" & PTH & "オブジェクト一覧_" & Time_Stamp_Get & ".xlsx」にエクスポートしました。",
64, "cmd_オブジェクト一覧_Click"
Exit Sub
End Sub
Private Sub cmd_クエリ一覧_Click()
'作成者：瀧澤禮好
'作成日：2019/01/11
'変更日：2019/01/11
'
If IsNull(Me.txt_Export_PTH) = True Then
MsgBox "「エクスポート先」が空白です！", 16, ""
Exit Sub
End If
Dim PTH As String
Dim chk As String
PTH = Me.txt_Export_PTH
Call Folder_Look_Up(PTH)
If Right(PTH, 1) = "\" Then
Else
PTH = PTH & "\"
End If
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml,
"クエリ一覧", PTH & "クエリ一覧_" & Time_Stamp_Get & ".xlsx", False, ""
MsgBox "「" & PTH & "クエリ一覧_" & Time_Stamp_Get & ".xlsx」にエクスポートしました。", 64,
"cmd_クエリ一覧_Click"
Exit Sub
End Sub
Private Sub Form_Load()
'作成者：瀧澤禮好
'作成日：2019/01/12
'変更日：2019/01/12
'
DoCmd.OpenForm "frm_BGF", acNormal, "", "", , acHidden
Exit Sub
End Sub
Private Sub txt_Export_PTH_DblClick(Cancel As Integer)
'作成者：瀧澤禮好
'作成日：2019/01/11
'変更日：2019/01/11
'
Me.txt_Export_PTH = FDFolderPicker
Exit Sub
End Sub
Private Sub txt_PTH_DblClick(Cancel As Integer)
'作成者：瀧澤禮好
'作成日：2019/01/06
'変更日：2019/01/11
'
Dim Len_PTH As Variant
On Error GoTo Error_Task
Me.txt_PTH = FDFilePicker(3)
PTH = Me.txt_PTH
If IsNull(PTH) = True Then
Exit Sub
Else
Len_PTH = Len(PTH)
'対象AccessファイルのMSysObjectsを名前を変えてハードリンク
If Create_Link_Table(PTH, "MSysObjects", "USys_Get_Objects") = False
Then
MsgBox "エラーが発生しました！", 16, "txt_PTH_DblClick"
Exit Sub
Else
End If
'オブジェクトの一覧を取得（テーブル、クエリ、フォーム、レポート、モジュール、マクロ、リンク等）
Call Make_Usys_Objects
'
'クエリの名前を取得してテーブルに転記、SQLプロパティを取得してテーブルに転記
Call Make_Usys_Query
End If
'必要なデータを取得したら、リンクを解除
DoCmd.DeleteObject acTable, "USys_Get_Objects"
MsgBox "解析完了！", 64, "txt_PTH_DblClick"
Exit Sub
Error_Task:
DoCmd.DeleteObject acTable, "USys_Get_Objects"
MsgBox "解析完了エラー！", 16, "txt_PTH_DblClick"
Exit Sub
End Sub
Function Get_SQL_ST(Q_Name As String) As String
'作成者：瀧澤禮好
'作成日：2019/01/07
'変更日：2019/01/07
'クエリのSQLを取得
Get_SQL_ST = CurrentDb.QueryDefs(Q_Name).SQL
Exit Function
End Function
frm_BGF:
SQLプロパティが欠落する事象を解決するために、テーブルに書き込む事を止め、テキストボックスに出力し、
そのテキストボックスから改めてテーブルに上書きする事で、総てのSQLステートメントを取得する事に成功した。
frm_Get_Feeld:
※このフォームは、解析対象のAccessファイルにインポートして操作する。
※テーブルの解析のロジックは、総てこのフォームのクラスモジュールに記述してある。
Option Compare Database
Option Explicit
Private Sub cmd_Get_Feeld_Click()
'作成者：瀧澤禮好
'作成日：2019/01/12
'変更日：2019/01/13
'
'テーブルのフィールド定義を取得
If IsNull(Me.txt_Book_Name) Then
MsgBox "ブック名が空白です！", 16, ""
Exit Sub
End If
On Error Resume Next
DoCmd.SetWarnings False
Dim myQuery As DAO.QueryDef
Dim SQL_STR As String
Dim T_CNT As Long
Dim cnt As Long
Dim myDB As DAO.Database
Dim myTD As DAO.TableDef
Dim myFeeld As DAO.Field
Dim myIndex As DAO.Index
Dim Feeld_Name As String
Dim Feeld_Type As Integer
Dim Feeld_Index As Boolean
Dim Feeld_I As Variant
Dim PTH As String
Dim Book_Name As String
Dim Sheet_Name As String
Dim BN As Integer
Dim TS As String
TS = Format(Now(), "yyyymmddhhnnss")
BN = Len(CurrentProject.Name)
PTH = CurrentProject.Path & "\"
Me.txt_Book_Name = CurrentProject.Name
Dim PTH_Len As Integer 'フルパスの長さ
Dim COMMA_Point As Integer 'コンマの位置
Dim PTH_Point As Integer '拡張子の長さ
Dim PTH_OUT As String '拡張子の格納先
PTH_Len = Len(Me.txt_Book_Name) 'フルパスの長さ取得
COMMA_Point = InStr(CurrentProject.Name, ".") 'カンマの位置を右から走査して取得
PTH_Point = PTH_Len - (BN - COMMA_Point + 1) 'フルパスの長さからコンマ位置を差し引く
PTH_OUT = Left(Me.txt_Book_Name, PTH_Point)
'右からフルパスの長さからコンマ位置を差し引いた文字文取得
Book_Name = PTH_OUT & "_フィールド定義_" & TS
DoCmd.SetWarnings False
SQL_STR = "DELETE Get_Name.* FROM Get_Name;"
DoCmd.RunSQL SQL_STR, -1
SQL_STR = "INSERT INTO Get_Name ( Name )" _
& " SELECT MSysObjects.Name" _
& " FROM MSysObjects " _
& " WHERE (((MSysObjects.Name) Not Like 'MSys*' And
(MSysObjects.Name)<>'tbl_Get_FP' And (MSysObjects.Name)<>'Get_Name' And
(MSysObjects.Name)<>'tbl_DAO_Field_Object_TypePro') AND
((MSysObjects.Type)=1 Or (MSysObjects.Type)=4 Or (MSysObjects.Type)=6));"
DoCmd.RunSQL SQL_STR
T_CNT = DCount("Name", "Get_Name")
For cnt = 1 To T_CNT
Me.txt_Table_Name = DLookup("Name", "Get_Name", "ID = " & cnt)
Sheet_Name = Me.txt_Table_Name & "_解析"
Set myDB = CurrentDb
Set myTD = myDB.TableDefs(Me.txt_Table_Name)
'フィールド数を取得
'MsgBox "Testのフィールド数は " & myTD.Fields.Count & " 個です"
'フィールド定義を取得
SQL_STR = "DELETE tbl_Get_FP.* FROM tbl_Get_FP;"
DoCmd.RunSQL SQL_STR, -1
For Each myFeeld In myTD.Fields
Me.txt_Feeld_1 = "" '名前クリア
Me.txt_Feeld_2 = "" '型クリア
Me.txt_Feeld_3 = "" 'サイズクリア
Me.txt_Feeld_1 = myFeeld.Name '名前
Me.txt_Feeld_2 = myFeeld.Type '型
Me.txt_Feeld_3 = myFeeld.Size 'サイズ
SQL_STR = " INSERT INTO tbl_Get_FP ( Name, Type,Size)" _
& " SELECT [Forms]![frm_Get_Feeld]![txt_Feeld_1] AS 式2, [Forms]![frm_Get_Feeld]![txt_Feeld_2]
AS 式1, [Forms]![frm_Get_Feeld]![txt_Feeld_3] AS 式3;"
DoCmd.RunSQL SQL_STR
SQL_STR = " UPDATE tbl_Get_FP INNER JOIN
tbl_DAO_Field_Object_TypePro ON tbl_Get_FP.Type =
tbl_DAO_Field_Object_TypePro.値 SET tbl_Get_FP.Type_Str = [tbl_DAO_Field_Object_TypePro]![dbxxx];"
DoCmd.RunSQL SQL_STR
Next
'インデックスの取得（重複無し）
For Each myIndex In myTD.Indexes
If myIndex.Unique = True Then
For Each myFeeld In myIndex.Fields
Me.txt_Index2 = ""
Me.txt_Index2 = myFeeld.Name
SQL_STR = "UPDATE tbl_Get_FP SET tbl_Get_FP.[Index] =
'△'" _
& "WHERE
(((tbl_Get_FP.Name)=[Forms]![frm_Get_Feeld]![txt_Index2]));"
DoCmd.RunSQL SQL_STR
Next
End If
Next
'インデックスの取得（プライマリキー）
For Each myIndex In myTD.Indexes
If myIndex.Primary = True Then
For Each myFeeld In myIndex.Fields
Me.txt_Index = ""
Me.txt_Index = myFeeld.Name
SQL_STR = "UPDATE tbl_Get_FP SET tbl_Get_FP.[Index] =
'○'" _
& "WHERE
(((tbl_Get_FP.Name)=[Forms]![frm_Get_Feeld]![txt_Index]));"
DoCmd.RunSQL SQL_STR
Next
End If
Next
SQL_STR = " SELECT tbl_Get_FP.Name, tbl_Get_FP.Type,
tbl_Get_FP.Type_Str, tbl_Get_FP.Index, tbl_Get_FP.Size" _
& " FROM tbl_Get_FP;"
Set myQuery = myDB.CreateQueryDef(Sheet_Name, SQL_STR)
myQuery.SQL = SQL_STR
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml,
Sheet_Name, PTH & Book_Name & ".xlsx", True, ""
DoEvents
DoCmd.DeleteObject acQuery, Sheet_Name
Next cnt
End_Task:
DoCmd.DeleteObject acQuery, Sheet_Name
MsgBox "OK"
End Sub
Private Sub cmd_Quit_Click()
'テーブルのフィールド定義を取得
'作成者：瀧澤禮好
'作成日：2019/01/12
'変更日：2019/01/12
'
'
DoCmd.SetWarnings False
DoCmd.DeleteObject acTable, "tbl_Get_FP"
DoCmd.DeleteObject acTable, "Get_Name"
DoCmd.DeleteObject acTable, "tbl_DAO_Field_Object_TypePro"
DoCmd.Close acForm, Me.Name
End Sub
Private Sub Form_Load()
'テーブルのフィールド定義を取得
'作成者：瀧澤禮好
'作成日：2019/01/12
'変更日：2019/01/12
'
'
'/********************/テーブル作成/********************/
Dim DB As DAO.Database
Dim TD As DAO.TableDef
Dim A_FL As DAO.Field
Dim SQL_STR As String
On Error Resume Next
DoCmd.SetWarnings False
DoCmd.DeleteObject acTable, "tbl_Get_FP"
DoCmd.DeleteObject acTable, "Get_Name"
DoCmd.DeleteObject acTable, "tbl_DAO_Field_Object_TypePro"
Set DB = CurrentDb
Set TD = DB.CreateTableDef("tbl_Get_FP")
TD.Fields.Append TD.CreateField("Name", dbText, 255)
TD.Fields.Append TD.CreateField("Type", dbLong)
TD.Fields.Append TD.CreateField("Type_Str", dbText, 255)
TD.Fields.Append TD.CreateField("Index", dbText, 255)
TD.Fields.Append TD.CreateField("Size", dbText, 255)
'TD.Fields.Append TD.CreateField("ID", dbAutoIncrField)
DB.TableDefs.Append TD
With TD
Set A_FL = .CreateField("ID", dbLong)
A_FL.Attributes = dbAutoIncrField
.Fields.Append Object:=A_FL
End With
Set A_FL = Nothing
Set DB = Nothing
Set TD = Nothing
Set DB = CurrentDb
Set TD = DB.CreateTableDef("Get_Name")
TD.Fields.Append TD.CreateField("Name", dbText, 255)
'TD.Fields.Append TD.CreateField("ID", dbLong)
DB.TableDefs.Append TD
With TD
Set A_FL = .CreateField("ID", dbLong)
A_FL.Attributes = dbAutoIncrField
.Fields.Append Object:=A_FL
End With
Set A_FL = Nothing
Set DB = Nothing
Set TD = Nothing
Set DB = CurrentDb
Set TD = DB.CreateTableDef("tbl_DAO_Field_Object_TypePro")
TD.Fields.Append TD.CreateField("値", dbLong)
TD.Fields.Append TD.CreateField("dbxxx", dbText, 255)
DB.TableDefs.Append TD
With TD
Set A_FL = .CreateField("ID", dbLong)
A_FL.Attributes = dbAutoIncrField
.Fields.Append Object:=A_FL
End With
Set A_FL = Nothing
Set DB = Nothing
Set TD = Nothing
'/********************/テーブル作成/********************/
DoCmd.RunSQL " INSERT INTO
tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES (1,'dbBoolean');", -1
DoCmd.RunSQL " INSERT INTO
tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES (2,'dbByte');", -1
DoCmd.RunSQL " INSERT INTO
tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES (3,'dbInteger');", -1
DoCmd.RunSQL " INSERT INTO
tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES (4,'dbLong');", -1
DoCmd.RunSQL " INSERT INTO
tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES (5,'dbCurrency');", -1
DoCmd.RunSQL " INSERT INTO
tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES (6,'dbSingle');", -1
DoCmd.RunSQL " INSERT INTO
tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES (7,'dbDouble');", -1
DoCmd.RunSQL " INSERT INTO
tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES (8,'dbDate');", -1
DoCmd.RunSQL " INSERT INTO
tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES (9,'dbBinary');", -1
DoCmd.RunSQL " INSERT INTO
tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES (10,'dbText');", -1
DoCmd.RunSQL " INSERT INTO
tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES (11,'dbLongBinary');", -1
DoCmd.RunSQL " INSERT INTO tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES
(12,'dbMemo');", -1
DoCmd.RunSQL " INSERT INTO tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES
(15,'dbGUID');", -1
DoCmd.RunSQL " INSERT INTO tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES
(16,'dbBigInt');", -1
DoCmd.RunSQL " INSERT INTO tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES
(17,'dbVarBinary');", -1
DoCmd.RunSQL " INSERT INTO tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES
(18,'dbChar');", -1
DoCmd.RunSQL " INSERT INTO tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES
(19,'dbNumeric');", -1
DoCmd.RunSQL " INSERT INTO tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES
(20,'dbDecimal');", -1
DoCmd.RunSQL " INSERT INTO tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES
(21,'dbFloat');", -1
DoCmd.RunSQL " INSERT INTO tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES
(22,'dbTime');", -1
DoCmd.RunSQL " INSERT INTO tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES
(23,'dbTimeStamp');", -1
DoCmd.RunSQL " INSERT INTO tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES
(101,'dbAttachment');", -1
DoCmd.RunSQL " INSERT INTO tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES
(102,'dbComplexByte');", -1
DoCmd.RunSQL " INSERT INTO tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES
(103,'dbComplexInteger');", -1
DoCmd.RunSQL " INSERT INTO tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES
(104,'dbComplexLong');", -1
DoCmd.RunSQL " INSERT INTO tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES
(105,'dbComplexSingle');", -1
DoCmd.RunSQL " INSERT INTO tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES
(106,'dbComplexDouble');", -1
DoCmd.RunSQL " INSERT INTO tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES
(107,'dbComplexGUID');", -1
DoCmd.RunSQL " INSERT INTO tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES
(108,'dbComplexDecimal');", -1
DoCmd.RunSQL " INSERT INTO
tbl_DAO_Field_Object_TypePro([値],[dbxxx]) VALUES (109,'dbComplexText');",
-1
Exit Sub
End Sub
General:
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
Sub Folder_Look_Up(PTH As String)
'作成者：瀧澤禮好
'作成日：2019/01/11
'変更日：2019/01/11
'フォルダの存在を確認し、存在しない場合は作成する
Dim chk As String
Dim PTH_Len As Integer
chk = Right(PTH, 1)
If chk = "\" Then
PTH_Len = Len(PTH)
PTH = Left(PTH, (PTH_Len - 1))
End If
If FSO_PH_Check(PTH) = False Then
If (MsgBox("「" & PTH & "」は存在しません。" & vbCrLf & "「" & PTH &
"」を作成しますか？", 36) = 7) Then
Exit Sub
Else
MkFolder (PTH)
End If
End If
End Sub
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(Kaku As Integer)
'作成者：瀧澤禮好
'作成日：2016/02/26
'変更日：2018/01/06
'[参照] ダイアログ ボックスの 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;*.xlsx;*.xlsm"
.Filters.Add "Access", "*.mdb;*.accdb"
.Filters.Add "イメージ", "*.gif; *.jpg; *.jpeg"
.Filters.Add "すべてのファイル", "*.*"
.FilterIndex = Kaku
.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(5)
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 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
Function Get_SQL_ST_PTH(PTH As String, Q_Name As String) As String
'作成者：瀧澤 禮好
'作成日：2019/01/11
'更新日：2019/01/11
'クエリのSQLを取得(外部Accessファイル)
Dim Get_SQL_DB As DAO.Database
Dim SQL_STR As String
On Error GoTo Error_Task
Set Get_SQL_DB = OpenDatabase(PTH)
SQL_STR = Get_SQL_DB.QueryDefs(Q_Name).SQL
Get_SQL_DB.Close
Set Get_SQL_DB = Nothing
Get_SQL_ST_PTH = SQL_STR
Exit Function
Error_Task:
Get_SQL_ST_PTH = "取得出来ませんでした！"
Exit Function
End Function
Function Time_Stamp_Get() As String
'作成者：瀧澤 禮好
'作成日：2019/01/11
'更新日：2019/01/11
'タイムスタンプの作成
Dim TS As String
TS = Format(Now(), "yyyymmddhhnnss") 'タイムスタンプ作成
Time_Stamp_Get = TS
End Function
Module_DAO:
Option Compare Database
Option Explicit
Sub Make_Usys_Objects()
'作成者：瀧澤禮好
'作成日：2019/01/06
'変更日：2019/01/11
'
'クエリを元にレコードセット処理を行う。
DoEvents
Dim DAO_WS As Workspace
Dim DAO_DB As DAO.Database
Dim DAO_RS_IN As DAO.Recordset
Dim DAO_RS_OUT As DAO.Recordset
Dim DAO_FIL As DAO.Field
Dim SQL_STR As String
Dim cn As Long
Set DAO_WS = DBEngine.Workspaces(0)
Set DAO_DB = CurrentDb()
Set DAO_RS_IN = DAO_DB.OpenRecordset("qry_Get_Objects") 'テーブル名又はクエリ名を設定。
Set DAO_RS_OUT = DAO_DB.OpenRecordset("Usys_Objects") 'テーブル名又はクエリ名を設定。
DoCmd.SetWarnings False
SQL_STR = "DELETE Usys_Objects.* FROM Usys_Objects;"
DoCmd.RunSQL SQL_STR, -1
SQL_STR = " SELECT USys_Get_Objects.Connect, USys_Get_Objects.Database,
USys_Get_Objects.DateCreate, USys_Get_Objects.DateUpdate,
USys_Get_Objects.Flags, USys_Get_Objects.ForeignName, USys_Get_Objects.Id,
USys_Get_Objects.Lv," _
& " USys_Get_Objects.LvExtra, USys_Get_Objects.LvModule,
USys_Get_Objects.LvProp, USys_Get_Objects.Name, USys_Get_Objects.Owner,
USys_Get_Objects.ParentId, USys_Get_Objects.RmtInfoLong,
USys_Get_Objects.RmtInfoShort, USys_Get_Objects.Type, Usys_Objects_Type.種類,
Usys_Objects_Type.ObjectType" _
& " FROM USys_Get_Objects INNER JOIN Usys_Objects_Type ON
USys_Get_Objects.Type = Usys_Objects_Type.Type;"
CurrentDb.QueryDefs("qry_Get_Objects").SQL = SQL_STR
SQL_STR = " SELECT Usys_Objects.PTH, Usys_Objects.ObjectType,
Usys_Objects.Name, Get_SQL_ST_PTH([PTH],[Name]) AS SQLプロパティ" _
& " FROM Usys_Objects" _
& " WHERE Usys_Objects.ObjectType='acQuery';"
CurrentDb.QueryDefs("Usys_Query_Item_Object").SQL = SQL_STR
cn = 1
Do Until DAO_RS_IN.EOF 'レコードセットの最後まで繰り返す。
DAO_RS_OUT.AddNew
DAO_RS_OUT![No] = cn
DAO_RS_OUT![Connect] = DAO_RS_IN![Connect]
DAO_RS_OUT![Database] = DAO_RS_IN![Database]
DAO_RS_OUT![DateCreate] = DAO_RS_IN![DateCreate]
DAO_RS_OUT![DateUpdate] = DAO_RS_IN![DateUpdate]
DAO_RS_OUT![Flags] = DAO_RS_IN![Flags]
DAO_RS_OUT![ForeignName] = DAO_RS_IN![ForeignName]
DAO_RS_OUT![Id] = DAO_RS_IN![Id]
DAO_RS_OUT![Lv] = DAO_RS_IN![Lv]
DAO_RS_OUT![LvExtra] = DAO_RS_IN![LvExtra]
DAO_RS_OUT![LvModule] = DAO_RS_IN![LvModule]
DAO_RS_OUT![LvProp] = DAO_RS_IN![LvProp]
DAO_RS_OUT![Name] = DAO_RS_IN![Name]
DAO_RS_OUT![Owner] = DAO_RS_IN![Owner]
DAO_RS_OUT![ParentId] = DAO_RS_IN![ParentId]
DAO_RS_OUT![RmtInfoLong] = DAO_RS_IN![RmtInfoLong]
DAO_RS_OUT![RmtInfoShort] = DAO_RS_IN![RmtInfoShort]
DAO_RS_OUT![Type] = DAO_RS_IN![Type]
DAO_RS_OUT![種類] = DAO_RS_IN![種類]
DAO_RS_OUT![ObjectType] = DAO_RS_IN![ObjectType]
DAO_RS_OUT![PTH] = [Forms]![frm_Main]![txt_PTH]
DAO_RS_OUT.Update
DAO_RS_IN.MoveNext '次のレコードへ移動
cn = cn + 1
Loop
DAO_RS_IN.Close 'レコードセットを閉じる
DAO_RS_OUT.Close 'レコードセットを閉じる
DAO_DB.Close 'データベースを閉じる。
DAO_WS.Close 'ワークスぺスを閉じる。
Set DAO_RS_IN = Nothing 'オブジェクト変数の初期化。
Set DAO_RS_OUT = Nothing 'オブジェクト変数の初期化。
Set DAO_WS = Nothing 'オブジェクト変数の初期化。
Set DAO_DB = Nothing 'オブジェクト変数の初期化
Exit Sub
End Sub
Sub Make_Usys_Query()
'作成者：瀧澤禮好
'作成日：2019/01/08
'変更日：2019/01/12
'
'クエリを元にレコードセット処理を行う。
DoEvents
Dim DAO_WS As Workspace
Dim DAO_DB As DAO.Database
Dim DAO_RS_IN As DAO.Recordset
Dim DAO_RS_OUT As DAO.Recordset
Dim DAO_FIL As DAO.Field
Dim SQL_STR As String
Dim cn As Long
Set DAO_WS = DBEngine.Workspaces(0)
Set DAO_DB = CurrentDb()
Set DAO_RS_IN = DAO_DB.OpenRecordset("Usys_Query_Item_Object")
'テーブル名又はクエリ名を設定。
Set DAO_RS_OUT = DAO_DB.OpenRecordset("Usys_Query") 'テーブル名又はクエリ名を設定。
DoCmd.SetWarnings False
SQL_STR = "DELETE Usys_Query.* FROM Usys_Query;"
DoCmd.RunSQL SQL_STR, -1
cn = 1
Do Until DAO_RS_IN.EOF 'レコードセットの最後まで繰り返す。
DAO_RS_OUT.AddNew
DAO_RS_OUT![連番] = cn
DAO_RS_OUT![クエリ名] = DAO_RS_IN![Name]
DAO_RS_OUT![SQLプロパティ] = DAO_RS_IN![SQLプロパティ]
DAO_RS_OUT.Update
DAO_RS_IN.MoveNext '次のレコードへ移動
cn = cn + 1
Loop
DAO_RS_IN.Close 'レコードセットを閉じる
DAO_RS_OUT.Close 'レコードセットを閉じる
DAO_DB.Close 'データベースを閉じる。
DAO_WS.Close 'ワークスぺスを閉じる。
Set DAO_RS_IN = Nothing 'オブジェクト変数の初期化。
Set DAO_RS_OUT = Nothing 'オブジェクト変数の初期化。
Set DAO_WS = Nothing 'オブジェクト変数の初期化。
Set DAO_DB = Nothing 'オブジェクト変数の初期化
Call Change_SQL_Pro
Exit Sub
End Sub
Sub Change_SQL_Pro()
'作成者：瀧澤禮好
'作成日：2019/01/12
'変更日：2019/01/12
'SQLプロパティん書き換え
Dim cnt As Long
Dim Item_cnt As Long
Dim Change_Item As String
Dim PTH As String
Dim SQL_STR As String
PTH = [Forms]![frm_Main]![txt_PTH]
Item_cnt = DCount("連番", "Usys_Query")
For cnt = 1 To Item_cnt
Change_Item = DLookup("クエリ名", "Usys_Query", "[連番]=" & cnt)
[Forms]![frm_BGF]![txt_SQL_Pro] = Get_SQL_ST_PTH(PTH, Change_Item)
SQL_STR = " UPDATE Usys_Query SET Usys_Query.SQLプロパティ =
[Forms]![frm_BGF]![txt_SQL_Pro] WHERE Usys_Query.連番=" & cnt & ";"
DoCmd.RunSQL SQL_STR, -1
Next cnt
End Sub
WSH_FSO:
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
Module_ソースコードExport:
Option Compare Database
Option Explicit
Sub ExportComponents()
'MS Access のVBAモジュールを全てエクスポート
Dim Fso As New Scripting.FileSystemObject
Dim OutDir As String
'FSOでの出力先フォルダの有無確認、出力先フォルダの作成
OutDir = Fso.GetParentFolderName(CurrentDb.Name) & "\Source_Code"
'カレントプロジェクトのフォルダに「src 」を作成。
If Not Fso.FolderExists(OutDir) Then
Fso.CreateFolder (OutDir)
End If
'VBAモジュールの取得
Dim Component As VBComponent
For Each Component In Application.VBE.ActiveVBProject.VBComponents
Component.Export FileName:=OutDir & "\" & Component.Name &
GetExtension(Component.Type)
Next
End Sub
Function GetExtension(ComponentType As vbext_ComponentType) As String
'Microsoft Visual Basic for Applications Extensibility*.*
'Microsoft Scripting Runtime
'コンポーネントタイプによる拡張子の設定
Select Case ComponentType
Case vbext_ComponentType.vbext_ct_ClassModule
GetExtension = ".cls"
Case vbext_ComponentType.vbext_ct_MSForm
GetExtension = ".frm"
Case vbext_ComponentType.vbext_ct_StdModule
GetExtension = ".bas"
Case vbext_ComponentType.vbext_ct_ActiveXDesigner
GetExtension = ".cls"
Case vbext_ComponentType.vbext_ct_Document
GetExtension = ".cls"
End Select
End Function
Usys_Objects:
Usys_Objects_Type:
Usys_Query:
Usys_Table:
qry_Get_Objects:
SELECT USys_Get_Objects.Connect, USys_Get_Objects.Database,
USys_Get_Objects.DateCreate, USys_Get_Objects.DateUpdate,
USys_Get_Objects.Flags, USys_Get_Objects.ForeignName, USys_Get_Objects.Id,
USys_Get_Objects.Lv, USys_Get_Objects.LvExtra, USys_Get_Objects.LvModule,
USys_Get_Objects.LvProp, USys_Get_Objects.Name, USys_Get_Objects.Owner,
USys_Get_Objects.ParentId, USys_Get_Objects.RmtInfoLong,
USys_Get_Objects.RmtInfoShort, USys_Get_Objects.Type, Usys_Objects_Type.種類,
Usys_Objects_Type.ObjectType
FROM USys_Get_Objects INNER JOIN Usys_Objects_Type ON USys_Get_Objects.Type
= Usys_Objects_Type.Type;
qry_Get_Query:
SELECT Usys_Objects.[No], Usys_Objects.Connect, Usys_Objects.Database,
Usys_Objects.DateCreate, Usys_Objects.DateUpdate, Usys_Objects.Flags,
Usys_Objects.ForeignName, Usys_Objects.Id, Usys_Objects.Lv,
Usys_Objects.LvExtra, Usys_Objects.LvModule, Usys_Objects.LvProp,
Usys_Objects.Name, Usys_Objects.Owner, Usys_Objects.ParentId,
Usys_Objects.RmtInfoLong, Usys_Objects.RmtInfoShort, Usys_Objects.Type,
Usys_Objects.種類, Usys_Objects.ObjectType
FROM Usys_Objects
WHERE (((Usys_Objects.Type)=5));
qry_Get_Table:
SELECT Usys_Objects.Name, Usys_Objects.Type, Usys_Objects.PTH,
Usys_Objects.ObjectType, Usys_Objects.種類, Usys_Objects.Connect,
Usys_Objects.Database, Usys_Objects.DateCreate, Usys_Objects.DateUpdate
FROM Usys_Objects
WHERE (((Usys_Objects.Name) Not Like 'MSys*') AND ((Usys_Objects.Type)=1))
OR (((Usys_Objects.Type)=6)) OR (((Usys_Objects.Type)=4));
Usys_Query_Item_Object:
SELECT Usys_Objects.PTH, Usys_Objects.ObjectType, Usys_Objects.Name,
Get_SQL_ST_PTH([PTH],[Name]) AS SQLプロパティ
FROM Usys_Objects
WHERE Usys_Objects.ObjectType='acQuery';
オブジェクト一覧:
SELECT Usys_Objects.[No] AS 連番, Usys_Objects.Connect AS 接続種類,
Usys_Objects.Database AS 接続場所, Usys_Objects.ForeignName AS 接続名,
Usys_Objects.Name AS オブジェクト名, Usys_Objects.種類
FROM Usys_Objects
ORDER BY Usys_Objects.[No];
クエリ一覧:
SELECT Usys_Query.連番, Usys_Query.[クエリ名], Usys_Query.SQLプロパティ
FROM Usys_Query
ORDER BY Usys_Query.連番;
|
ID |
種類 |
Type |
ObjectType |
値 |
|
1 |
フォームForm |
-32768 |
acForm |
2 |
|
2 |
マクロMacro (名前が ~(チルダ) で始まるものはForm等、各オブジェクトの 埋め込みマクロ？「~TMPCLPMacro」は「AutoExec」) |
-32766 |
acMacro |
4 |
|
3 |
レポートReport |
-32764 |
acReport |
3 |
|
4 |
モジュールModule |
-32761 |
acModule |
5 |
|
5 |
User |
-32758 |
|
|
|
6 |
UserDefined Dcument, SummaryInfo Document (Databases Container の
Dcument) |
-32757 |
|
|
|
7 |
ページ |
-32756 |
|
|
|
8 |
テーブルTable (名前が MSys で始まるものはシステムオブジェクト) |
1 |
acTable |
0 |
|
9 |
MSysDb Document (Databases Container の Dcument) |
2 |
|
|
|
10 |
Collection |
3 |
|
|
|
11 |
Link Table (ODBC Link) |
4 |
|
|
|
12 |
クエリQuery (名前が ~(チルダ) で始まるものはForm, ListBox, ComboBox 各オブジェクトの
RecordSourceまたはRowSource) |
5 |
acQuery |
1 |
|
13 |
Link Table (Access Link) |
6 |
acTable |
|
|
14 |
Relationship |
8 |
|
|
|
15 |
Database プロパティ |
|
acDatabaseProperties |
11 |
|
16 |
データベース ダイアグラム (Access プロジェクト) |
|
acDiagram |
8 |
|
17 |
関数 |
|
acFunction |
10 |
|
18 |
サーバー ビュー |
|
acServerView |
7 |
|
19 |
ストアド プロシージャ (Access プロジェクト) |
|
acStoredProcedure |
9 |
|
20 |
データ マクロ |
|
acTableDataMacro |
12 |
|
|
|
|
|
|
