アクセス小僧：開いているExcelファイルを名前を付けて保存

【前記事】
アクセス小僧：Excelファイルが開いているか確認する
https://cheese999.blog.ss-blog.jp/2022-02-11

に対して、以下の変更をしました。

・出力先のExcelファイルが開いている場合、別の名前を付けて保存し、Excelを閉じる。

【マクロ】
Private Sub myJgTxRx(myQuery1 As String, myJogaiMode1 As Integer, _
myTxMode1 As Integer, myRxMode1 As Integer)
  ' 【機能】クエリの除外状態、送付済状態、受領状態を変更
  ' 【引数】
  ' myQuery1 as String : クエリ名
  ' myJogaiMode1 : 除外状態(1:除外しない、2:除外する、3:両方)
  ' myTxMode1 : 送付済状態(1:－，2:送付済、3:喪中、4:全て)
  ' myRxMode1 : 受領状態(1:－，2:受領、3:全て)
  ' 【変数】
  Dim dbs As Database ' カレントデータベース
  Dim qdf As QueryDef ' クエリ
  Dim strSQL As String ' 現在のSQL文
  Dim reg As Object ' 正規表現オブジェクト
  Dim MyStr1 As String ' 検索パタン
  Dim v2 As String '置換後のパタン
  Dim rep As String ' 置換後のSQL文
  Dim myJogaiMd(2) As Boolean ' 除外状態
  Dim myTxMd(3) As Integer ' 送付済状態
  Dim myRxMd(2) As Integer ' 受領状態
  Dim strFile1, strFile2 As String ' ファイル名
  Dim Ans(2) As Integer ' 答え
  Dim xlApp As Object ' Excelアプリケーション・オブジェクト
  Dim xlBook As Object ' Excelブック・オブジェクト
  Dim myReadOnly1 As Variant ' ExcelブックのReadOnly
  Dim msg As String ' メッセージ
  '【エラー処理】
  On Error GoTo ErrLabel
  ' 【実行コード】

（中略）

  ' クエリをエクセルに書式付きでエクスポート
  ' フルパスのファイル名
  ' strFile1 = "C:\aaa\bbb\" & myQuery1 & ".xls"
  ' Application.CurrentProject.Pathは現在のデータベースファイルのパス
  strFile1 = Application.CurrentProject.Path & "\" & myQuery1 & ".xls"
  Ans(0) = MsgBox("クエリ" & myQuery1 & "をエクセルにエクスポートしますか？" & vbCrLf & strFile1, vbQuestion + vbOKCancel + vbDefaultButton2, "どうする？")
  ' strFile1ファイルが存在するか？
  If Dir(strFile1) <> "" Then
    Ans(1) = vbOK ' 存在する
  Else
    Ans(1) = vbCancel ' 存在しない
  End If
  ' strFile1ファイルが開いているか？
  If (Ans(0) = vbOK) And (Ans(1) = vbOK) Then
    Set xlApp = CreateObject("Excel.Application") ' Excelアプリケーションのオブジェクト
    Set xlBook = xlApp.Workbooks.Open(strFile1) ' Excelワークブックを開く
    myReadOnly1 = xlBook.ReadOnly ' Excelファイルが開いているときTrue
    xlBook.Close ' Excelブックを閉じる
    xlApp.Application.Quit ' Excelアプリケーションを終了
    Set xlBook = Nothing ' 解放
    Set xlApp = Nothing ' 解放
  End If
  ' strFile1ファイルが開いているときの処理
  If (Ans(0) = vbOK) And (Ans(1) = vbOK) And (myReadOnly1 = True) Then
    ' ファイル名の重複を防ぐため、現在時刻の年月日時分秒ミリ秒をファイル名に追加する
    strFile2 = Application.CurrentProject.Path & "\" & myQuery1 & Format(Now, "yyyymmddhhmmssms") & ".xls"
    Ans(2) = MsgBox(strFile1 & "が開いています。" & vbCrLf & strFile2 & "に名前を変更して保存します｡")
    Set xlBook = GetObject(strFile1) ' 開かれているstrFile1のオブジェクト
    Set xlApp = xlBook.Application
    xlBook.SaveAs strFile2 ' strFile2に名前を変更して保存
    xlBook.Close SaveChanges:=False ' Excelブックを閉じる
    xlApp.Application.Quit ' Excelアプリケーションを終了
    ' Ans(2) = MsgBox("一時停止", vbOKOnly)
    Set xlBook = Nothing ' 解放
    Set xlApp = Nothing ' 解放
  End If
  If (Ans(0) = vbOK) Then
    ' Excelにエクスポート
    DoCmd.OutputTo acOutputQuery, myQuery1, acFormatXLS, strFile1, True ' 書式付き
    ' DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, myQuery1, strFile1 ' 書式なし
  End If
  GoTo EndSub
ErrLabel:
  msg = "エラー発生アプリ: " & Err.Source & vbCrLf & _
            "エラー番号: " & Err.Number & vbCrLf & _
            "エラー内容: " & Err.Description
  Ans(2) = MsgBox(msg, vbOKOnly)
EndSub:
End Sub

タグ：VBA Excel access

コメント 1

ヤバイぜ！　ありがとうございます(^_0)ノ
by cheese999 (2022-02-20 14:56)