アクセス小僧：Excelファイルが開いているか確認する

アクセスのクエリをExcelファイルに出力するVBAマクロがあり、出力する前に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 As String ' ファイル名
  Dim Ans As Integer ' 答え
  Dim xlApp As Object ' Excelアプリケーション・オブジェクト
  Dim xlBook As Object ' Excelブック・オブジェクト
  Dim myReadOnly1 As Variant ' ExcelブックのReadOnly
  ' 【実行コード】
  ' 除外状態
  Select Case myJogaiMode1
  Case 1 ' 除外しない
    myJogaiMd(0) = False
    myJogaiMd(1) = False
  Case 2 ' 除外する
    myJogaiMd(0) = True
    myJogaiMd(1) = True
  Case 3 ' 両方
    myJogaiMd(0) = False
    myJogaiMd(1) = True
  Case Else
    myJogaiMd(0) = False
    myJogaiMd(1) = True
  End Select
  ' 送付済状態
  Select Case myTxMode1
  Case 1 ' －
    myTxMd(0) = 1
    myTxMd(1) = 1
    myTxMd(2) = 1
  Case 2 ' 送付済
    myTxMd(0) = 2
    myTxMd(1) = 2
    myTxMd(2) = 2
  Case 3 ' 喪中
    myTxMd(0) = 3
    myTxMd(1) = 3
    myTxMd(2) = 3
  Case 3 ' 全て
    myTxMd(0) = 1
    myTxMd(1) = 2
    myTxMd(2) = 3
  Case Else
    myTxMd(0) = 1
    myTxMd(1) = 2
    myTxMd(2) = 3
  End Select
  ' 受領状態
  Select Case myRxMode1
  Case 1 ' －
    myRxMd(0) = 1
    myRxMd(1) = 1
  Case 2 ' 受領
    myRxMd(0) = 2
    myRxMd(1) = 2
  Case 3 ' 全て
    myRxMd(0) = 1
    myRxMd(1) = 2
  Case Else
    myRxMd(0) = 1
    myRxMd(1) = 2
  End Select
  ' 正規表現による置換
  Set dbs = CurrentDb ' カレントデータベース
  Set qdf = dbs.QueryDefs(myQuery1) ' クエリ
  ' クエリの現在のSQL文を変数にセット
  strSQL = qdf.SQL
  ' 正規表現オブジェクト作成
  Set reg = CreateObject("VBScript.RegExp")
  ' パタン=「WHERE (((T_氏名住所.送付済ID)=1 Or (T_氏名住所.送付済ID)=2 Or (T_氏名住所.送付済ID)=3)
  ' AND ((T_氏名住所.受領ID)=1 Or (T_氏名住所.受領ID)=2) AND ((T_氏名住所.除外)=False Or (T_氏名住所.除外)=True));
  ' 検索パタン(MyStr1)
  MyStr1 = "WHERE\s\(\(\(T_氏名住所\.送付済ID\)=[0-9]\sO[Rr]\s\(T_氏名住所\.送付済ID\)=[0-9]\sO[Rr]\s\(T_氏名住所\.送付済ID\)=[0-9]\)"
  MyStr1 = MyStr1 & "\sA[Nn][Dd]\s\(\(T_氏名住所\.受領ID\)=[0-9]\sO[Rr]\s\(T_氏名住所\.受領ID\)=[0-9]\)"
  MyStr1 = MyStr1 & "\sA[Nn][Dd]\s\(\(T_氏名住所\.除外\)=[A-Za-z]+\sO[Rr]\s\(T_氏名住所\.除外\)=[A-Za-z]+\)\);"
  ' 置換後のパターン(v2)
  v2 = "WHERE (((T_氏名住所.送付済ID)=" & myTxMd(0) & " Or (T_氏名住所.送付済ID)=" & myTxMd(1) & " Or (T_氏名住所.送付済ID)=" & myTxMd(2) & ")"
  v2 = v2 & " AND ((T_氏名住所.受領ID)=" & myRxMd(0) & " Or (T_氏名住所.受領ID)=" & myRxMd(1) & ")"
  v2 = v2 & " AND ((T_氏名住所.除外)=" & myJogaiMd(0) & " Or (T_氏名住所.除外)=" & myJogaiMd(1) & "));"
  ' 置換実行
  With reg
    .pattern = MyStr1 'パターンを設定
    .IgnoreCase = True '大文字と小文字を区別するFalseか、しないTrueか
    .Global = True '文字列全体を検索するTrueか、しないFalseか
    rep = .Replace(strSQL, v2) ' 置換
  End With
  ' クエリのSQL文を変更
  qdf.SQL = rep
  ' 解放
  Set qdf = Nothing
  Set dbs = Nothing
  If Application.SysCmd(acSysCmdGetObjectState, acQuery, myQuery1) <> 0 Then
    ' クエリが開いていたら、開きなおす
    DoCmd.Close acQuery, myQuery1, acSavePrompt
    DoCmd.OpenQuery myQuery1
  Else
    ' クエリが開いていなかったら、開く
    DoCmd.OpenQuery myQuery1
  End If
  ' クエリをエクセルに書式付きでエクスポート
  Ans = MsgBox("クエリ" & myQuery1 & "をエクセルにエクスポートしますか？", vbQuestion + vbOKCancel + vbDefaultButton2, "どうする？")
  If Ans = vbOK Then
    ' フルパスのファイル名
    ' strFile1 = "C:\Users\aaa\Document\bbb\ccc\ddd\" & myQuery1 & ".xls"
    ' Application.CurrentProject.Pathは現在のデータベースファイルのパス
    strFile1 = Application.CurrentProject.Path & "\" & myQuery1 & ".xls"
    Set xlApp = CreateObject("Excel.Application") ' Excelアプリケーションのオブジェクト
    Set xlBook = xlApp.Workbooks.Open(strFile1) ' Excelワークブックを開く
    myReadOnly1 = xlBook.ReadOnly
    xlBook.Close ' Excelブックを閉じる
    xlApp.Application.Quit ' Excelアプリケーションを終了
    Set xlBook = Nothing ' 解放
    Set xlApp = Nothing ' 解放
    If myReadOnly1 Then
      Ans = MsgBox(strFile1 & "が開いています。")
    Else
      ' エクスポート
      DoCmd.OutputTo acOutputQuery, myQuery1, acFormatXLS, strFile1, True
    End If
  End If
End Sub

タグ：VBA access Excel readonly

コメント 1

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