Access (VBA)

Access VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 8 : Access 2013)
前任作成の印刷ツール改修について
投稿日時: 18/05/02 11:42:11
投稿者: 2011wing

印刷ツールのExcelの書式が変更になり差し替えましたが正常作動しません。
 
Option Compare Database
Option Explicit
 
Function データ取込_Main(prFName As String)
 
    Dim tBook As Object
    Dim tSHT As Object
    Dim strSHTName As String
     
    データ取込_Main = True
     
    'ファイルを開く
    Set xls = CreateObject("Excel.Application")
    xls.Workbooks.Open FileName:=prFName
     
    'ファイル情報取得
    Set tBook = xls.ActiveWorkbook
     
    'シートを確認
    If Not シート有無確認(tBook, conSHTName_再出力BP一覧) Then
        MsgBox "指定されたファイルに【" & conSHTName_再出力BP一覧 & "】が存在しません。"
        GoTo ERR_END
    End If
     
    '取込開始
    Set tSHT = tBook.Sheets(conSHTName_再出力BP一覧)
    If Not データ取込(tSHT) Then
        GoTo ERR_END
    End If
 
 
'##################################################
NORMAL_END:
    '後処理
     
    'ターゲットを閉じる
    tBook.Close SaveChanges:=False
 
    'エクセルの終了
    xls.Quit
    Set xls = Nothing
     
    Exit Function
     
ERR_END:
 
    データ取込_Main = False
    GoTo NORMAL_END
     
End Function
 
Function データ取込(prSHT As Object) As Boolean
 
    データ取込 = True
     
    Dim CN As New ADODB.Connection
    Dim RS As New ADODB.Recordset
     
    Dim C As Variant
    Dim lngLastRow As Long
     
    Dim lngRow As Long
    Dim i As Integer
     
    'CN 初期化
    Set CN = CurrentProject.Connection
     
    'テーブルリセット
    DoCmd.RunSQL "DELETE * FROM TW01_取込データ;"
     
    'テーブルを開く
    RS.Open "TW01_取込データ", CN, adOpenDynamic, adLockOptimistic
     
    '該当データを配列に格納
    With prSHT
        lngLastRow = .Range("A1").CurrentRegion.Rows.Count
        C = .Range(.Cells(1, 1), .Cells(lngLastRow, 8))
    End With
     
    '入力データが無い場合は終了
    If lngLastRow <= 1 Then
        MsgBox "指定されたファイルにデータが入力されていません。"
        データ取込 = False
        GoTo NORMAL_END
    End If
     
    'データインポート
    For lngRow = 2 To UBound(C, 1) '「ビジネスパートナー番号」のインデックス番号の最大値
        With RS
            'ビジネスパートナー番号が入力されているデータのみ出力
            If C(lngRow, 4) <> "" Then
                .AddNew
             
                ![NO] = lngRow - 1
                ![リストNo] = C(lngRow, 1)
                ![登録日] = C(lngRow, 2)
                ![登録者] = C(lngRow, 3)
                ![ビジネスパートナー番号] = C(lngRow, 4)
                ![印刷日時] = C(lngRow, 5)
                ![印刷者] = C(lngRow, 6)
                ![挨拶状フルパス] = C(lngRow, 7)
                ![ご契約内容一覧フルパス] = C(lngRow, 8)
             
                .Update
            End If
        End With
    Next lngRow
     
 
'###############################################
NORMAL_END:
    '解放
    RS.Close: Set RS = Nothing
    CN.Close: Set CN = Nothing
     
End Function
 
 
Option Compare Database
Option Explicit
 
Dim CN As New ADODB.Connection '「元データ作成」-「makeTBL」モジュールで使用
Dim RSout As New ADODB.Recordset 'ご契約内容一覧作成モジュールで使用
 
Dim IntF01_SelectData As Integer 'プラス割リスト選択
 
Sub 再印刷ファイル作成_Main()
 
    Dim CN2 As New ADODB.Connection
    Dim RS As New ADODB.Recordset
    Dim lngRcCnt As Long
     
If strDEBUG = "debug" Then Debug.Print "再印刷ファイル作成_Main Step1 :(1) " & Forms!F01_Main.Chk_SelectData1 & " (2) " & Forms!F01_Main.Chk_SelectData2
 
    'CN 初期化
    Set CN2 = CurrentProject.Connection
     
    '静的カーソル(他のユーザーが更新したレコードは表示されません) レコードごとに共有ロック
    RS.Open "Q301_再出力ファイル作成対象データ_BP番号順", CN2, adOpenStatic, adLockOptimistic
     
    Do Until RS.EOF
 
        lngRcCnt = 0
         
        If Forms!F01_Main.Chk_SelectData1 = True Then
If strDEBUG = "debug" Then Debug.Print "再印刷ファイル作成_Main @データ検索SelectData1 (" & lngRcCnt & ") No=" & RS![リストNo] & " BP番号=" & RS![ビジネスパートナー番号]
             
            IntF01_SelectData = 1
             
            Call 元データ作成_参照(RS![ビジネスパートナー番号], 1)
             
            lngRcCnt = ファイル作成(RS![ビジネスパートナー番号])
                               
        End If
 
        If Forms!F01_Main.Chk_SelectData2 = True And lngRcCnt = 0 Then
If strDEBUG = "debug" Then Debug.Print "再印刷ファイル作成_Main Aデータ検索SelectData2 (" & lngRcCnt & ") BP番号=" & RS![ビジネスパートナー番号]
 
            IntF01_SelectData = 2
 
            Call 元データ作成_参照(RS![ビジネスパートナー番号], 2)
             
            lngRcCnt = ファイル作成(RS![ビジネスパートナー番号])
 
        End If
         
        RS.MoveNext
 
    Loop
 
    RS.Close: Set RS = Nothing
    CN2.Close: Set CN2 = Nothing
 
End Sub
 
'外部テーブル参照:外部テーブルはローカルテーブルのためロックは作成しない
Function 元データ作成_参照(prビジネスパートナー番号 As String, pr選択Data As Integer)
 
    Dim strSQL As String
     
    元データ作成_参照 = False
 
    'CN 初期化
    Set CN = CurrentProject.Connection
     
    'DM情報取得
    Select Case pr選択Data
        Case 1
            'Chk_SelectData1 選択あり
            strSQL = "SELECT Lnk01_1_DM01_DM情報1.* INTO TW011_DM" & _
                            " FROM Lnk01_1_DM01_DM情報1" & _
                            " WHERE Lnk01_1_DM01_DM情報1.[6_ビジネスパートナー番号] = '" & prビジネスパートナー番号 & "'" & _
                            " ORDER BY Lnk01_1_DM01_DM情報1.[ID] ;"
        Case 2
            'Chk_SelectData2 選択あり
            strSQL = "SELECT Lnk01_2_DM01_DM情報2.* INTO TW011_DM" & _
                            " FROM Lnk01_2_DM01_DM情報2" & _
                            " WHERE Lnk01_2_DM01_DM情報2.[6_ビジネスパートナー番号] = '" & prビジネスパートナー番号 & "'" & _
                            " ORDER BY Lnk01_2_DM01_DM情報2.[ID] ;"
    End Select
If strDEBUG = "debug" Then Debug.Print "元データ作成 strSQL→" & strSQL
     
    If Not makeTBL("DM01", "TW011_DM", strSQL) Then
        Exit Function
    End If
     
    元データ作成_参照 = True
     
    CN.Close: Set CN = Nothing
 
End Function
 
Function makeTBL_Rock(prDBname As String, prTBLName As String, prStrSQL As String) As Boolean
'外部テーブル参照のためロックを作成する
 
On Error GoTo ErrHandler
 
    makeTBL_Rock = True
     
    DoCmd.SetWarnings False
 
    'ロックファイルを作成
    If Not tryLock(Forms!F01_Main.txtパス, conLckFile, Forms!F01_Main.txtMyID) Then
        makeTBL_Rock = False
        Exit Function
    End If
     
    On Error Resume Next
    CurrentDb.TableDefs.Delete (prTBLName)
    On Error GoTo 0
     
    'なければテーブル作成
    CN.Execute prStrSQL
     
ErrHandler:
    If Err Then
        makeTBL_Rock = False
        MsgBox (Err.Number & vbCrLf & Err.Description & vbCrLf & Err.Source)
    End If
     
NORMAL_END:
    DoCmd.SetWarnings True
     
    ' ロック解除
    If Not tryUnlock(Forms!F01_Main.txtパス, conLckFile, Forms!F01_Main.txtMyID) Then
        Exit Function
    End If
 
End Function
 
Function makeTBL(prDBname As String, prTBLName As String, prStrSQL As String) As Boolean
'外部テーブル参照でもロックなし
 
On Error GoTo ErrHandler
 
    makeTBL = True
 
    DoCmd.SetWarnings False
 
    '.laccdbがあるか確認
    If chkFile(Forms!F01_Main.txtパス & prDBname & ".laccdb") Then
        MsgBox "DB使用中です。" & _
              "少し時間をおいてから再度実行してください。"
        makeTBL = False
        GoTo ErrHandler
    End If
 
    On Error Resume Next
    CurrentDb.TableDefs.Delete (prTBLName)
    On Error GoTo 0
 
    'なければテーブル作成
    CN.Execute prStrSQL
 
ErrHandler:
 
    If Err Then
        makeTBL = False
        MsgBox (Err.Number & vbCrLf & Err.Description & vbCrLf & Err.Source)
    End If
 
    DoCmd.SetWarnings True
 
End Function
 
Function ファイル作成(prビジネスパートナー番号 As String) As Long
         
    ファイル作成 = DCount("*", "TW011_DM")
     
If strDEBUG = "debug" Then Debug.Print "ファイル作成 BP番号=" & prビジネスパートナー番号 & " 件数= " & ファイル作成
 
    If ファイル作成 > 0 Then
     
        '該当データあり
        strMSG_TW02 = ""
        Call TW02_データチェック更新(prビジネスパートナー番号, 1)
         
        datTimeStamp = Now()
                 
        '挨拶状(word)作成
        If Not 挨拶状作成() Then
            '挨拶状が作成できないときは、処理終了
            ファイル作成 = -1
            Exit Function
        End If
         
        If Not ご契約内容一覧作成() Then
            'ご契約内容一覧が作成できないときは、処理終了
            ファイル作成 = -1
            Exit Function
        End If
         
    Else
     
        '該当データなし
        strMSG_TW02 = ""
        Call TW02_データチェック更新(prビジネスパートナー番号, 9)
         
        '挨拶状フルパス更新(空白)
        Call TW02_フルパス更新(prビジネスパートナー番号, "", 1)
        'ご契約内容一覧フルパス更新(空白)
        Call TW02_フルパス更新(prビジネスパートナー番号, "", 2)
 
    End If
 
End Function
 
Function 挨拶状作成()
 
    Dim CN2 As New ADODB.Connection
    Dim RS As New ADODB.Recordset
     
    Dim wdApp As word.Application
    Dim wdDoc As word.Document
    Dim wdSelection As Object
 
    Dim StrWORDmaster As String
    Dim StrWORDmasterName As String
    Dim StrWORDmaster拡張子 As String
 
    Dim strMasterFileName As String
     
    Dim strビジネスパートナー番号 As String
    Dim str郵便番号 As String
    Dim str郵送名義1 As String
    Dim str郵送名義2 As String
     
    Dim lngガスあり As Long
     
    On Error GoTo ErrHandler
     
    挨拶状作成 = True
     
    'CN 初期化
    Set CN2 = CurrentProject.Connection
     
    '静的カーソル(他のユーザーが更新したレコードは表示されません) 読み取り専用
    RS.Open "TW011_DM", CN2, adOpenStatic, adLockReadOnly
     
    RS.MoveFirst '最初のレコードに移動
 
    strビジネスパートナー番号 = Nz(RS![6_ビジネスパートナー番号], "")
If strDEBUG = "debug" Then Debug.Print "挨拶状作成: ID=" & RS![ID]
If strDEBUG = "debug" Then Debug.Print "挨拶状作成: BP番号=" & RS![6_ビジネスパートナー番号]
If strDEBUG = "debug" Then Debug.Print "挨拶状作成: 24_天気のみ/ガスあり=" & RS![24_天気のみ/ガスあり]
 
    '出力ファイル名を決定
    lngガスあり = DCount("*", "TW011_DM", "[24_天気のみ/ガスあり]=2")
If strDEBUG = "debug" Then Debug.Print "挨拶状作成: lngガスあり件数=" & lngガスあり
If strDEBUG = "debug" Then Debug.Print "挨拶状作成: lng天気のみ件数=" & DCount("*", "TW011_DM", "[24_天気のみ/ガスあり]=1")
 
' Select Case RS![24_天気のみ/ガスあり]
' Case 1
' '天気のみ conWORDmaster1
' StrWORDmaster = DLookup("[テンプレートファイル名]", "TM_テンプレートファイル名", "テンプレート区分 = 'conWORDmaster1'")
' StrWORDmasterName = DLookup("[テンプレート名]", "TM_テンプレートファイル名", "テンプレート区分 = 'conWORDmaster1'")
' StrWORDmaster拡張子 = DLookup("[テンプレート拡張子]", "TM_テンプレートファイル名", "テンプレート区分 = 'conWORDmaster1'")
' Case 2
' '天気・ガス用 conWORDmaster2
' StrWORDmaster = DLookup("[テンプレートファイル名]", "TM_テンプレートファイル名", "テンプレート区分 = 'conWORDmaster2'")
' StrWORDmasterName = DLookup("[テンプレート名]", "TM_テンプレートファイル名", "テンプレート区分 = 'conWORDmaster2'")
' StrWORDmaster拡張子 = DLookup("[テンプレート拡張子]", "TM_テンプレートファイル名", "テンプレート区分 = 'conWORDmaster2'")
' End Select
     
    If lngガスあり = 0 Then
If strDEBUG = "debug" Then Debug.Print "挨拶状作成: ******* 天気のみ"
            '天気のみ conWORDmaster1
            StrWORDmaster = DLookup("[テンプレートファイル名]", "TM_テンプレートファイル名", "テンプレート区分 = 'conWORDmaster1'")
            StrWORDmasterName = DLookup("[テンプレート名]", "TM_テンプレートファイル名", "テンプレート区分 = 'conWORDmaster1'")
            StrWORDmaster拡張子 = DLookup("[テンプレート拡張子]", "TM_テンプレートファイル名", "テンプレート区分 = 'conWORDmaster1'")
    Else
If strDEBUG = "debug" Then Debug.Print "挨拶状作成: ******** 天気・ガス用"
            '天気・ガス用 conWORDmaster2
            StrWORDmaster = DLookup("[テンプレートファイル名]", "TM_テンプレートファイル名", "テンプレート区分 = 'conWORDmaster2'")
            StrWORDmasterName = DLookup("[テンプレート名]", "TM_テンプレートファイル名", "テンプレート区分 = 'conWORDmaster2'")
            StrWORDmaster拡張子 = DLookup("[テンプレート拡張子]", "TM_テンプレートファイル名", "テンプレート区分 = 'conWORDmaster2'")
    End If
     
    strOutFileName挨拶 = Forms!F01_Main!txtパス_出力 & conOutFolder & "\" & _
                                        RS![6_ビジネスパートナー番号] & "_" & StrWORDmasterName & "_" & _
                                        Format(datTimeStamp, "yyyymmddhhmmss") & StrWORDmaster拡張子
    strMasterFileName = Forms!F01_Main!txtパス_出力 & conTemp & "\" & StrWORDmaster
     
If strDEBUG = "debug" Then Debug.Print "挨拶状作成: 出力ファイルパス=" & strOutFileName挨拶
If strDEBUG = "debug" Then Debug.Print "挨拶状作成: マスタファイルパス=" & strMasterFileName
 
    'ワードマスタ開く
    Set wdApp = CreateObject("word.Application")
    Set wdDoc = wdApp.Documents.Open(strMasterFileName)
    Set wdSelection = wdApp.Selection '冒頭にSelectionオブジェクトのインスタンスを作成
     
    wdApp.Visible = True
    wdDoc.ActiveWindow.View = wdPrintView '編集モードに移行(観覧モードでは置換ができないため)
    wdApp.WindowState = wdWindowStateMinimize '最小化
''''' wdDoc.Activate
 
    '@郵便番号
    '★7桁なくても「頭3桁-残り」で郵便番号作成
    If IsNull(RS![1_郵便番号]) Then
        str郵便番号 = " - "
    Else
        str郵便番号 = Left(RS![1_郵便番号], 3) & "-" & Mid(RS![1_郵便番号], 4, Len(RS![1_郵便番号]) - 3)
    End If
     
    Call wordReplaceText(wdSelection, "@郵便番号", str郵便番号)
         
    'A郵送住所1
    Call wordReplaceText(wdSelection, "A郵送住所1", Nz(RS![2_郵送住所1], ""))
     
    'B郵送住所2
    Call wordReplaceText(wdSelection, "B郵送住所2", Nz(RS![3_郵送住所2], ""))
     
    'C郵送名義1
    str郵送名義1 = Nz(RS![4_郵送名義1], "")
    If IsNull(RS![5_郵送名義2]) Then str郵送名義1 = str郵送名義1 & " 様"
     
    Call wordReplaceText(wdSelection, "C郵送名義1", str郵送名義1)
     
    'D郵送名義2
    str郵送名義2 = Nz(RS![5_郵送名義2], "")
    If Not IsNull(RS![5_郵送名義2]) Then str郵送名義2 = str郵送名義2 & " 様"
    Call wordReplaceText(wdSelection, "D郵送名義2", str郵送名義2)
   
    'Eビジネスパートナー番号
    Call wordReplaceText(wdSelection, "Eビジネスパートナー番号", strビジネスパートナー番号)
     
    '名前を付けて保存
    wdDoc.SaveAs strOutFileName挨拶
 
    'ワードの終了
  wdApp.Quit
 
    '挨拶状フルパス更新
    Call TW02_フルパス更新(strビジネスパートナー番号, strOutFileName挨拶, 1)
 
NORMAL_END:
 
  Set wdDoc = Nothing
  Set wdApp = Nothing
   
  RS.Close: Set RS = Nothing
  CN2.Close: Set CN2 = Nothing
 
    Exit Function
     
'エラー処理
ErrHandler:
 
    'マスタは保存しないで閉じる
    wdApp.Quit SaveChanges:=wdDoNotSaveChanges
   
    If Err Then
        '作成エラー
        strMSG_TW02 = "(挨拶状)"
        Call TW02_データチェック更新(RS![6_ビジネスパートナー番号], 7)
 
        MsgBox (Err.Number & vbCrLf & Err.Description & vbCrLf & Err.Source)
        挨拶状作成 = False
    End If
     
    GoTo NORMAL_END
     
End Function
 
Sub wordReplaceText(prWdSelection As Object, strFind As String, strReplace As String)
 
    'Application.ScreenUpdating = False
' ActiveDocument.Content.Select 'アクティブな文書のすべての範囲
 
    With prWdSelection.Find
        '検索データ設定
        .ClearFormatting
       
        .Forward = True '検索方向:文書の最後に向かって
        .MatchWholeWord = True '単語のみを照合
'2018/1/29コンパイルエラーのためコメント''' .Wrap = wdWrapContinue '文書全体検索
 
        .Execute FindText:=strFind, _
                            Replace:=wdReplaceAll, ReplaceWith:=strReplace
  End With
   
End Sub
 
Function ご契約内容一覧作成()
     
    Dim CN2 As New ADODB.Connection
 
    Dim xlsApp As excel.Application
    Dim myBook As excel.Workbook
    Dim mySHT As Object
     
    Dim StrEXLmaster As String
    Dim StrEXLmasterName As String
    Dim StrEXLmaster拡張子 As String
 
    Dim strMasterFileName As String
     
    Dim strビジネスパートナー番号 As String
 
    Dim lngMaxRcCnt As Long
    Dim lngRcCnt As Long
     
    On Error GoTo ErrHandler
 
    ご契約内容一覧作成 = True
     
    'CN 初期化
    Set CN2 = CurrentProject.Connection
     
    '静的カーソル(他のユーザーが更新したレコードは表示されません) 読み取り専用
    RSout.Open "TW011_DM", CN2, adOpenStatic, adLockReadOnly
     
    '「TW011_DM」テーブル件数
    lngMaxRcCnt = RSout.RecordCount
If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧作成: lngMaxRcCnt=" & lngMaxRcCnt
     
    RSout.MoveFirst '最初のレコードに移動
 
    strビジネスパートナー番号 = Nz(RSout![6_ビジネスパートナー番号], "")
If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧作成: ID=" & RSout![ID]
If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧作成: BP番号=" & RSout![6_ビジネスパートナー番号]
     
    '出力ファイル名を決定
    Select Case IntF01_SelectData
        Case 1
            '2017年10月時点(Forms!F01_MAIN.Chk_SelectData1 にチェックあり)
            'conEXLmaster1
            StrEXLmaster = DLookup("[テンプレートファイル名]", "TM_テンプレートファイル名", "テンプレート区分 = 'conEXLmaster1'")
            StrEXLmasterName = DLookup("[テンプレート名]", "TM_テンプレートファイル名", "テンプレート区分 = 'conEXLmaster1'")
            StrEXLmaster拡張子 = DLookup("[テンプレート拡張子]", "TM_テンプレートファイル名", "テンプレート区分 = 'conEXLmaster1'")
 
        Case 2
            '2018年1月時点(Forms!F01_MAIN.Chk_SelectData2 にチェックあり)
            'conEXLmaster2
            StrEXLmaster = DLookup("[テンプレートファイル名]", "TM_テンプレートファイル名", "テンプレート区分 = 'conEXLmaster2'")
            StrEXLmasterName = DLookup("[テンプレート名]", "TM_テンプレートファイル名", "テンプレート区分 = 'conEXLmaster2'")
            StrEXLmaster拡張子 = DLookup("[テンプレート拡張子]", "TM_テンプレートファイル名", "テンプレート区分 = 'conEXLmaster2'")
    End Select
 
    strOutFileName契約内容一覧 = Forms!F01_Main!txtパス_出力 & conOutFolder & "\" & _
                                                    RSout![6_ビジネスパートナー番号] & "_" & StrEXLmasterName & "_" & _
                                                    Format(datTimeStamp, "yyyymmddhhmmss") & StrEXLmaster拡張子
    strMasterFileName = Forms!F01_Main!txtパス_出力 & conTemp & "\" & StrEXLmaster
 
If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧作成: 出力ファイルパス=" & strOutFileName契約内容一覧
If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧作成: マスタファイルパス=" & strMasterFileName
     
    'エクセルマスタ開く
    Set xlsApp = CreateObject("Excel.Application")
    xlsApp.Workbooks.Open strMasterFileName
    Set myBook = xlsApp.ActiveWorkbook
     
'★開発中のため表示
    xlsApp.WindowState = xlMinimized 'Excel最小化(改ページ設定がうまくいかないのでコメント)
    xlsApp.Visible = True 'Excelを見えるようにしないと改ページ設定がうまくいかないかも?
     
    Set mySHT = myBook.Sheets(conSHTName)
''' mySHT.Select '2018/2/1エラー1004のため入れてみたがコメントでも動くのでコメントとする
''' mySHT.Activate '2018/2/1エラー1004のため入れてみたがコメントでも動くのでコメントとする
 
    xlsApp.Calculation = xlCalculationManual '自動計算停止
     
    '初期化
    lngRcCnt = 0
 
    Do Until RSout.EOF
 
        lngRcCnt = lngRcCnt + 1
         
If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧作成:(" & lngRcCnt & ") ID=" & RSout![ID]
If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧作成:(" & lngRcCnt & ") BP番号=" & RSout![6_ビジネスパートナー番号]
             
        If lngRcCnt = 1 Then
         
            'ご契約内容一覧 表題(Excel)作成
            If Not ご契約内容一覧_表題(mySHT, lngMaxRcCnt) Then
                'ご契約内容一覧(表題)が作成できないときは、処理終了
                GoTo ERR_END
            End If
             
        End If
         
        'ご契約内容一覧 明細(Excel)作成
        If Not ご契約内容一覧_明細(mySHT, lngRcCnt) Then
            'ご契約内容一覧(明細)が作成できないときは、処理終了
            GoTo ERR_END
        End If
         
        RSout.MoveNext
 
    Loop
     
    xlsApp.Calculation = xlCalculationAutomatic '自動計算再開
 
    '名前を付けて保存
    xlsApp.DisplayAlerts = False
    myBook.SaveAs FileName:=strOutFileName契約内容一覧
    xlsApp.DisplayAlerts = True
 
    'エクセルの終了
    xlsApp.Quit
     
    'ご契約内容一覧フルパス更新
    Call TW02_フルパス更新(strビジネスパートナー番号, strOutFileName契約内容一覧, 2)
 
NORMAL_END:
 
    Set mySHT = Nothing
    Set myBook = Nothing
    Set xlsApp = Nothing
       
    RSout.Close: Set RSout = Nothing
    CN2.Close: Set CN2 = Nothing
 
    Exit Function
 
ERR_END:
 
    'マスタは保存しないで閉じる
    myBook.Close SaveChanges:=False
 
    ご契約内容一覧作成 = False
     
    GoTo NORMAL_END
 
'エラー処理
ErrHandler:
 
    'マスタは保存しないで閉じる
    myBook.Close SaveChanges:=False
     
    If Err Then
        MsgBox ("ご契約内容一覧作成" & vbCrLf & Err.Number & vbCrLf & Err.Description & vbCrLf & Err.Source)
        ご契約内容一覧作成 = False
    End If
     
    GoTo NORMAL_END
 
End Function
 
Function ご契約内容一覧_表題(prSHT As Object, prMaxRcCnt As Long)
 
    Dim int口数Page As Long
    Dim int改行row As Long
     
    Dim lngRowPaste As Long
    Dim i As Long
     
    On Error GoTo ErrHandler
     
    ご契約内容一覧_表題 = True
     
If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧_表題: prMaxRcCnt=" & prMaxRcCnt
     
If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧_表題: ID=" & RSout![ID]
If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧_表題: BP番号=" & RSout![6_ビジネスパートナー番号]
 
' With prBook.Sheets(conSHTName) '対象シート
    With prSHT
     
        'Eビジネスパートナー番号
        .Range("A12").Value = "ビジネスパートナー番号:" & Nz(RSout![6_ビジネスパートナー番号], "")
     
        'F口数
        '.Range("A17").Value = Val(RSout![7_口数])
        If IsNumeric(RSout![7_口数]) Then
        .Range("H14").Value = Val(RSout![7_口数])
        Else
        .Range("H14").Value = "-"
        End If
 
        'G1年間の合計天気料金
        '.Range("B17").Value = Val(RSout![8_1年間の合計天気料金])
        'If IsNumeric(RSout![8_1年間の合計天気料金]) Then
        '.Range("B17").Value = Val(RSout![8_1年間の合計天気料金])
        'Else
        '.Range("B17").Value = "-"
        'End If
 
        'H1年目_2年目割引額
        '.Range("L17").Value = Val(RSout![9_1年目_2年目割引額])
        'If IsNumeric(RSout![9_1年目_2年目割引額]) Then
        '.Range("L17").Value = Val(RSout![9_1年目_2年目割引額])
        'Else
        '.Range("L17").Value = "-"
        'End If
 
        'I1年目_2年目割引率
        '.Range("U17").Value = Val(RSout![10_1年目_2年目割引率]) / 100
        'If IsNumeric(RSout![10_1年目_2年目割引率]) / 100 Then
        '.Range("U17").Value = Val(RSout![10_1年目_2年目割引率]) / 100
        'Else
        '.Range("U17").Value = "-"
        'End If
 
        'J3年目_4年目割引額
        '.Range("Z17").Value = Val(RSout![11_3年目_4年目割引額])
        ' If IsNumeric(RSout![11_3年目_4年目割引額]) Then
        '.Range("Z17").Value = Val(RSout![11_3年目_4年目割引額])
        'Else
        '.Range("Z17").Value = "-"
        'End If
 
        'K3年目_4年目割引率
        '.Range("AI17").Value = Val(RSout![12_3年目_4年目割引率]) / 100
        ' If IsNumeric(RSout![12_3年目_4年目割引率]) / 100 Then
        '.Range("AI17").Value = Val(RSout![12_3年目_4年目割引率]) / 100
        'Else
        '.Range("AI17").Value = "-"
        'End If
 
        'L5年目以降割引額
        '.Range("AN17").Value = Val(RSout![13_5年目以降割引額])
        'If IsNumeric(RSout![13_5年目以降割引額]) Then
        '.Range("AN17").Value = Val(RSout![13_5年目以降割引額])
        'Else
        '.Range("AN17").Value = "-"
        'End If
 
        'M5年目以降割引率
        '.Range("AW17").Value = Val(RSout![14_5年目以降割引率]) / 100
        'If IsNumeric(RSout![14_5年目以降割引率]) / 100 Then
        '.Range("AW17").Value = Val(RSout![14_5年目以降割引率]) / 100
        'Else
        '.Range("AW17").Value = "-"
        'End If
 
        '口数分の明細行をコピーする
        lngRowPaste = 15 '明細「1」の先頭行を初期値に設定
        For i = 2 To prMaxRcCnt
            lngRowPaste = lngRowPaste + 9
            .Rows("15:23").Copy .Rows(lngRowPaste)
            .Range("A" & lngRowPaste) = i
        Next i
         
        '印刷範囲を設定
        .PageSetup.PrintArea = "A1:BA" & (lngRowPaste + 8)
         
        If prMaxRcCnt >= 6 Then
         
            '1P目と2P目の改ページを追加(水平方向)
            .HPageBreaks.Add Before:=.Range("A65")
             
            '全明細数から1P目の5明細分を差し引き、2P目以降印刷される7明細が何ページあるか算出
            int口数Page = ((prMaxRcCnt - 5) / 7) + 0.5
 
If strDEBUG = "debug" Then Debug.Print "int口数page = " & int口数Page
           
            '改ページ設定行を算出 計算式 2P目の開始行(65行目)に対象ページ×63行(7明細)を足す
            'ただし、印刷範囲内の場合のみ改行設定を行う
             
            For i = 1 To int口数Page
                 
                '1P目は64行(5明細) 2P目以降は63行(7明細)基準
                int改行row = 65 + (i * 63)
                 
                If int改行row <= (lngRowPaste + 8) Then
If strDEBUG = "debug" Then Debug.Print "Hpagebreaks.add = A" & int改行row
                    .HPageBreaks.Add Before:=.Range("A" & int改行row)
 
                End If
             
            Next i
             
        End If
         
    End With
 
NORMAL_END:
 
    Exit Function
     
'エラー処理
ErrHandler:
   
    If Err Then
        '作成エラー
        strMSG_TW02 = "(ご契約内容一覧 表題)"
        Call TW02_データチェック更新(RSout![6_ビジネスパートナー番号], 7)
 
        MsgBox ("ご契約内容一覧_表題" & vbCrLf & Err.Number & vbCrLf & Err.Description & vbCrLf & Err.Source)
        ご契約内容一覧_表題 = False
    End If
     
    GoTo NORMAL_END
     
End Function
 
Function ご契約内容一覧_明細(prSHT As Object, prRecCnt As Long)
     
    Dim lngRowPasteST As Long
    Dim lngRowPaste As Long
     
    Dim str供給地点特定番号 As String
    Dim str日付 As String
    Dim datご契約満了予定日 As Date
   
    On Error GoTo ErrHandler
 
    ご契約内容一覧_明細 = True
 
If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧_明細: prRecCnt=" & prRecCnt
If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧_明細: ID=" & RSout![ID]
If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧_明細: BP番号=" & RSout![6_ビジネスパートナー番号]
If strDEBUG = "debug" And RSout![6_ビジネスパートナー番号] = "1000000040" Then
Debug.Print "---------------ここからチェック"
End If
    lngRowPasteST = 15 + (9 * (prRecCnt - 1)) '明細行の設定 明細「1」の開始行=15 + (明細9行 × (出力する明細No-1))
If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧_明細: lngRowPasteST=" & lngRowPasteST
 
' With prBook.Sheets(conSHTName) '対象シート
 
    With prSHT
            'Nご契約名義 (第一名義)
            lngRowPaste = lngRowPasteST + 1
            .Range("B" & lngRowPaste).Value = Nz(RSout![15_ご契約名義(第一名義)], "")
If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧_明細: Nご契約名義 (第一名義)end"
           
            '16_ご契約名義(第二名義)
            lngRowPaste = lngRowPasteST + 2
            .Range("B" & lngRowPaste).Value = Nz(RSout![16_ご契約名義(第二名義)], "")
If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧_明細: 16_ご契約名義(第二名義)end"
             
            '17_ご契約住所
            lngRowPaste = lngRowPasteST + 4
            .Range("B" & lngRowPaste).Value = Nz(RSout![17_ご契約住所], "")
If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧_明細: 17_ご契約住所end"
             
            '18_ご契約住所(建物名)
            lngRowPaste = lngRowPasteST + 5
            .Range("B" & lngRowPaste).Value = Nz(RSout![18_ご契約住所(建物名)], "")
If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧_明細: 18_ご契約住所(建物名)end"
             
            '19_供給地点特定番号識別番号
            lngRowPaste = lngRowPasteST + 7
            If IsNull(RSout![19_供給地点特定番号識別番号]) Then
                str供給地点特定番号 = ""
            Else
                str供給地点特定番号 = Left(RSout![19_供給地点特定番号識別番号], 2) & _
                                                    "-" & Mid(RSout![19_供給地点特定番号識別番号], 3, 4) & _
                                                    "-" & Mid(RSout![19_供給地点特定番号識別番号], 7, 4) & _
                                                    "-" & Mid(RSout![19_供給地点特定番号識別番号], 11, 4) & _
                                                    "-" & Mid(RSout![19_供給地点特定番号識別番号], 15, 4) & _
                                                    "-" & Mid(RSout![19_供給地点特定番号識別番号], 19, 4)
            End If
            .Range("B" & lngRowPaste).Value = str供給地点特定番号
If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧_明細: 19_供給地点特定番号識別番号end"
 
            '20_ご契約プラン
            lngRowPaste = lngRowPasteST + 7
            .Range("Y" & lngRowPaste).Value = Nz(RSout![20_ご契約プラン], "")
If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧_明細: 20_ご契約プランend"
             
            '21_ご契約天力
            lngRowPaste = lngRowPasteST + 7
            .Range("AQ" & lngRowPaste).Value = Nz(RSout![21_ご契約天力], "")
If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧_明細: 21_ご契約天力end"
             
            '22_ご契約満了予定日
            'lngRowPaste = lngRowPasteST + 7
             
            'If Len(RSout![22_ご契約満了予定日]) = 8 Then
            ' str日付 = Left(RSout![22_ご契約満了予定日], 4) & _
              ' "/" & Mid(RSout![22_ご契約満了予定日], 5, 2) & _
              ' "/" & Mid(RSout![22_ご契約満了予定日], 7, 2)
             
                'If IsDate(str日付) = True Then
                ' ' 変換できるときのみ日付にする
                  ' datご契約満了予定日 = CDate(str日付)
                  ' .Range("AJ" & lngRowPaste).Value = datご契約満了予定日
                'Else
'If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧_明細: 日付変換エラー@22_ご契約満了予定日"
' '日付変換エラー
  ' strMSG_TW02 = "(ご契約内容一覧 明細 日付変換エラー)"
  ' Call TW02_データチェック更新(RSout![6_ビジネスパートナー番号], 7)
                     
    ' GoTo ErrHandler
    ' End If
    ' Else
'If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧_明細: 日付変換エラーA 22_ご契約満了予定日"
 
                '日付変換エラー
' strMSG_TW02 = "(ご契約内容一覧 明細 日付変換エラー)"
  ' Call TW02_データチェック更新(RSout![6_ビジネスパートナー番号], 7)
                 
  ' GoTo ErrHandler
    ' End If
'If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧_明細: 22_ご契約満了予定日end"
 
            '23_年間天気料金
          ' lngRowPaste = lngRowPasteST + 7
            '.Range("AT" & lngRowPaste).Value = Val(RSout![23_年間天気料金])
        ' If IsNumeric(RSout![23_年間天気料金]) Then
          ' .Range("AT" & lngRowPaste).Value = Val(RSout![23_年間天気料金])
          ' Else
        ' .Range("AT" & lngRowPaste).Value = "-"
          ' End If
             
'If strDEBUG = "debug" Then Debug.Print "ご契約内容一覧_明細: 23_年間天気料金end"
     
  ' End With
 
NORMAL_END:
           
    Exit Function
     
'エラー処理
ErrHandler:
   
    If Err Then
        '作成エラー
        strMSG_TW02 = "(ご契約内容一覧 明細)"
        Call TW02_データチェック更新(RSout![6_ビジネスパートナー番号], 7)
 
        MsgBox ("ご契約内容一覧_明細" & vbCrLf & Err.Number & vbCrLf & Err.Description & vbCrLf & Err.Source)
        ご契約内容一覧_明細 = False
    End If
     
    GoTo NORMAL_END
     
End Function
 
 
Option Compare Database
Option Explicit
 
Public Function テンプレートファイル名確認()
 
    Dim StrWORDmaster1 As String
    Dim StrWORDmaster2 As String
    Dim StrEXLmaster1 As String
    Dim StrEXLmaster2 As String
   
    テンプレートファイル名確認 = False
     
    'マスタの確認
    '--- Word 挨拶状(天気のみ)
    StrWORDmaster1 = DLookup("[テンプレートファイル名]", "TM_テンプレートファイル名", "テンプレート区分 = 'conWORDmaster1'")
    If Not chkFile(Forms!F01_Main!txtパス_出力 & conTemp & "\" & StrWORDmaster1) Then
        MsgBox "「" & Forms!F01_Main!txtパス_出力 & conTemp & "\" & StrWORDmaster1 & "」が存在しません。"
        Exit Function
    End If
 
    '--- Word 挨拶状(天気・ガス用)
    StrWORDmaster2 = DLookup("[テンプレートファイル名]", "TM_テンプレートファイル名", "テンプレート区分 = 'conWORDmaster2'")
    If Not chkFile(Forms!F01_Main!txtパス_出力 & conTemp & "\" & StrWORDmaster2) Then
        MsgBox "「" & Forms!F01_Main!txtパス_出力 & conTemp & "\" & StrWORDmaster2 & "」が存在しません。"
        Exit Function
    End If
     
    '--- Excel ご契約内容一覧 ご契約内容一覧 2017年10月分選択のとき
    If Forms!F01_Main.Chk_SelectData1 = True Then
        StrEXLmaster1 = DLookup("[テンプレートファイル名]", "TM_テンプレートファイル名", "テンプレート区分 = 'conEXLmaster1'")
        If Not chkFile(Forms!F01_Main!txtパス_出力 & conTemp & "\" & StrEXLmaster1) Then
            MsgBox "「" & Forms!F01_Main!txtパス_出力 & conTemp & "\" & StrEXLmaster1 & "」が存在しません。"
            Exit Function
        End If
    End If
     
    '--- Excel ご契約内容一覧(1月分) ご契約内容一覧 1月分選択のとき
    If Forms!F01_Main.Chk_SelectData2 = True Then
        StrEXLmaster2 = DLookup("[テンプレートファイル名]", "TM_テンプレートファイル名", "テンプレート区分 = 'conEXLmaster2'")
        If Not chkFile(Forms!F01_Main!txtパス_出力 & conTemp & "\" & StrEXLmaster2) Then
            MsgBox "「" & Forms!F01_Main!txtパス_出力 & conTemp & "\" & StrEXLmaster2 & "」が存在しません。"
            Exit Function
        End If
    End If
 
    テンプレートファイル名確認 = True
 
End Function
 
 
Option Compare Database
Option Explicit
 
Sub 再印刷_Main()
' ファイルオープンのエラーなどで止まった時に見えないため、WordやExcelを起動するのが見えるように
' 最小化してからVisibleをTrue(見える化)にする
' ただし、WordはVisibleをTrueにしないと最小化ができないため、表示が見えてしまう
' 不都合な場合はVisible = Trueしてる行を削除してください。(WindowStateを最小化してる部分も不要)
 
    Const wdWindowStateMinimize = 2
    Const xlMinimized = -4140
 
    Dim CN2 As New ADODB.Connection
    Dim RS As New ADODB.Recordset
         
    Dim wdApp As word.Application
    Dim wdDoc As word.Document
     
    Dim tBook As Object
     
    Dim strFileName As String
 
    'CN 初期化
    Set CN2 = CurrentProject.Connection
     
    '静的カーソル(他のユーザーが更新したレコードは表示されません) レコードごとに共有ロック
    RS.Open "Q301_再出力対象データ_BP番号順", CN2, adOpenStatic, adLockOptimistic
 
    Do Until RS.EOF
If strDEBUG = "debug" Then Debug.Print "再印刷 : BP番号=" & RS![ビジネスパートナー番号]
If strDEBUG = "debug" Then Debug.Print "     : データチェック =" & RS![データチェック] & " / 挨拶状=" & RS![挨拶状フルパス] & " / 契約内容一覧=" & RS![ご契約内容一覧フルパス]; ""
         
        '再作成ファイル 正常終了のみ印刷
        If IsNull(RS![印刷日時]) Or RS![印刷日時] = "" Then
            If IsNull(RS![データチェック]) Or RS![データチェック] = "" Then
            '再作成ファイル(挨拶状、ご契約内容一覧)がセットで存在すること
                If Nz(RS![挨拶状フルパス], "") <> "" And Nz(RS![ご契約内容一覧フルパス], "") <> "" Then
                    If chkFile(RS![挨拶状フルパス]) And chkFile(RS![ご契約内容一覧フルパス]) Then
                     
                        '■挨拶状(word) 印刷■
                        'Wordファイルを開く
                        Set wdApp = CreateObject("Word.Application")
                        'wdApp.WindowState = wdWindowStateMinimize '最小化(Word表示前にいれても効かない)
                        wdApp.Visible = True 'Wordを表示
                        wdApp.WindowState = wdWindowStateMinimize '最小化
                         
                        strFileName = RS![挨拶状フルパス]
                        Set wdDoc = wdApp.Documents.Open(strFileName)
         
                        '印刷 テスト中は印刷プレビューにするため
                        If strPRpreview = "preview" Then
                            'wdDoc.PrintPreview
                        Else
                            wdDoc.PrintOut
                        End If
                         
                        'ターゲットを閉じる(保存しない)
                        wdDoc.Close SaveChanges:=False
                         
                        'ワードの終了
                        wdApp.Quit
                        Set wdApp = Nothing
                     
                        '■ご契約内容一覧(Excel) 印刷■
                        'Excelファイルを開く
                        Set xls = CreateObject("Excel.Application")
                        xls.WindowState = xlMinimized 'Excel最小化
                        xls.Visible = True 'Excel見える化
                        xls.Workbooks.Open FileName:=RS![ご契約内容一覧フルパス]
                         
                        'ファイル情報取得
                        Set tBook = xls.ActiveWorkbook
                         
                        'シートを確認
                        If Not シート有無確認(tBook, conSHTName) Then
                            '印刷エラー
                            strMSG_TW02 = "(ご契約内容一覧)"
                            Call TW02_データチェック更新(RS![6_ビジネスパートナー番号], 8)
                            Exit Do
                        End If
         
                        '印刷 テスト中は印刷プレビューにするため
                        If strPRpreview = "preview" Then
                            tBook.Worksheets(conSHTName).PrintPreview
                        Else
                            tBook.Worksheets(conSHTName).PrintOut
                        End If
                         
                        'ターゲットを閉じる(保存しない)
                        tBook.Close SaveChanges:=False
         
                        'エクセルの終了
                        xls.Quit
                        Set xls = Nothing
                         
                        datTimeStamp = Now()
                        Call 再印刷履歴追加
                         
                        RS![印刷日時] = datTimeStamp
                 
                        RS.Update
     
                    End If 'ファイル存在
                     
                End If '挨拶状フルパスとご契約内容一覧フルパスあり
     
            End If 'データステータス空白(エラーなし)
         
        End If '印刷日時 空白
         
        RS.MoveNext
 
    Loop
 
    '解放
    RS.Close: Set RS = Nothing
    CN2.Close: Set CN2 = Nothing
 
End Sub
 
 
Option Compare Database
Option Explicit
 
Sub 再印刷履歴追加()
    Dim CNedit As New ADODB.Connection
    Dim RSFrom As New ADODB.Recordset
    Dim RSTo As New ADODB.Recordset
     
        'CN 初期化
    Set CNedit = CurrentProject.Connection
 
    'レコードセット
    RSFrom.Open "Q301_再出力対象データ_BP番号順", CNedit, adOpenDynamic, adLockOptimistic
    RSTo.Open "Lnk02_再印刷履歴", CNedit, adOpenDynamic, adLockOptimistic
 
    RSTo.AddNew
    RSTo!ビジネスパートナー番号 = RSFrom![ビジネスパートナー番号]
    RSTo!出力ファイル名_挨拶状 = RSFrom![挨拶状フルパス]
    RSTo!出力ファイル名_ご契約内容一覧 = RSFrom![ご契約内容一覧フルパス]
    RSTo!作業者 = Forms!F01_Main!txtMyID
    RSTo!再印刷処理日 = datTimeStamp
    RSTo.Update
     
    RSFrom.Close: Set RSFrom = Nothing
    RSTo.Close: Set RSTo = Nothing
    CNedit.Close: Set CNedit = Nothing
 
End Sub
 
Function 再印刷履歴確認(prビジネスパートナー番号 As String)
 
    Dim CNref As New ADODB.Connection
    Dim RS As New ADODB.Recordset
    Dim strSQL As String
     
    On Error GoTo ErrHandler
     
    再印刷履歴確認 = True
 
    'ロックファイルを作成
    If Not tryLock(Forms!F01_Main.txtパス, conLckFile, Forms!F01_Main.txtMyID) Then
        再印刷履歴確認 = False
        Exit Function
    End If
 
    'CN 初期化
    Set CNref = CurrentProject.Connection
 
    'レコードセット(既に再印刷済みか確認:最新の発行情報のみ)
    strSQL = "SELECT Lnk02_再印刷履歴.* FROM Lnk02_再印刷履歴 " & _
            "WHERE Lnk02_再印刷履歴.整理コード='" & prビジネスパートナー番号 & "' " & _
            "ORDER BY Lnk02_再印刷履歴.SEQ DESC;"
 
    RS.Open strSQL, CNref, adOpenDynamic, adLockOptimistic
 
    '再印刷履歴がなければ終了
    If RS.EOF Then GoTo NORMAL_END
 
    '再印刷履歴があれば結果をエラーメッセージの形式で返す
    RS.MoveLast: RS.MoveFirst
 
    strMSG = "【" & RS![再印刷処理日] & ":" & RS![作業者] & ":" & RS![ビジネスパートナー番号] & "】" & vbCrLf
 
'エラー処理
ErrHandler:
    If Err Then
        MsgBox (Err.Number & vbCrLf & Err.Description & vbCrLf & Err.Source)
        再印刷履歴確認 = False
    End If
 
NORMAL_END:
 
    RS.Close: Set RS = Nothing
    CNref.Close: Set CNref = Nothing
 
    ' ロック解除
    If Not tryUnlock(Forms!F01_Main.txtパス, conLckFile, Forms!F01_Main.txtMyID) Then
        Exit Function
    End If
 
End Function
 
Option Compare Database
Option Explicit
 
Sub 印刷履歴一覧出力ファイルパス_Main()
 
    If Not IsNull(Forms!F01_Main!txtインポートファイル) Then
        Call データ出力_フルパス(Forms!F01_Main!txtインポートファイル)
    Else
        MsgBox "インポートファイルが不明のため、印刷履歴(印刷用ファイルパス)を出力できませんでした"
    End If
 
End Sub
 
Function データ出力_フルパス(prFName As String)
    Dim CN2 As New ADODB.Connection
    Dim RS As New ADODB.Recordset
 
    Dim tBook As Object
    Dim tSHT As Object
 
    Dim lngLastRow As Long
     
    Dim lngRow As Long
    Dim i As Long
 
    データ出力_フルパス = True
     
    'ファイル確認
    If Dir(prFName, vbNormal) = "" Then
        データ出力_フルパス = False
        MsgBox "インポートファイル【" & prFName & "】が存在しません。" & vbCrLf & _
                        "印刷用ファイルパスの結果が反映できませんでした。"
        Exit Function
    End If
     
    'ファイルを開く
    Set xls = CreateObject("Excel.Application")
    xls.Workbooks.Open FileName:=prFName
     
    'ファイル情報取得
    Set tBook = xls.ActiveWorkbook
     
    'シートを確認
    If Not シート有無確認(tBook, conSHTName_再出力BP一覧) Then
        MsgBox "指定されたファイルに【" & conSHTName_再出力BP一覧 & "】が存在しません。" & vbCrLf & _
                        "印刷用ファイルパスの結果が反映できませんでした。"
        GoTo ERR_END
    End If
     
    '取込開始
    Set tSHT = tBook.Sheets(conSHTName_再出力BP一覧)
     
    '***** 一覧出力 開始 *****
    'CN 初期化
    Set CN2 = CurrentProject.Connection
     
    'テーブルを開く
    '静的カーソル(他のユーザーが更新したレコードは表示されません) 読み取り専用
    RS.Open "Q401_再出力ファイル作成対象データ_Excelリスト反映", CN2, adOpenStatic, adLockReadOnly
     
    'シート最終行取得
    With tSHT
        lngLastRow = .Range("A1").CurrentRegion.Rows.Count
    End With
     
    '該当データ(再出力対象)出力
    If RS.RecordCount = 0 Then
''''' MsgBox "印刷用ファイル作成対象がないため、印刷用ファイルパスの結果が反映できませんでした。"
        GoTo ERR_END
    End If
     
    RS.MoveFirst '最初のレコードに移動
     
    '該当データのExcel位置取得
    lngRow = 0
    For i = 2 To lngLastRow
     
        'リストNOとビジネスパートナー番号が一致したらExcel書き込み
If strDEBUG = "debug" Then Debug.Print "i="; i & " tsht.cell(" & i & ",1)=" & tSHT.Cells(i, 1) & " リストNo=" & RS![リストNo]
If strDEBUG = "debug" Then Debug.Print " tsht.cells(" & i & ",4)=" & tSHT.Cells(i, 4) & " BP番号=" & RS![ビジネスパートナー番号]
        If tSHT.Cells(i, 1) = RS![リストNo] And tSHT.Cells(i, 4) = RS![ビジネスパートナー番号] Then
            lngRow = i
If strDEBUG = "debug" Then Debug.Print "Excel出力セル確定" & lngRow
            Exit For
        End If
         
    Next i
     
    If lngRow > 0 Then
     
        Do Until RS.EOF
If strDEBUG = "debug" Then Debug.Print "lngRow="; lngRow & " tsht.cell(" & lngRow & ",1)=" & tSHT.Cells(lngRow, 1) & " リストNo=" & RS![リストNo]
If strDEBUG = "debug" Then Debug.Print " tsht.cells(" & lngRow & ",4)=" & tSHT.Cells(lngRow, 4) & " BP番号=" & RS![ビジネスパートナー番号]
            'リストNOとビジネスパートナー番号が一致したらExcel書き込み
            If tSHT.Cells(lngRow, 1) = RS![リストNo] And tSHT.Cells(lngRow, 4) = RS![ビジネスパートナー番号] Then
If strDEBUG = "debug" Then Debug.Print "Excel出力"
                If RS![データチェック] <> "" Then
                    tSHT.Cells(lngRow, 5) = Format(Now(), "yy/mm/dd") & " " & Nz(RS![データチェック], "")
                Else
                    tSHT.Cells(lngRow, 5) = ""
                End If
'2018/2/5 ファイル作成者は記録しない
''''' tSHT.Cells(lngRow, 6) = Nz(Forms!F01_Main!txtMyID, "")
                tSHT.Cells(lngRow, 7) = Nz(RS![挨拶状フルパス], "")
                tSHT.Cells(lngRow, 8) = Nz(RS![ご契約内容一覧フルパス], "")
            End If
         
            lngRow = lngRow + 1
 
            RS.MoveNext
         
        Loop
 
    Else
     
        MsgBox "印刷用ファイルパスの結果が反映できませんでした。"
        GoTo ERR_END
     
    End If
     
    '上書き保存
    tBook.Save
 
'##################################################
NORMAL_END:
    '後処理
     
    'ターゲットを閉じる
    tBook.Close
 
    'エクセルの終了
    xls.Quit
    Set xls = Nothing
     
    '解放
    If Not RS Is Nothing Then
        RS.Close: Set RS = Nothing
    End If
     
    If Not CN2 Is Nothing Then
        CN2.Close: Set CN2 = Nothing
    End If
     
    Exit Function
     
ERR_END:
 
    データ出力_フルパス = False
    GoTo NORMAL_END
     
End Function
 
 
Sub 印刷履歴一覧出力_Main()
 
    If Not IsNull(Forms!F01_Main!txtインポートファイル) Then
        Call データ出力(Forms!F01_Main!txtインポートファイル)
    Else
        MsgBox "インポートファイルが不明のため、印刷履歴を出力できませんでした"
    End If
 
End Sub
 
Function データ出力(prFName As String)
    Dim CN2 As New ADODB.Connection
    Dim RS As New ADODB.Recordset
 
    Dim tBook As Object
    Dim tSHT As Object
 
    Dim lngLastRow As Long
     
    Dim lngRow As Long
    Dim i As Long
 
    データ出力 = True
     
    'ファイル確認
    If Dir(prFName, vbNormal) = "" Then
        データ出力 = False
        MsgBox "インポートファイル【" & prFName & "】が存在しません。" & vbCrLf & _
                        "印刷の結果が反映できませんでした。"
        Exit Function
    End If
     
    'ファイルを開く
    Set xls = CreateObject("Excel.Application")
    xls.Workbooks.Open FileName:=prFName
     
    'ファイル情報取得
    Set tBook = xls.ActiveWorkbook
     
    'シートを確認
    If Not シート有無確認(tBook, conSHTName_再出力BP一覧) Then
        MsgBox "指定されたファイルに【" & conSHTName_再出力BP一覧 & "】が存在しません。" & vbCrLf & _
                        "印刷の結果が反映できませんでした。"
        GoTo ERR_END
    End If
     
    '取込開始
    Set tSHT = tBook.Sheets(conSHTName_再出力BP一覧)
     
    '***** 一覧出力 開始 *****
    'CN 初期化
    Set CN2 = CurrentProject.Connection
     
    'テーブルを開く
    '静的カーソル(他のユーザーが更新したレコードは表示されません) 読み取り専用
    RS.Open "Q401_再出力データ_Excelリスト反映", CN2, adOpenStatic, adLockReadOnly
     
    'シート最終行取得
    With tSHT
        lngLastRow = .Range("A1").CurrentRegion.Rows.Count
    End With
     
    '該当データ(再出力対象)出力
    If RS.RecordCount = 0 Then
''''' MsgBox "再印刷対象がないため、印刷の結果が反映できませんでした。"
        GoTo ERR_END
    End If
     
    RS.MoveFirst '最初のレコードに移動
     
    '該当データのExcel位置取得
    lngRow = 0
    For i = 2 To lngLastRow
     
        'リストNOとビジネスパートナー番号が一致したらExcel書き込み
If strDEBUG = "debug" Then Debug.Print "i="; i & " tsht.cell(" & i & ",1)=" & tSHT.Cells(i, 1) & " リストNo=" & RS![リストNo]
If strDEBUG = "debug" Then Debug.Print " tsht.cells(" & i & ",4)=" & tSHT.Cells(i, 4) & " BP番号=" & RS![ビジネスパートナー番号]
        If tSHT.Cells(i, 1) = RS![リストNo] And tSHT.Cells(i, 4) = RS![ビジネスパートナー番号] Then
            lngRow = i
If strDEBUG = "debug" Then Debug.Print "Excel出力セル確定" & lngRow
            Exit For
        End If
         
    Next i
     
    If lngRow > 0 Then
     
        Do Until RS.EOF
If strDEBUG = "debug" Then Debug.Print "lngRow="; lngRow & " tsht.cell(" & lngRow & ",1)=" & tSHT.Cells(lngRow, 1) & " リストNo=" & RS![リストNo]
If strDEBUG = "debug" Then Debug.Print " tsht.cells(" & lngRow & ",4)=" & tSHT.Cells(lngRow, 4) & " BP番号=" & RS![ビジネスパートナー番号]
            'リストNOとビジネスパートナー番号が一致したらExcel書き込み
            If tSHT.Cells(lngRow, 1) = RS![リストNo] And tSHT.Cells(lngRow, 4) = RS![ビジネスパートナー番号] Then
If strDEBUG = "debug" Then Debug.Print "Excel出力"
                If RS![データチェック] <> "" Then
                    tSHT.Cells(lngRow, 5) = Format(Now(), "yy/mm/dd") & " " & Nz(RS![データチェック], "")
                Else
                    tSHT.Cells(lngRow, 5) = Nz(RS![印刷日時], "")
                End If
                tSHT.Cells(lngRow, 6) = Nz(Forms!F01_Main!txtMyID, "")
            End If
         
            lngRow = lngRow + 1
 
            RS.MoveNext
         
        Loop
 
    Else
     
        MsgBox "印刷の結果が反映できませんでした。"
        GoTo ERR_END
     
    End If
     
    '上書き保存
    tBook.Save
 
'##################################################
NORMAL_END:
    '後処理
     
    'ターゲットを閉じる
    tBook.Close
 
    'エクセルの終了
    xls.Quit
    Set xls = Nothing
     
    '解放
    If Not RS Is Nothing Then
        RS.Close: Set RS = Nothing
    End If
     
    If Not CN2 Is Nothing Then
        CN2.Close: Set CN2 = Nothing
    End If
     
    Exit Function
     
ERR_END:
 
    データ出力 = False
    GoTo NORMAL_END
     
End Function
Option Compare Database
Option Explicit
 
Sub TW02_データチェック更新(prビジネスパートナー番号 As String, pr文言CD As Integer)
 
    Dim CN2 As New ADODB.Connection
     
    Dim strSQL As String
    Dim str文言 As String
     
    'CN 初期化
    Set CN2 = CurrentProject.Connection
 
    str文言 = ""
     
    Select Case pr文言CD
        Case 1
            str文言 = ""
             
        Case 7
            str文言 = "作成エラー" & strMSG_TW02
             
        Case 8
            str文言 = "印刷エラー" & strMSG_TW02
             
        Case 9
            str文言 = "該当なし"
    End Select
     
    strSQL = "UPDATE TW02_再出力データ" & _
            " SET" & _
            " TW02_再出力データ.データチェック = '" & str文言 & "'" & _
            " WHERE TW02_再出力データ.[ビジネスパートナー番号] = '" & prビジネスパートナー番号 & "';"
If strDEBUG = "debug" Then Debug.Print "TW02_データチェック更新 SQL=" & strSQL
 
    CN2.Execute strSQL
     
    CN2.Close: Set CN2 = Nothing
 
End Sub
 
Sub TW02_フルパス更新(prビジネスパートナー番号 As String, prフルパス As String, pr区分 As Integer)
 
    Dim CN2 As New ADODB.Connection
 
    Dim strSQL As String
     
    'CN 初期化
    Set CN2 = CurrentProject.Connection
     
    strSQL = "UPDATE TW02_再出力データ"
 
    Select Case pr区分
        Case 1
            strSQL = strSQL & " SET TW02_再出力データ.挨拶状フルパス = '" & prフルパス & "'"
        Case 2
            strSQL = strSQL & " SET TW02_再出力データ.ご契約内容一覧フルパス = '" & prフルパス & "'"
    End Select
     
    strSQL = strSQL & " WHERE TW02_再出力データ.[ビジネスパートナー番号] = '" & prビジネスパートナー番号 & "';"
     
If strDEBUG = "debug" Then Debug.Print "TW02_フルパス更新 SQL=" & strSQL
 
    CN2.Execute strSQL
     
    CN2.Close: Set CN2 = Nothing
 
End Sub
Option Compare Database
Option Explicit
 
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliSeconds As Long)
 
'==============================================================================
' ロック関係のユーティリティモジュール
'
' @author ishiyuus
'==============================================================================
'==============================================================================
' 定数定義
'==============================================================================
 
Public Function tryLock(ByVal filePath As String, ByVal FileName As String, ByVal userId As String) As Boolean
 
    Dim fullPath As String
    Dim currUserId As String
 
    ' 絶対パス構築
    fullPath = filePath & "\" & FileName
 
    ' ロックファイルの存在判定
    If chkFile(fullPath) Then
        ' ロック中のユーザーを取得
        currUserId = LeadFirstLine(fullPath)
 
        ' ロックユーザーを確認
        If currUserId = userId Then
            tryLock = True
        Else
            tryLock = False
            MsgBox currUserId & "がデータ使用中です。" & vbCrLf & _
                  "数分待ってから実行ください。" & vbCrLf & _
                  "長時間解消されない場合は、データ管理者へご連絡ください。", vbExclamation
        End If
    Else
        ' ロックファイル生成
        Call WriteFirstLine(fullPath, userId)
        tryLock = True
    End If
 
End Function
 
Public Function tryUnlock(ByVal filePath As String, ByVal FileName As String, ByVal userId As String) As Boolean
' Call LogUtil.logTrace("LockUtil.tryUnlock(filePath={}, fileName={}, userId={})", filePath, fileName, userId)
 
    ' ローカル変数宣言
    Dim fullPath As String
 
    ' 絶対パス構築
    fullPath = filePath & "\" & FileName
 
' Call LogUtil.logDebug("Trying get unlock on File [{}]", fullPath)
 
    ' ロックファイルの存在判定
    If chkFile(fullPath) Then
        ' ロックユーザーを確認
        If LeadFirstLine(fullPath) = userId Then
            ' ロックファイルを削除
            Call Kill(fullPath)
        End If
    End If
 
    tryUnlock = True
End Function
 
'ファイル有無確認(待ち処理あり)
'prFullPathがあればTRUE、なければFALSEを返す。ただし、ファイルが存在する場合、prWaitSecで指定した秒数分確認を継続する。
Function LckFileWait(prFullPath As String, Optional prWaitSec As Integer = 10) As Boolean
 
    Dim x As Integer
 
    LckFileWait = True
 
    'prWaitSecに指定した秒数だけ確認
    For x = 1 To prWaitSec
        If chkFile(prFullPath) = False Then
            'ファイルなし
            LckFileWait = False
            Exit For
        End If
        '1秒静止
        Sleep 1000
    Next x
 
End Function
 
'ファイル一行だけ読み込み
'対象ファイルの一行目の内容を返す
Function LeadFirstLine(prFullPath As String) As Variant
 
    Dim x As Integer
    x = FreeFile
    Open prFullPath For Input As #x
    Line Input #x, LeadFirstLine
    Close #x
 
End Function
 
'ファイル一行だけ書き込み
Function WriteFirstLine(prFullPath As String, prLine As String) As Boolean
 
    Dim x As Integer
    x = FreeFile
    Open prFullPath For Output As #x
    Print #x, prLine
    Close #x
 
End Function
 
Option Compare Database
Option Explicit
 
Public Function GetFolderName() As String
   
  Dim intRet As Integer
 
  With Application.FileDialog(msoFileDialogFolderPicker)
    'ダイアログのタイトルを設定
    .Title = "フォルダ選択"
    .InitialFileName = CurrentProject.Path
     
    'ダイアログを表示
    intRet = .Show
    If intRet <> 0 Then
      'フォルダが選択されたときフルパス返す
      GetFolderName = Trim(.SelectedItems.Item(1))
    Else
      'フォルダが未選択時空白を返す
      GetFolderName = ""
    End If
  End With
 
End Function
 
Function ファイル指定() As String
     
    Dim objDiaLog As Object
     
    'フォルダ指定を受ける
    Set objDiaLog = Application.FileDialog(msoFileDialogFilePicker)
    With objDiaLog
        .Filters.Add "Excelファイル", "*.xls?"
        .InitialFileName = CurrentProject.Path
        .AllowMultiSelect = False
        .Show
         
        If .SelectedItems.Count <> 0 Then
            ファイル指定 = .SelectedItems(1)
        Else
            ファイル指定 = ""
        End If
         
    End With
 
End Function
 
Function シート有無確認(prBook As Object, prShtName As String) As Boolean
 
    Dim ws As Object
     
    シート有無確認 = False
 
    'シート名を確認
    For Each ws In prBook.Worksheets
        If ws.Name = prShtName Then
            シート有無確認 = True
            Exit For
        End If
    Next ws
 
End Function
 
'ファイルを指定
Public Function GetFileName() As String
   
  Dim intRet As Integer
 
  With Application.FileDialog(msoFileDialogOpen)
    'ダイアログのタイトルを設定
    .Title = "ファイル選択"
    .InitialFileName = CurrentProject.Path
    .AllowMultiSelect = False
     
    'ダイアログを表示
    intRet = .Show
    If intRet <> 0 Then
      'フォルダが選択されたときフルパス返す
      GetFileName = Trim(.SelectedItems.Item(1))
    Else
      'フォルダが未選択時空白を返す
      GetFileName = ""
    End If
  End With
 
End Function
 
'ファイルの有無確認
'prFullPathがあればTRUE 無ければFALSEを返す
Public Function chkFile(prFullPath As String) As Boolean
 
    ' 戻り値の初期値を設定
    chkFile = False
 
    ' ファイル存在判定
    If Dir(prFullPath, vbNormal) <> "" Then
        chkFile = True
    Else
        ' ディレクトリの存在判定
        If Dir(prFullPath, vbDirectory) <> "" Then
            chkFile = True
        End If
    End If
 
End Function
 
Sub フォルダ作成(prFolderName As String)
     
    'フォルダの有無確認
    If chkFile(prFolderName) = False Then
        MkDir prFolderName
    End If
     
End Sub
 
Public Function HanKanaConv(s As Variant) As String
    Dim i As Integer, P As Integer, C As String
    Const HanKanaS = "ァィゥェォャュョッ"
    Const HanKanaL = "アイウエオヤユヨツ"
 
    HanKanaConv = s
    For i = 1 To Len(s)
        C = Mid(s, i, 1)
        P = InStr(1, HanKanaS, C, vbBinaryCompare)
        If P > 0 Then Mid(HanKanaConv, i) = Mid(HanKanaL, P, 1)
    Next i
     
End Function
 
Function getRcCnt(prTBLName As String, prFLDName As String, prWORD As Variant, Optional prFLG As Long = 0) As Long
    Dim strSQL As String
     
    Select Case prFLG
        Case 0
            strSQL = "select * from " & prTBLName & " where [" & prFLDName & "]=" & prWORD & ";"
        Case 1
            strSQL = "select * from " & prTBLName & " where [" & prFLDName & "]=" & prWORD & " and [削除FLG] is null;"
    End Select
     
    CurrentDb.QueryDefs("QW01_データチェック").SQL = strSQL
    getRcCnt = DCount("*", "QW01_データチェック")
End Function
 
'----------------------------------------------------------
' 引数1:DBフルパス
' 引数2:テーブル名
' 引数で受け取ったDBの中に該当テーブルがあるか確認
' なければ終了
' あれば一旦自分のリンクテーブルを削除し、再度リンク作成
'----------------------------------------------------------
Public Function chkTBL(prDBname As String, prTBLName As String, prLINKName As String) As Boolean
 
    Dim tdf As TableDef
    Dim tmpField As Field
    Dim i As Integer
    Dim iFieldNum As Integer
     
    Dim tmp As Variant
     
    Dim intSECURITY As Integer
     
    '初期化
    chkTBL = False
    tmp = Split(prDBname, "\")
     
    '該当ファイルの有無確認
    If Not chkFile(prDBname) Then
' strMSG = "指定フォルダに「" & tmp(UBound(tmp)) & "」を保存してください。"
        strMSG = "本フォルダに「" & Replace(prDBname, CurrentProject.Path, "") & "」を保存してください。"
        Exit Function
    End If
 
    'テーブル情報を最新に更新
    CurrentDb.TableDefs.Refresh
     
    '当DB(コントロールDB)内のテーブルリンクを削除
    On Error Resume Next 'テーブルがすでに削除されている場合に備えて、エラー処理は必要
    CurrentDb.TableDefs.Delete (prLINKName)
    On Error GoTo 0
     
    'テーブル情報を最新に更新
    OpenDatabase(prDBname, False, False, ";pwd=keiyakuG").TableDefs.Refresh
     
    '該当テーブルの存在確認
    For Each tdf In OpenDatabase(prDBname, False, False, ";pwd=keiyakuG").TableDefs
        If tdf.Name = prTBLName Then
            chkTBL = True
            Exit For
        End If
    Next
     
    '該当テーブルがなければ処理終了
    If Not chkTBL Then
        strMSG = "「" & tmp(UBound(tmp)) & "」内に参照データがありません。契約企画Gへご連絡ください。"
        Exit Function
    End If
     
    '現在のセキュリティレベルを退避
    intSECURITY = Application.AutomationSecurity
    'セキュリティレベルを下げる
' Application.AutomationSecurity = msoAutomationSecurityLow
    Application.AutomationSecurity = 1
 
    '-----------------------------------
    '当DB(コントロールDB)にリンクテーブルを作成する
    DoCmd.TransferDatabase acLink, _
    "Microsoft Access", _
    prDBname, _
    acTable, _
    prTBLName, _
    prLINKName
     
    'テーブルを隠す
    '★フォーム:FLGLinkCHK=TESTのとき隠さない(開発中)
    If Forms!F01_Main.FLGLinkCHK <> "TEST" Then
        CurrentDb.TableDefs(prLINKName).Attributes = 1
    End If
     
    '現在のセキュリティレベルを戻す
    Application.AutomationSecurity = intSECURITY
     
    'アクセスバグ回避 ステータスバーを非表示に
    '★フォーム:FLGLinkCHK=TESTのとき隠さない(開発中)
    If Forms!F01_Main.FLGLinkCHK <> "TEST" Then
        DoCmd.SelectObject acForm, "", True
        DoCmd.RunCommand acCmdWindowHide
    End If
     
    'ステータスバーをクリア
    SysCmd acSysCmdSetStatus, " "
     
End Function
 
Public Function fnSum(ParamArray prVal() As Variant) As Long
    Dim i As Long
     
    On Error Resume Next
    fnSum = 0
     
    For i = 0 To UBound(prVal)
        If Not IsNull(prVal(i)) Then
            If IsNumeric(prVal(i)) Then
                fnSum = fnSum + CLng(prVal(i))
            End If
        End If
    Next i
     
     
End Function
 
Option Compare Database
Option Explicit
 
Function Init(prCtrlFolder As String, prVersion As String)
 
    Init = True
    On Error GoTo ErrHandler
     
    'バージョン確認
    If chkFile(prCtrlFolder & conVerFile) Then
        If LeadFirstLine(prCtrlFolder & conVerFile) <> prVersion Then
            MsgBox "ERROR: バージョンが無効です 最新バージョンのツールを使用ください"
            Init = False
            Exit Function
        End If
    End If
     
    'メンテナンスファイル確認
    If chkFile(prCtrlFolder & conMntFile) Then
        MsgBox LeadFirstLine(prCtrlFolder & conMntFile)
        Init = False
        Exit Function
    End If
         
'エラー処理
ErrHandler:
    If Err Then
        MsgBox (Err.Number & vbCrLf & Err.Description & vbCrLf & Err.Source)
        Init = False
    End If
 
End Function
Option Compare Database
Option Explicit
 
'実行中のタスク一覧(非API)から指定したアプリケーション、ファイル名が起動中か調べる
' (タスクマネージャ の「プロセス一覧」を取得)
' アプリケーション名を指定 : 指定されたアプリケーションが起動しているか ["- Excel" or "Microsoft Excel" or "- Word"]
' ファイル名を指定 : 指定されたファイルが開かれているか
' 戻り値 : True = タスク(プロセス)実行中
' False = タスク(プロセス)なし
 
Function プロセス一覧チェック(prName As String) As Boolean
 
    Dim WD As Object
    Dim task As Variant
     
    プロセス一覧チェック = False
     
    'Wordを起動
    Set WD = CreateObject("Word.Application")
 
    'Word VBAのTasksコレクションを調べる
    For Each task In WD.Tasks
'Debug.Print task.Name
         
        'タスク(プロセス)実行中のタスク名から指定名が含まれているか確認
        If task.Visible And InStr(task.Name, prName) Then
         
'Debug.Print "★" & task.Name & "起動中"
            プロセス一覧チェック = True
            Exit For
        End If
 
    Next
 
    WD.Quit
    Set WD = Nothing
     
End Function
 
Option Compare Database
Option Explicit
 
'Public Const strDEBUG As String = "debug" 'Debug.print出力※テスト用
Public Const strDEBUG As String = "" 'Debug.print出力なし※リリース用
 
'Public Const strPRpreview As String = "preview" '印刷プレビュー表示※テスト用
Public Const strPRpreview As String = "" '印刷 ※リリース用
 
Public Const strDM発送データ2 As String = "" '2017年10月DM発送データのみ
'Public Const strDM発送データ2 As String = "201712" '2017年12月DM発送データあり
 
'----- M99_共通_メンテ
Public Const conVerFile As String = "ctl_valid_version.txt" 'バージョン管理
Public Const conLckFile As String = "ctl_datalock_2.txt" 'ロックファイル
Public Const conMntFile As String = "ctl_maintenance.txt" 'メンテナンスファイル
 
'----- M_F01_1エクセルインポート
Public Const conSHTName_再出力BP一覧 = "プラス割DM再印刷リスト"
 
'----- M_F01_21再印刷ファイル作成
Public Const conOutFolder = "プラス割DM再印刷データ"
 
'----- M_F01_22テンプレート名確認
Public Const conTemp = "01_テンプレート"
 
'----- M_F01_21再印刷ファイル作成 / M_F01_31印刷 / M_F01_41印刷履歴Excel出力
Public Const conSHTName = "印刷画面"
 
'----- M_F01_1エクセルインポート
Public xls As excel.Application
 
'Public strSQL As String
Public strMSG As String
 
Public strOutFileName挨拶 As String
Public strOutFileName契約内容一覧 As String
 
'----- M_F01_21再印刷ファイル作成 /
Public strMSG_TW02 As String
 
'----- M_F01_21再印刷ファイル作成 / M_F01_31印刷
Public datTimeStamp As Date
  
 
出力ファイル作成のワードはOKになりますがExcelのほうが再印刷用ファイル作成中のままスリープ
してしまいます。
 
非常に困っております。どなたか修正方法を宜しくお願い申し上げます

回答
投稿日時: 18/05/02 12:29:13
投稿者: よろずや

全文記載されても、タダで読める量ではありません。
あくまでも、デバッグするのは貴方の仕事です。
こちらからは、アドバイスできるだけです。
 
まず、どこを書き換えたのかを明確にする必要があります。
改修前と改修後のプログラムをそれぞれメモ帳に貼り付けてテキストファイルにし、
FCコマンドで比較リストを作ると、改修した場所が明確になります。
 
次に、ステップ実行して、不審な動きをするあたりで各変数の値をたしかめます。
ステップ実行中にマウスポインタを変数の上に持っていくと、変数の値を確認できます。
 
ざっと見た範囲で気になるところは、データベースの処理にADOを使っていますが、
その中に異質なものが混ざっています。
DoCmd.RunSQL "DELETE * FROM TW01_取込データ;"
これは非同期で実行され、削除が終わらないうちに次のステップに進んでしまいます。
CN.Execute prStrSQL
こちらの構文が正解です。
 
いずれにしても手元に現物、環境が無ければ手の出しようがありません。
頑張ってください。
 
ギブアップするなら、「ココナラ」で有償で相談するという手もあります。

回答
投稿日時: 18/05/02 14:35:57
投稿者: sk

引用:
印刷ツールのExcelの書式が変更になり差し替えましたが正常作動しません。

変更前/変更後の書式や出力仕様に関する情報が
明示されていないのでは、どこをどう修正するべきかも
判断のしようがありません。
 
また、モジュール12個分のコードをまるごと転載されており、
それらに含まれているいくつかのプロシージャが何らかの
Excel ブックの参照や生成処理に関わっているようですが、
「変更になった書式」とは具体的にどれを指しているかについて
全く触れられていません。
 
(例えば Workbooks オブジェクトの Open メソッドが
 呼び出される箇所が全体で 5 つあるが、そのうちのどれが
 「変更になった書式」に当たるブックを開いている箇所であるかが
 示されていない)
 
更に Excel ブックの生成処理と直接関わりがないと思われる
モジュールまで転載されていることによって、かえって
問題箇所の特定を難しくされています。
 
引用:
'Public Const strDEBUG As String = "debug" 'Debug.print出力※テスト用
Public Const strDEBUG As String = "" 'Debug.print出力なし※リリース用

Public Const strDEBUG As String = "debug" 'Debug.print出力※テスト用
'Public Const strDEBUG As String = "" 'Debug.print出力なし※リリース用
 
-----------------------------------------------------------------------------
 
とりあえず、上記の定数の値を "debug" にした上、コードの実行中に
イミディエイトウィンドウに出力されるテキストを確認するとか、
 
引用:
Function ご契約内容一覧作成()

上記のステートメント等にブレークポイントを設定して
ステップイン実行するなどしてデバッグ作業を行なわれることを
お奨めします。

回答
投稿日時: 18/05/02 14:45:57
投稿者: sk

追記:
 
あと明らかに異常だったのは以下の箇所。
 

引用:
Function ご契約内容一覧_明細(prSHT As Object, prRecCnt As Long)

引用:
With prSHT

引用:
' End With

With prSHT に対応する End With がコメントアウトされているため、
このままだとコンパイルエラーになるはず。
 
引用:
On Error GoTo ErrHandler

また、デバッグされるならばこのステートメントを
一時的にコメントアウトされた方がよいでしょう。

投稿日時: 18/05/02 17:08:52
投稿者: 2011wing

sk さんの引用:
追記:
 
あと明らかに異常だったのは以下の箇所。
 
引用:
Function ご契約内容一覧_明細(prSHT As Object, prRecCnt As Long)

引用:
With prSHT

引用:
' End With

With prSHT に対応する End With がコメントアウトされているため、
このままだとコンパイルエラーになるはず。
 
引用:
On Error GoTo ErrHandler

また、デバッグされるならばこのステートメントを
一時的にコメントアウトされた方がよいでしょう。

 
ありがとうございます。
お指摘の箇所を訂正して見事RUNできました
 
あとは枚数がすこし直さないとページがばらばらなのですこしやってみます

投稿日時: 18/05/03 10:22:36
投稿者: 2011wing

 End WithのコメントアウトをはずしてみごとRUNできるようになりました。
 書式の設定も完了しましたので、問題なく改修が終了となりました
長文のところ見事バグをみつけてくださり、スキルに関心するとともに
感謝の気持ちでいっぱいです。
また何かありましたら宜しくお願い致します。
ありがとうございました。