Option Compare Database
Option Explicit
Sub Print_Out_Txt(OUT_TXT As String, Line_No_O As String)
'作成者：
'作成日：2018/08/17
'変更日：2018/08/17
'テキストファイルに出力
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
Sub Make_Double_Chk()
'作成者：
'作成日：2018/08/17
'変更日：2018/08/17
Dim OUT_TXT As String
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()
'作成者：
'作成日：2018/08/17
'変更日：2018/08/17
Dim OUT_TXT As String
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
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
Function Get_Error_Data(PRO As String)
'作成者：
'作成日：2016/08/27
'変更日：2016/09/03
'
'※「Get_Error_Data("プロシージャ名")」を各プロシージャの最終行に記述。
'※「Error_Data」テーブルにエラー情報を取得・蓄積する。
'※エラートラップがある場合、エラートラップの最終行に「Get_Error_Data("プロシージャ名")」を最終行に記述。
Dim Num As Long '番号
Dim E_Data As String '意味
Dim E_Date_Time As String '時間
Dim SQL_STR As String 'SQL
Dim HR As Variant '配列
Dim IDID As Long 'ID
'最初のレコードかを確認
If DCount("エラー番号", "Usys_Error_Data") = 0 Then
'最初のレコードの場合（1を代入）
IDID = 1
Else
'2件目以降のレコードの場合（連番を作成代入）
IDID = DLast("ID", "Usys_Error_Data")
IDID = IDID + 1
End If
Num = Err.Number
E_Data = Err.Description
E_Data = Replace(E_Data, "'", "~") 'クォーテーションエラーの対処(2016/09/03)。
E_Date_Time = Format(Now(), "yyyymmddhhnnss")
HR = Split(Num & "," & E_Data & "," & E_Date_Time & "," & PRO, ",")
SQL_STR = "INSERT INTO Usys_Error_Data ( エラー番号, エラーの意味, 発生時刻, プロシージャ名, ID ) " _
& "VALUES ('" & HR(0) & "', '" & HR(1) & "', '" & HR(2) & "', '" & HR(3) & "', '" & IDID & "')"
DoCmd.SetWarnings False
DoCmd.RunSQL SQL_STR, 1
End Function
Function ReMake_Error_Data_TBL()
'作成者：
'作成日：2016/08/27
'変更日：2016/08/27
'
'※「AutoExec」マクロに記述するか、オプションの自動起動に記述。
DoCmd.SetWarnings False
On Error Resume Next
DoCmd.DeleteObject acTable, "Usys_Error_Data"
DoCmd.CopyObject "", "Usys_Error_Data", acTable, "Usys_Error_Data_0"
'Dim DB As DAO.Database
'Dim TD As DAO.TableDef
'Dim IDX As DAO.Index
'Set DB = CurrentDb
'Set TD = DB.CreateTableDef("Usys_Error_Data") 'テーブルの新規作成宣言。
'Set IDX = TD.CreateIndex("主キー") '主キー設定
'TD.Fields.Append TD.CreateField("エラー番号", dbLong) 'フィールド情報の宣言
'TD.Fields.Append TD.CreateField("エラーの意味", dbText, 255) 'フィールド情報の宣言
'TD.Fields.Append TD.CreateField("発生時刻", dbText, 255) 'フィールド情報の宣言
'TD.Fields.Append TD.CreateField("プロシージャ名", dbText, 255) 'フィールド情報の宣言
'TD.Fields.Append TD.CreateField("ID", dbLong) 'フィールド情報の宣言
'IDX.Fields.Append IDX.CreateField("ID") '主キー設定
'IDX.Primary = True '主キー設定
'TD.Indexes.Append IDX '主キー設定
'DB.TableDefs.Append TD '設定情報のデータベースへ追加。
'Set IDX = Nothing
'Set TD = Nothing
'Set DB = Nothing
End Function
Sub Export_CSV()
'作成者：
'作成日：2016/08/27
'変更日：2016/08/31
'
'※アプリケーション終了のロジックの最終行に記述。
Dim E_Date_Time As String
On Error Resume Next
E_Date_Time = Format(Now(), "yyyymmddhhnnss")
DoCmd.TransferText acExportDelim, "", "Usys_Error_Data", CurrentProject.Path & "\Error_Data" & E_Date_Time & ".csv", True, ""
End Sub
Option Compare Database
Option Explicit
Sub Get_Control_Properties()
'作成者：
'作成日：2019/04/15
'変更日：2019/04/15
Dim Form_Name As String
Dim Ctrol As Control
Dim List_Type As Integer
Dim Prop_Num As Integer
Dim cnt As Integer
Form_Name = "frm_プログレスバー" 'プロパティを取得するフォーム名
DoCmd.OpenForm Form_Name, acDesign
On Error GoTo Err_Task
List_Type = InputBox("検査パターンを入力してください！ 1:一つのコントロールのプロパティを総て取得、2:フォーム内の総てのコントロールの標題を総て取得", "コントロールプロパティ取得", "1") '
Select Case List_Type
Case 1 '一つのコントロールのプロパティを総て取得
With Forms(Form_Name).Controls(2) 'コントロールの番号
Debug.Print .Properties.Count
cnt = 1
For Prop_Num = 0 To .Properties.Count - 1 '{コントロールプロパティの総数}-1
Debug.Print cnt & "-" & .Name & ":" & _
.Properties(Prop_Num).Name & ":" & _
.Properties(Prop_Num).Value
cnt = cnt + 1
Next
End With
Case 2 'フォーム内の総てのコントロールの標題を総て取得
With Forms(Form_Name) 'フォームのプロパティ設定
Debug.Print Forms(Form_Name).Controls.Count
cnt = 1
For Each Ctrol In Forms(Form_Name).Controls
On Error Resume Next
Debug.Print cnt & "-" & Ctrol.Name & ": caption=" & _
Ctrol.Properties("caption")
cnt = cnt + 1
Next
End With
Case Else
End Select
Err_Task:
DoCmd.Close acForm, Form_Name
Exit Sub
End Sub
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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Progress_Bar_Count As Integer
Sub View_Progress_Bar()
'作成者：
'作成日：2019/04/14
'変更日：2019/04/17
'プログレスバーを各ステップ毎に値を決めて、終了時に値を取得して進捗状況を表示する。
'パブリック変数にて値を取得して対応。
'※STEPのコードは、各プロシージャの終了時に設置。
Call View_Progress_Bar_Start
'STEP 01
Call View_Progress_Bar_X(0)
Sleep 1000
'STEP 02
Call View_Progress_Bar_X(15)
Sleep 1000
'STEP 03
Call View_Progress_Bar_X(25)
Sleep 1000
'STEP 04
Call View_Progress_Bar_X(5)
Sleep 1000
'STEP 05
Call View_Progress_Bar_X(10)
Sleep 1000
'STEP 06
Call View_Progress_Bar_X(25)
Sleep 1000
'STEP 07
Call View_Progress_Bar_X(10)
Sleep 1000
'STEP 08
Call View_Progress_Bar_X(10)
Call View_Progress_Bar_End
Exit Sub
End Sub
Sub View_Progress_Bar_Start()
'作成者：
'作成日：2019/04/17
'変更日：2019/04/17
DoCmd.OpenForm "frm_Progress_Bar"
[Forms]![frm_Progress_Bar]![ProgressBar0].Max = 100 'プログレスバーの最高値(10)
[Forms]![frm_Progress_Bar]![ProgressBar0].Min = 0 'プログレスバーの最小値(0)
Progress_Bar_Count = 0 'プログレスバーの値設定
Exit Sub
End Sub
Sub View_Progress_Bar_X(View_Point As Integer)
'作成者：
'作成日：2019/04/17
'変更日：2019/04/17
Progress_Bar_Count = Progress_Bar_Count + View_Point 'プログレスバーの値設定
[Forms]![frm_Progress_Bar]![ProgressBar0].Value = Progress_Bar_Count 'プログレスバーの表示値
DoEvents 'メモリをOSに返す
Exit Sub
End Sub
Sub View_Progress_Bar_End()
'作成者：
'作成日：2019/04/17
'変更日：2019/04/17
MsgBox Progress_Bar_Count & "%" & vbCrLf & "処理が終了しました！", 64, "View_Progress_Bar"
DoCmd.Close acForm, "frm_Progress_Bar"
Exit Sub
End Sub
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
'--------------------------------------------------------------------------------
DoCmd.TransferSpreadsheet
DoCmd.TransferSpreadsheet (TransferType, SpreadsheetType, TableName, FileName, HasFieldNames, Range)
DoCmd.TransferSpreadsheet acImport, 3,"Employees","C:\Lotus\Newemps.wk3", True, "A1:G12"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "オブジェクト一覧", PTH & "オブジェクト一覧_" & Time_Stamp_Get & ".xlsx", False, ""
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "DCVシステム管理", PTH & "\DCVシステム管理" & TS & ".xls", True, ""
'--------------------------------------------------------------------------------
AcSpreadSheetType 列挙 (Access)
名前,値,説明
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 XML 形式
'--------------------------------------------------------------------------------
AcDataTransferType 列挙 (Access)
名前,値,説明
acExport,1,データがエクスポートされます。
acImport,0,(既定値) データがインポートされます。
acLink,2,指定したデータ ソースにデータベース。
'--------------------------------------------------------------------------------
AcTextTransferType 列挙 (Access)
名前,値,説明
acExportDelim,2,区切り記号付きエクスポート
acExportFixed,3,固定長エクスポート
acExportHTML,8,HTML エクスポート
acExportMerge,4,Word 差し込みデータ エクスポート
acImportDelim,0,区切り記号付きインポート
acImportFixed,1,固定長インポート
acImportHTML,7,HTML インポート
acLinkDelim,5,区切り記号付きリンク
acLinkFixed,6,固定長リンク
acLinkHTML,9,HTML リンク
'--------------------------------------------------------------------------------
1,"[\w.\-]+@[\w\-]+\.[\w.\-]+","メールアドレス"
2,"https?://[\w/:%#\$&\?\(\)~\.=\+\-]+","URL（ホームページアドレス）"
3,"\d{4}[/\.年]\d{1,2}[/\.月]\d{1,2}日?","日付"
4,"(〒|ZIP：)\d{3}-\d{4}","郵便番号"
5,"0\d{1,4}-\d{1,4}-\d{4}","電話番号"
6,"0[89]0\d{8}","携帯電話番号(ハイフンなし)"
7,"b.k","bから始まってkで終わる3桁の文字列"
8,"b.*k","bから始まってkで終わる2桁以上の文字列"
9,"b.+k","bから始まってkで終わる3桁以上の文字列"
10,"\d","半角数字"
11,"\D","半角数字以外"
12,"\d+","数字列"
13,"\d{4}","4桁の数字"
14,"\d{4,}","4桁以上の数字"
15,"\d{1,4}","4桁までの数字(1〜4桁の数字)"
16,"\d{4,10}","4桁〜10桁の数字（最長一致）"
17,"\d{4,10}?","4桁〜10桁の数字（最短一致）"
18,"\b\d{1,3}(,\d{3})*\b","桁区切りのカンマ付数字"
19,"\\\d{1,3}(,\d{3})*\b","価格（先頭が「\」の桁区切り付数字列）"
20,"\u","半角英大文字"
21,"\U","半角英大文字以外"
22,"\l","半角英小文字"
23,"\L","半角英小文字以外,"
24,"[\u\l]","半角英字"
25,"[^\u\l]","半角英字以外"
26,"\b[\u\l]+\b","英単語"
27,"[\u\l\d]","半角英数字"
28,"[13579]","1桁の奇数"
29,"\d*[13579]\b","奇数"
30,"[3-7]","3から7までの数字"
31,"[0-9A-F]{2}","0-9とA-Fのいずれか2文字（2桁の16進数）"
32,"[０-９]","全角数字"
33,"[Ａ-Ｚ]+","全角英大文字列"
34,"[一二三四五六七八九十壱弐参拾百千万萬億兆〇]+","漢数字列"
35,"\n","改行"
36,"\x20","半角スペース"
37,"□","全角スペース"
38,"\t","タブコード"
39,"[\x20\t]+","半角スペースかタブコードの繰り返し"
40,"\s","空白文字"
41,"(?i)sample","sampleという文字列（大文字小文字同一視）"
42,"\bam\b","amという単語"
43,"\Bam\B","単語の途中にあるam"
44,"\b[Ww]h.+?\b","whで始まる3文字以上の単語"
45,"大阪|東京","大阪または東京"
46,"大阪(府|市)","大阪府または大阪市"
47,"^○","行頭の○"
48,"^\x20+","行頭の半角スペースの連続"
49,"。$","行末の。"
50,"^\n","空白行"
51,"^.*$","行全体"
52,"<[hH][1-3].*?>","見出しタグ開始（h1〜h3まで）"
53,"</[hH][1-3]>","見出しタグ終了（h1〜h3まで）"
54,"sam(?=ple)","sample の中の sam"
55,"sam(?=ple|ba)","sample か samba の中の sam"
56,"sam(?!ple)","後ろが「ple」ではない「sam」"
57,"(?<=sam)ple","sample の中の ple"
58,"(?<=sam|ap)ple","sample か apple の中の ple"
59,"(?<!sam|ap)ple","前が「saｍ」か「ap」以外の 「ple」"