Option Compare Database
Function BackUpFile(FolderPath, FileName)
‘***************フォルダ検索/ファイル検索/ファイルコピー********
‘
‘バックアップ作成場所のフォルダのパスと新規ファイル名を受け取り、
‘フォルダが存在しなければ、新規でフォルダを作成し、カレントファイルをコピー。
‘（yyyymmdd_backup.accdb）
‘***************************************************************
On Error GoTo err_FsoCopy:
Dim MyFSO As New FileSystemObject
‘カレントデータベースのファイル名を取得（コピー元のファイル名）
Dim sFileName As String
sFileName = MyFSO.GetFileName(Application.CurrentDb.Name)
‘フォルダ存在確認
‘Dim FolderPath As String
If Not MyFSO.FolderExists(FolderPath) Then
MsgBox “フォルダが存在しないため、作成します。”
MyFSO.CreateFolder Path:=FolderPath
End If
‘ファイル存在確認
‘Dim FileName As String
FileName = FolderPath & “\” & FileName
If MyFSO.FileExists(FileName) Then
If MsgBox(“同じファイル名が存在します。上書きしますか？”, vbCritical + vbOKCancel) = vbCancel Then
MsgBox “バックアップ処理を中止します。”
BackUpFile = False
Set MyFSO = Nothing
Exit Function
Else
MyFSO.DeleteFile FileSpec:=FileName
End If
End If
‘ファイルコピー
MyFSO.CopyFile Source:=CurrentProject.Path & “\” & sFileName, Destination:=FileName
MsgBox “バックアップ完了しました。”
BackUpFile = True
‘終了処理
err_Exit:
Set MyFSO = Nothing
Exit Function
‘エラー処理
err_FsoCopy:
MsgBox Err.Description
Err.Clear
Resume err_Exit:
End Function
Sub ExcelExport(FolderPath, FileName, TableName)
‘***************テーブルをエクセルでエクスポート******************
‘FolderPath：出力先のパス
‘FileName ：出力後のファイルネーム（.xlsx）
‘TableName ：コピー元のテーブル名
‘*******************************************************
‘On Error GoTo err_FsoExcel:
Dim MyFSO As New FileSystemObject
‘フォルダ存在確認
If Not MyFSO.FolderExists(FolderPath) Then
MsgBox “フォルダが存在しないため、作成します。”
MyFSO.CreateFolder Path:=FolderPath
End If
‘ファイル存在確認
FileName = FolderPath & “\” & FileName
If MyFSO.FileExists(FileName) Then
If MsgBox(“同じファイル名が存在します。上書きしますか？”, vbCritical + vbOKCancel) = vbCancel Then
MsgBox “エクスポートを中止します。”
Set MyFSO = Nothing
Exit Sub
Else
MyFSO.DeleteFile FileSpec:=FileName
End If
End If
‘エクスポート
DoCmd.OutputTo acOutputTable, TableName, acFormatXLSX, FileName, True
MsgBox “エクセルファイルで出力しました。”
‘終了処理
err_Exit:
Set MyFSO = Nothing
Exit Sub
‘エラー処理
err_FsoExcel:
MsgBox Err.Description
Err.Clear
Resume err_Exit:
End Sub
Sub ExcelExport2(FolderPath, FileName, TableName)
‘***************クエリをエクセルでエクスポート******************
‘FolderPath：出力先のパス
‘FileName ：出力後のファイルネーム（.xlsx）
‘TableName ：コピー元のテーブル名
‘*******************************************************
‘On Error GoTo err_FsoExcel:
Dim MyFSO As New FileSystemObject
‘フォルダ存在確認
If Not MyFSO.FolderExists(FolderPath) Then
MsgBox “フォルダが存在しないため、作成します。”
MyFSO.CreateFolder Path:=FolderPath
End If
‘ファイル存在確認
FileName = FolderPath & “\” & FileName
If MyFSO.FileExists(FileName) Then
If MsgBox(“同じファイル名が存在します。上書きしますか？”, vbCritical + vbOKCancel) = vbCancel Then
MsgBox “エクスポートを中止します。”
Set MyFSO = Nothing
Exit Sub
Else
MyFSO.DeleteFile FileSpec:=FileName
End If
End If
‘エクスポート
DoCmd.OutputTo acOutputQuery, TableName, acFormatXLSX, FileName, True
MsgBox “エクセルファイルで出力しました。”
‘終了処理
err_Exit:
Set MyFSO = Nothing
Exit Sub
‘エラー処理
err_FsoExcel:
MsgBox Err.Description
Err.Clear
Resume err_Exit:
End Sub