【VBA】TIFF → PDF 自動結合＋コメント貼付ツール

' =============================================================
' TIFF → PDF 自動結合＋コメント貼付ツール（ワンストップ版）
'
' ★★★ 調整はこの下の定数だけ触ればOK ★★★
'
' 【貼り付け先】
'   ■ 標準モジュール（Module1等）: このファイルの内容すべて
'   ■ シートモジュール: ファイル末尾の「シートモジュール用」をコピー
'     → VBAエディタ左のシート名をダブルクリックして貼り付け
'
' 【処理概要】
'   1. シート上のファイル名リスト × TIFFフォルダを突き合わせ
'   2. 先頭一致でマッチしたTIFFを、リスト順にWord経由でPDF結合
'   3. マルチページTIFFは全ページを自動展開して取り込み
'   4. モードに応じてコメントテキストボックスを埋め込み可能
'
' 【モード切替】
'   G9セルのプルダウンで選択 → シートモジュール経由で自動反映
'   - 「PDF作成時には埋め込まない」: コメントなし（青系ヘッダ）
'   - 「PDF作成時に埋め込み」    : コメント埋込（緑系ヘッダ）
'
' 【あとからコメント追加（JS生成）】
'   既存PDFにコメントを追加したい場合:
'   - Alt+F8 → 「JS生成_クリップボードコピー」を実行
'   - E列のコメント → Acrobat/PDF-XChange 互換の JavaScript を自動生成
'   - クリップボードにコピーされるので、PDFエディタの
'     JSコンソール（Ctrl+J）に貼り付けて実行
'
' 【マルチページTIFF対応】
'   1つのTIFFに複数ページが含まれる場合、全ページをPDFに展開する。
'   コメントは展開された全ページに同一テキストを貼付する。
' =============================================================
Option Compare Text  ' 文字列比較を大文字小文字区別なしに統一

' --- ① モードで色を変える見出し範囲（飛び地はカンマ区切り） ---
Private Const MODE_COLOR_RANGE As String = "A1:E1,G1,G3,G5,G8"

' --- ② シート上のセル配置 ---
Private Const CELL_TIF_PATH   As String = "G2"   ' tif格納先パス
Private Const CELL_PDF_NAME   As String = "G4"   ' PDF出力ファイル名
Private Const CELL_PDF_DIR    As String = "G6"   ' PDF出力先フォルダ
Private Const CELL_MODE_VALUE As String = "G9"   ' モード切替プルダウン

' --- ③ モード文言（プルダウンの選択肢と一致させること） ---
Private Const MODE1_LABEL As String = "PDF作成時には埋め込まない"
Private Const MODE2_LABEL As String = "PDF作成時に埋め込み"

' --- ④ モード別ヘッダ色 RGB（MODE_COLOR_RANGE に適用） ---
Private Const MODE1_COLOR As String = "200,220,255"  ' 青系（薄）
Private Const MODE2_COLOR As String = "200,240,210"  ' 緑系（薄）

' --- ⑤ データ列・行 ---
Private Const COL_ROT      As Long = 1   ' A列: 反転フラグ
Private Const COL_NUM      As Long = 2   ' B列: ファイル番号
Private Const COL_COMMENT  As Long = 5   ' E列: コメント
Private Const DATA_START_ROW As Long = 2 ' データ開始行（見出しの次）

' --- ⑥ PDF出力品質 ---
'   0 = wdExportOptimizeForPrint  （高品質 220dpi+ / 印刷向け）
'   1 = wdExportOptimizeForOnScreen（軽量 150dpi / 確認・メール向け）
Private Const PDF_QUALITY As Long = 0

' --- ⑦ 設定シートのセルアドレス ---
'   レイアウト変更時はここだけ修正
Private Const SET_FONT_SIZE  As String = "B3"   ' フォントサイズ
Private Const SET_FONT_NAME  As String = "B4"   ' フォント名
Private Const SET_TEXT_COLOR As String = "B5"   ' 文字色
Private Const SET_BG_COLOR   As String = "B7"   ' 背景色
Private Const SET_BORDER     As String = "B8"   ' 枠線（あり/なし）
Private Const SET_BORDER_CLR As String = "B9"   ' 枠線色
Private Const SET_POSITION   As String = "B11"  ' 配置位置

' =============================================================
' ここから下は基本さわらなくてOK
' =============================================================


'##############################################################################
'#  モード切替（プルダウン変更時にシートモジュールから呼ばれる）
'##############################################################################

' =========================================
' モード反映（公開エントリポイント）
'   シートモジュールの Worksheet_Change から呼び出される。
'   G9 の値に応じてヘッダ色・コメント列の見た目を切り替える。
' =========================================
Public Sub モード反映()
    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim mode As String: mode = Trim(CStr(ws.Range(CELL_MODE_VALUE).Value))

    UpdateModeDisplay ws, mode

    Application.StatusBar = "モード変更: " & mode
    Application.OnTime Now + TimeValue("00:00:03"), "ClearStatus"
End Sub

Sub ClearStatus()
    Application.StatusBar = False
End Sub

' =========================================
' UpdateModeDisplay - ヘッダ色 & コメント列の見た目を更新
'
' 処理内容:
'   1. MODE_COLOR_RANGE（見出しセル群）の背景色をモードに応じて切替
'   2. コメント列（E列）の文字色を切替
'      - コメントなしモード → グレーアウト（入力不要を視覚的に伝える）
'      - コメント埋込モード → 黒に復元
' =========================================
Private Sub UpdateModeDisplay(ws As Worksheet, mode As String)

    ' モードに応じたヘッダ色を適用（"R,G,B" 文字列 → RGB値）
    Dim colorStr As String
    If mode = MODE1_LABEL Then colorStr = MODE1_COLOR Else colorStr = MODE2_COLOR
    Dim rgb_() As String: rgb_ = Split(colorStr, ",")
    ws.Range(MODE_COLOR_RANGE).Interior.Color = _
        RGB(CLng(rgb_(0)), CLng(rgb_(1)), CLng(rgb_(2)))

    ' コメント列の文字色切替
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, COL_NUM).End(xlUp).Row
    If lastRow >= DATA_START_ROW Then
        Dim fontClr As Long
        If mode = MODE1_LABEL Then fontClr = RGB(180, 180, 180) Else fontClr = RGB(0, 0, 0)
        ws.Range(ws.Cells(DATA_START_ROW, COL_COMMENT), _
                 ws.Cells(lastRow, COL_COMMENT)).Font.Color = fontClr
    End If

End Sub


'##############################################################################
'#  PDF生成メイン
'##############################################################################

' =========================================
' TiffToPdf - TIFF → PDF 結合処理
'
' 処理フロー:
'   1. モード判定 & セル設定読込
'   2. フォルダ存在チェック & PDF上書き確認 & ロックチェック
'   3. コメント設定読込（埋込モード時のみ、「設定」シートから）
'   4. データ読込（ファイル名・反転フラグ・コメント）
'   5. TIFFスキャン & 先頭一致マッチング & フレーム数検出
'   6. Word経由でPDF生成（マルチページ展開 + コメント）
'   7. PDF出力 & 完了メッセージ
'
' 堅牢性:
'   - マルチページTIFFを自動検出・全ページ展開
'   - エラー発生時もWordプロセスを確実に終了（孤児プロセス防止）
'   - Application設定（ScreenUpdating等）を確実に復元
'   - 深夜0時またぎ対応のタイマー
' =========================================
Sub TiffToPdf()

    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim startTime As Double: startTime = Timer  ' 処理時間計測（秒）

    ' --- Excel画面更新・イベント・再計算を一時停止（高速化） ---
    Dim prevScreenUpdating As Boolean: prevScreenUpdating = Application.ScreenUpdating
    Dim prevEnableEvents   As Boolean: prevEnableEvents = Application.EnableEvents
    Dim prevCalc As XlCalculation:     prevCalc = Application.Calculation

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    ' --- Word/一時ファイルのクリーンアップ用変数（エラー時にも使う） ---
    Dim wdApp As Object:    Set wdApp = Nothing
    Dim doc   As Object:    Set doc = Nothing
    Dim tempPath As String: tempPath = ""

    ' エラー発生時はクリーンアップ処理へジャンプ
    On Error GoTo ErrHandler

    '==========================================================================
    ' STEP 1: モード判定 & セル設定読込
    '==========================================================================
    Dim commentMode As Boolean
    Dim modeVal As String: modeVal = Trim(CStr(ws.Range(CELL_MODE_VALUE).Value))
    commentMode = (modeVal = MODE2_LABEL)

    Dim tiffFolder As String: tiffFolder = Trim(CStr(ws.Range(CELL_TIF_PATH).Value))
    Dim pdfName    As String: pdfName = Trim(CStr(ws.Range(CELL_PDF_NAME).Value))
    Dim pdfFolder  As String: pdfFolder = Trim(CStr(ws.Range(CELL_PDF_DIR).Value))

    ' --- 必須項目チェック ---
    If tiffFolder = "" Then
        MsgBox "エラー: " & CELL_TIF_PATH & "セル（tif格納先）が空です。", vbCritical, "設定不足"
        ws.Range(CELL_TIF_PATH).Select: GoTo Cleanup
    End If
    If pdfName = "" Then
        MsgBox "エラー: " & CELL_PDF_NAME & "セル（PDFファイル名）が空です。", vbCritical, "設定不足"
        ws.Range(CELL_PDF_NAME).Select: GoTo Cleanup
    End If
    If pdfFolder = "" Then
        MsgBox "エラー: " & CELL_PDF_DIR & "セル（PDF出力先）が空です。", vbCritical, "設定不足"
        ws.Range(CELL_PDF_DIR).Select: GoTo Cleanup
    End If

    ' --- パス正規化 ---
    If LCase(Right(pdfName, 4)) <> ".pdf" Then pdfName = pdfName & ".pdf"
    If Right(tiffFolder, 1) <> "\" Then tiffFolder = tiffFolder & "\"
    If Right(pdfFolder, 1) <> "\" Then pdfFolder = pdfFolder & "\"
    Dim outputPdf As String: outputPdf = pdfFolder & pdfName

    '==========================================================================
    ' STEP 2: フォルダ存在チェック & PDF上書き確認 & ロックチェック
    '==========================================================================
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")

    If Not fso.FolderExists(tiffFolder) Then
        MsgBox "エラー: tif格納先が見つかりません。" & vbCrLf & tiffFolder, vbCritical, "フォルダなし"
        GoTo Cleanup
    End If
    If Not fso.FolderExists(pdfFolder) Then
        MsgBox "エラー: PDF出力先が見つかりません。" & vbCrLf & pdfFolder, vbCritical, "フォルダなし"
        GoTo Cleanup
    End If

    ' 出力先PDFが既に存在する場合 → 上書き確認ダイアログ
    If Dir(outputPdf) <> "" Then
        Dim ans As VbMsgBoxResult
        ans = MsgBox("同名のPDFが既に存在します。上書きしますか？" & vbCrLf & vbCrLf & _
                     outputPdf, _
                     vbExclamation + vbYesNo + vbDefaultButton2, "上書き確認")
        If ans <> vbYes Then
            MsgBox "処理を中止しました。", vbInformation, "中止"
            GoTo Cleanup
        End If

        ' 上書きOK → ファイルがロックされていないか確認
        Dim fn As Integer: fn = FreeFile
        On Error Resume Next
        Open outputPdf For Binary Access Read Write Lock Read Write As #fn
        If Err.Number <> 0 Then
            On Error GoTo ErrHandler
            MsgBox "エラー: PDFが開かれています。" & vbCrLf & _
                   "閉じてから再実行してください。", vbCritical, "PDF上書きブロック"
            GoTo Cleanup
        End If
        Close #fn
        On Error GoTo ErrHandler
    End If

    '==========================================================================
    ' STEP 3: コメント設定読込（埋込モード時のみ）
    '   「設定」シートの定数セルからフォント・色・位置等を読み込む。
    '   設定シートがなければデフォルト値をそのまま使用。
    '==========================================================================
    Dim fontSize      As Long:    fontSize = 10
    Dim fontName      As String:  fontName = "Yu Gothic"
    Dim fontBold      As Boolean: fontBold = False
    Dim textColor     As Long:    textColor = vbRed
    Dim bgColor       As Long:    bgColor = vbWhite
    Dim bgTransparent As Boolean: bgTransparent = False
    Dim borderOn      As Boolean: borderOn = False
    Dim borderColor   As Long:    borderColor = vbBlack
    Dim position      As String:  position = "左上"

    If commentMode Then
        Dim wsSetting As Worksheet
        On Error Resume Next
        Set wsSetting = ThisWorkbook.Sheets("設定")
        On Error GoTo ErrHandler

        If Not wsSetting Is Nothing Then
            Dim sv As String
            ' フォントサイズ
            If wsSetting.Range(SET_FONT_SIZE).Value <> "" Then fontSize = CLng(wsSetting.Range(SET_FONT_SIZE).Value)
            ' フォント名
            If wsSetting.Range(SET_FONT_NAME).Value <> "" Then
                sv = CStr(wsSetting.Range(SET_FONT_NAME).Value)
                Select Case LCase(Replace(sv, " ", ""))
                    ' --- 一般向け名称（日本語） ---
                    Case "ゴシック":       fontName = "Arial":           fontBold = False
                    Case "ゴシック太字":   fontName = "Arial":           fontBold = True
                    Case "明朝":           fontName = "Times New Roman": fontBold = False
                    Case "明朝太字":       fontName = "Times New Roman": fontBold = True
                    Case "等幅":           fontName = "Courier New":     fontBold = False
                    Case "等幅太字":       fontName = "Courier New":     fontBold = True
                    ' --- Windows フォント名 ---
                    Case "arial":          fontName = "Arial":           fontBold = False
                    Case "arial太字":      fontName = "Arial":           fontBold = True
                    Case "couriernew":     fontName = "Courier New":     fontBold = False
                    Case "timesnewroman":  fontName = "Times New Roman": fontBold = False
                    Case "メイリオ":       fontName = "メイリオ":         fontBold = False
                    Case "メイリオ太字":   fontName = "メイリオ":         fontBold = True
                    Case "yugothic":       fontName = "Yu Gothic":       fontBold = False
                    ' --- CAD系短縮名（従来互換） ---
                    Case "helvb":          fontName = "Arial":           fontBold = True
                    Case "helv":           fontName = "Arial":           fontBold = False
                    Case "courb":          fontName = "Courier New":     fontBold = True
                    Case "cour":           fontName = "Courier New":     fontBold = False
                    Case "timesb":         fontName = "Times New Roman": fontBold = True
                    Case "times":          fontName = "Times New Roman": fontBold = False
                    ' --- その他: そのまま使用 ---
                    Case Else:             fontName = sv
                End Select
            End If
            ' 文字色
            If wsSetting.Range(SET_TEXT_COLOR).Value <> "" Then textColor = ColorFromName(CStr(wsSetting.Range(SET_TEXT_COLOR).Value))
            ' 背景色（"none" で透過）
            If wsSetting.Range(SET_BG_COLOR).Value <> "" Then
                sv = LCase(CStr(wsSetting.Range(SET_BG_COLOR).Value))
                If sv = "none" Then bgTransparent = True Else bgColor = ColorFromName(sv)
            End If
            ' 枠線
            If wsSetting.Range(SET_BORDER).Value <> "" Then borderOn = (CStr(wsSetting.Range(SET_BORDER).Value) = "あり")
            ' 枠線色
            If wsSetting.Range(SET_BORDER_CLR).Value <> "" Then borderColor = ColorFromName(CStr(wsSetting.Range(SET_BORDER_CLR).Value))
            ' 配置位置
            If wsSetting.Range(SET_POSITION).Value <> "" Then position = CStr(wsSetting.Range(SET_POSITION).Value)
        End If
    End If

    '==========================================================================
    ' STEP 4: データ読込（ファイル名・反転フラグ・コメント）
    '   シートからまとめて配列に読み込む（セル個別アクセスより高速）
    '==========================================================================
    Dim lastDataRow As Long
    lastDataRow = ws.Cells(ws.Rows.Count, COL_NUM).End(xlUp).Row
    Dim cnt As Long: cnt = lastDataRow - DATA_START_ROW + 1

    If cnt <= 0 Then
        MsgBox "エラー: ファイル名が1件もありません。" & vbCrLf & _
               "（" & COL_NUM & "列目, " & DATA_START_ROW & "行目～）", vbCritical, "データなし"
        GoTo Cleanup
    End If

    ' シートから一括読込（セル個別アクセスの数十倍高速）
    Dim vNums As Variant:     vNums = ws.Range(ws.Cells(DATA_START_ROW, COL_NUM), ws.Cells(lastDataRow, COL_NUM)).Value
    Dim vRots As Variant:     vRots = ws.Range(ws.Cells(DATA_START_ROW, COL_ROT), ws.Cells(lastDataRow, COL_ROT)).Value
    Dim vComments As Variant: vComments = ws.Range(ws.Cells(DATA_START_ROW, COL_COMMENT), ws.Cells(lastDataRow, COL_COMMENT)).Value

    ' 空行で途切れるまでの有効件数を再カウント（途中空行対策）
    Dim validCnt As Long: validCnt = 0
    Dim r As Long
    For r = 1 To cnt
        If Trim(CStr(vNums(r, 1))) = "" Then Exit For
        validCnt = validCnt + 1
    Next r
    cnt = validCnt

    If cnt = 0 Then
        MsgBox "エラー: ファイル名が1件もありません。", vbCritical, "データなし"
        GoTo Cleanup
    End If

    ' 作業用配列に展開
    Dim nums() As String, rotDirs() As String, comments() As String
    ReDim nums(1 To cnt): ReDim rotDirs(1 To cnt): ReDim comments(1 To cnt)
    For r = 1 To cnt
        nums(r) = Trim(CStr(vNums(r, 1)))
        rotDirs(r) = UCase(Trim(CStr(vRots(r, 1))))
        If commentMode Then
            comments(r) = Trim(CStr(vComments(r, 1)))
        Else
            comments(r) = ""
        End If
    Next r

    '==========================================================================
    ' STEP 5: TIFFスキャン & 先頭一致マッチング & フレーム数検出
    '   - TIFFフォルダ内の全 .tif/.tiff をスキャン → Dictionary に格納
    '   - ファイル名リストと先頭一致で照合
    '   - マッチしたTIFFのフレーム数（ページ数）を検出
    '   - 0件ヒット → missing / 複数ヒット → duplicate でエラー
    '==========================================================================

    ' --- TIFFファイルをDictionaryに収集 ---
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    Dim f As Object, ext As String, baseName As String
    Dim hasError As Boolean: hasError = False
    Dim errMsg As String: errMsg = ""

    For Each f In fso.GetFolder(tiffFolder).Files
        ext = LCase(fso.GetExtensionName(f.Name))
        If ext = "tif" Or ext = "tiff" Then
            baseName = fso.GetBaseName(f.Name)
            If dict.Exists(baseName) Then
                errMsg = errMsg & "重複: " & f.Name & " と " & fso.GetFileName(dict(baseName)) & vbCrLf
                hasError = True
            Else
                dict.Add baseName, f.Path
            End If
        End If
    Next f

    If hasError Then
        MsgBox "エラー: 同名TIFFがあります。" & vbCrLf & vbCrLf & errMsg, vbCritical, "重複エラー"
        GoTo Cleanup
    End If

    ' --- 先頭一致マッチング ---
    Dim sortedPaths() As String, sortedRots() As String, sortedComments() As String
    Dim sortedFrameCounts() As Long
    ReDim sortedPaths(1 To cnt): ReDim sortedRots(1 To cnt): ReDim sortedComments(1 To cnt)
    ReDim sortedFrameCounts(1 To cnt)
    Dim missingMsg  As String: missingMsg = ""
    Dim dupMatchMsg As String: dupMatchMsg = ""
    Dim matchCount  As Long:   matchCount = 0
    Dim allKeys() As Variant:  allKeys = dict.Keys

    For r = 1 To cnt
        Dim searchNum As String: searchNum = nums(r)
        Dim hitCount  As Long:   hitCount = 0
        Dim hitPath   As String: hitPath = ""
        Dim hitNames  As String: hitNames = ""
        Dim k As Long

        For k = 0 To UBound(allKeys)
            If Left(CStr(allKeys(k)), Len(searchNum)) = searchNum Then
                hitCount = hitCount + 1
                hitPath = dict(allKeys(k))
                hitNames = hitNames & "  " & fso.GetFileName(CStr(dict(allKeys(k)))) & vbCrLf
            End If
        Next k

        If hitCount = 0 Then
            missingMsg = missingMsg & "  - " & nums(r) & vbCrLf
        ElseIf hitCount > 1 Then
            dupMatchMsg = dupMatchMsg & "  - " & nums(r) & " → " & hitCount & "件:" & vbCrLf & hitNames
        Else
            matchCount = matchCount + 1
            sortedPaths(matchCount) = hitPath
            sortedRots(matchCount) = rotDirs(r)
            sortedComments(matchCount) = comments(r)
        End If
    Next r

    ' マッチングエラーがあれば中止
    If missingMsg <> "" Or dupMatchMsg <> "" Then
        Dim fullErr As String: fullErr = ""
        If missingMsg <> "" Then fullErr = "【見つからない】" & vbCrLf & missingMsg & vbCrLf
        If dupMatchMsg <> "" Then fullErr = fullErr & "【複数ヒット】" & vbCrLf & dupMatchMsg
        MsgBox "エラー: PDF生成を中止しました。" & vbCrLf & vbCrLf & fullErr, vbCritical, "マッチングエラー"
        GoTo Cleanup
    End If

    ' --- フレーム数（ページ数）の事前スキャン ---
    '   マルチページTIFFを検出し、総PDFページ数を算出する。
    '   この情報は進捗表示・完了メッセージ・コメント配置に必要。
    Dim totalPdfPages As Long: totalPdfPages = 0
    Dim multiPageInfo As String: multiPageInfo = ""  ' マルチページTIFF検出時の情報
    Dim multiPageCount As Long: multiPageCount = 0

    Application.StatusBar = "TIFFフレーム数を確認中..."
    Dim i As Long
    For i = 1 To matchCount
        sortedFrameCounts(i) = GetTiffFrameCount(sortedPaths(i))
        totalPdfPages = totalPdfPages + sortedFrameCounts(i)
        If sortedFrameCounts(i) > 1 Then
            multiPageCount = multiPageCount + 1
            multiPageInfo = multiPageInfo & "  " & fso.GetFileName(sortedPaths(i)) & _
                            " (" & sortedFrameCounts(i) & "ページ)" & vbCrLf
        End If
    Next i

    '==========================================================================
    ' STEP 6: Word経由でPDF生成
    '   - A3横（841.89 x 595.28 pt）、余白0のページに画像をフィット配置
    '   - マルチページTIFFは WIA の ActiveFrame で各フレームを抽出
    '   - 縦長画像は WIA で自動回転（A列の "R" で回転方向指定）
    '   - コメント埋込モードでは、各TIFFの1ページ目にテキストボックスを重ねる
    '==========================================================================
    Dim modeLabel As String
    If commentMode Then modeLabel = MODE2_LABEL Else modeLabel = MODE1_LABEL
    Application.StatusBar = "モード：" & modeLabel & "　　バックグラウンドでWord起動中..."

    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = False
    wdApp.DisplayAlerts = 0  ' wdAlertsNone: Word側のダイアログを抑制
    Set doc = wdApp.Documents.Add

    ' A3横のページサイズ（ポイント）
    Dim pgW As Double: pgW = 841.89
    Dim pgH As Double: pgH = 595.28

    With doc.PageSetup
        .Orientation = 1  ' wdOrientLandscape
        .PageWidth = pgW: .PageHeight = pgH
        .TopMargin = 0: .BottomMargin = 0
        .LeftMargin = 0: .RightMargin = 0
    End With

    ' 一時ファイルはシステムTempフォルダに保存（TIFFフォルダ内だと
    ' Explorerがサムネ再描画を繰返し、I/O競合で処理が遅くなるため）
    tempPath = Environ("TEMP") & "\tiff2pdf_temp_rotated.png"
    Dim usePath  As String
    Dim margin   As Double: margin = 6  ' コメントボックスの端からの余白(pt)

    Dim pdfPageNum As Long: pdfPageNum = 0   ' 累計PDFページ番号
    Dim commentCount As Long: commentCount = 0  ' コメント貼付数（完了メッセージ用）

    For i = 1 To matchCount
        Dim frameCount As Long: frameCount = sortedFrameCounts(i)
        Dim frameIdx As Long

        For frameIdx = 1 To frameCount
            pdfPageNum = pdfPageNum + 1

            ' --- 進捗表示 ---
            Application.StatusBar = "モード：" & modeLabel & "　　" & _
                pdfPageNum & "/" & totalPdfPages & "ページ目（バックグラウンドでWordにtif読込中...）"

            ' --- WIAで画像読込 ---
            Dim wiaImg As Object: Set wiaImg = CreateObject("WIA.ImageFile")
            wiaImg.LoadFile sortedPaths(i)

            ' マルチページTIFFの場合、対象フレームを選択
            If frameCount > 1 Then wiaImg.ActiveFrame = frameIdx

            Dim imgW As Long: imgW = wiaImg.Width
            Dim imgH As Long: imgH = wiaImg.Height

            ' マルチページ or 縦長 → 一時ファイルに書き出す必要あり
            Dim needsRotation As Boolean: needsRotation = (imgH > imgW)
            Dim needsTempFile As Boolean: needsTempFile = (frameCount > 1) Or needsRotation

            If needsTempFile Then
                Dim wiaProc As Object: Set wiaProc = CreateObject("WIA.ImageProcess")

                ' 縦長画像 → 横向きに回転（Rなら270°、それ以外は90°）
                If needsRotation Then
                    wiaProc.Filters.Add wiaProc.FilterInfos("RotateFlip").FilterID
                    If sortedRots(i) = "R" Then
                        wiaProc.Filters(1).Properties("RotationAngle") = 270
                    Else
                        wiaProc.Filters(1).Properties("RotationAngle") = 90
                    End If
                End If

                ' 変換フィルタ（マルチページからフレーム抽出 + PNG化）
                wiaProc.Filters.Add wiaProc.FilterInfos("Convert").FilterID
                wiaProc.Filters(wiaProc.Filters.Count).Properties("FormatID") = _
                    "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"  ' PNG GUID

                Set wiaImg = wiaProc.Apply(wiaImg)
                If Dir(tempPath) <> "" Then Kill tempPath
                wiaImg.SaveFile tempPath
                usePath = tempPath
                Set wiaProc = Nothing
            Else
                usePath = sortedPaths(i)
            End If
            Set wiaImg = Nothing

            ' --- 2ページ目以降はセクション区切りを挿入 ---
            If pdfPageNum > 1 Then
                Dim rng As Object: Set rng = doc.Content
                rng.Collapse 0  ' wdCollapseEnd
                rng.InsertBreak 2  ' wdSectionBreakNewPage
                With doc.Sections(doc.Sections.Count).PageSetup
                    .Orientation = 1
                    .PageWidth = pgW: .PageHeight = pgH
                    .TopMargin = 0: .BottomMargin = 0
                    .LeftMargin = 0: .RightMargin = 0
                End With
            End If

            ' --- 画像をページ全面に浮動配置 ---
            Dim shp As Object
            Set shp = doc.Shapes.AddPicture( _
                Filename:=usePath, LinkToFile:=False, SaveWithDocument:=True, _
                Left:=0, Top:=0, Width:=pgW, Height:=pgH, _
                Anchor:=doc.Sections(doc.Sections.Count).Range)
            shp.RelativeHorizontalPosition = 1  ' wdRelativeHorizontalPositionPage
            shp.RelativeVerticalPosition = 1    ' wdRelativeVerticalPositionPage
            shp.Left = 0: shp.Top = 0
            shp.LockAspectRatio = 0  ' msoFalse（ページにフィット）
            shp.Width = pgW: shp.Height = pgH
            shp.WrapFormat.Type = 3  ' wdWrapBehindText

            ' --- コメント（埋込モード & コメントありの場合、全ページに同一コメント）---
            If commentMode And sortedComments(i) <> "" Then
                commentCount = commentCount + 1

                ' テキストボックスの幅を文字数から概算
                Dim tw As Double: tw = 0
                Dim ch As Long, j As Long
                For j = 1 To Len(sortedComments(i))
                    ch = AscW(Mid(sortedComments(i), j, 1))
                    If ch > 255 Then tw = tw + fontSize Else tw = tw + fontSize * 0.55
                Next j
                tw = tw + 8  ' 左右パディング分

                Dim th As Double: th = fontSize + 8  ' 上下パディング分

                ' 配置位置の計算
                Dim tbLeft As Double, tbTop As Double
                Select Case position
                    Case "右上": tbLeft = pgW - margin - tw: tbTop = margin
                    Case "左下": tbLeft = margin:            tbTop = pgH - margin - th
                    Case "右下": tbLeft = pgW - margin - tw: tbTop = pgH - margin - th
                    Case Else:   tbLeft = margin:            tbTop = margin  ' デフォルト=左上
                End Select

                ' テキストボックス作成 & スタイル設定
                Dim tb As Object
                Set tb = doc.Shapes.AddTextbox(1, tbLeft, tbTop, tw, th, _
                    doc.Sections(doc.Sections.Count).Range)
                tb.RelativeHorizontalPosition = 1
                tb.RelativeVerticalPosition = 1
                tb.Left = tbLeft: tb.Top = tbTop
                tb.Width = tw: tb.Height = th
                tb.WrapFormat.Type = 3

                ' テキスト設定
                tb.TextFrame.TextRange.Text = sortedComments(i)
                tb.TextFrame.TextRange.Font.Name = fontName
                tb.TextFrame.TextRange.Font.Bold = fontBold
                tb.TextFrame.TextRange.Font.Size = fontSize
                tb.TextFrame.TextRange.Font.Color = textColor
                tb.TextFrame.MarginLeft = 2: tb.TextFrame.MarginRight = 2
                tb.TextFrame.MarginTop = 1: tb.TextFrame.MarginBottom = 1

                ' 背景
                If bgTransparent Then
                    tb.Fill.Visible = False
                Else
                    tb.Fill.Visible = True
                    tb.Fill.ForeColor.RGB = bgColor
                    tb.Fill.Transparency = 0
                End If

                ' 枠線
                If borderOn Then
                    tb.Line.Visible = True
                    tb.Line.ForeColor.RGB = borderColor
                    tb.Line.Weight = 0.5
                Else
                    tb.Line.Visible = False
                End If
            End If

        Next frameIdx
    Next i

    '==========================================================================
    ' STEP 7: PDF出力 & 後処理
    '==========================================================================
    Application.StatusBar = "モード：" & modeLabel & "　　PDF出力中..."
    ' PDF出力（品質はファイル先頭の PDF_QUALITY 定数で切替）
    doc.ExportAsFixedFormat _
        OutputFileName:=outputPdf, _
        ExportFormat:=17, _
        OpenAfterExport:=False, _
        OptimizeFor:=PDF_QUALITY, _
        CreateBookmarks:=0, _
        DocStructureTags:=False
    doc.Close False: Set doc = Nothing
    wdApp.Quit:      Set wdApp = Nothing

    ' 一時ファイルの削除
    If tempPath <> "" And Dir(tempPath) <> "" Then Kill tempPath
    tempPath = ""

    ' --- 処理時間算出（深夜0時またぎ対応） ---
    Dim elapsed As Double: elapsed = Timer - startTime
    If elapsed < 0 Then elapsed = elapsed + 86400  ' 24h = 86400秒
    Dim timeStr As String
    If elapsed < 60 Then
        timeStr = Format(elapsed, "0.0") & " 秒"
    Else
        timeStr = Format(Int(elapsed / 60), "0") & " 分 " & Format(elapsed - Int(elapsed / 60) * 60, "0") & " 秒"
    End If

    ' --- 完了メッセージ ---
    Dim doneMsg As String
    doneMsg = "完了！（" & modeLabel & "モード）" & vbCrLf & _
              "tifファイル " & matchCount & " 件 → " & totalPdfPages & " ページ"
    If commentMode Then doneMsg = doneMsg & vbCrLf & "コメント: " & commentCount & " 件"
    If multiPageCount > 0 Then
        doneMsg = doneMsg & vbCrLf & vbCrLf & _
                  "【マルチページTIFF " & multiPageCount & " 件を自動展開】" & vbCrLf & multiPageInfo
    End If
    doneMsg = doneMsg & vbCrLf & "処理時間: " & timeStr
    doneMsg = doneMsg & vbCrLf & vbCrLf & outputPdf

    ' Excel設定を先に復元してからメッセージ表示
    Application.ScreenUpdating = prevScreenUpdating
    Application.EnableEvents = prevEnableEvents
    Application.Calculation = prevCalc
    Application.StatusBar = False

    MsgBox doneMsg, vbInformation, "PDF生成完了"
    Exit Sub

ErrHandler:
    '==========================================================================
    ' エラーハンドラ: Word孤児プロセス防止 & 一時ファイル削除
    '==========================================================================
    Dim errText As String
    errText = "予期しないエラーが発生しました。" & vbCrLf & vbCrLf & _
              "エラー番号: " & Err.Number & vbCrLf & _
              "内容: " & Err.Description

Cleanup:
    ' --- Wordプロセスの確実な終了 ---
    On Error Resume Next
    If Not doc Is Nothing Then doc.Close False: Set doc = Nothing
    If Not wdApp Is Nothing Then wdApp.Quit: Set wdApp = Nothing

    ' --- 一時ファイル削除 ---
    If tempPath <> "" And Dir(tempPath) <> "" Then Kill tempPath

    ' --- Excel設定の復元（必ず実行） ---
    Application.ScreenUpdating = prevScreenUpdating
    Application.EnableEvents = prevEnableEvents
    Application.Calculation = prevCalc
    Application.StatusBar = False
    On Error GoTo 0

    ' ErrHandlerから来た場合のみエラーメッセージを表示
    If errText <> "" Then
        MsgBox errText, vbCritical, "エラー"
    End If

End Sub


'##############################################################################
'#  ヘルパー関数
'##############################################################################

' =========================================
' GetTiffFrameCount - TIFFファイルのフレーム数（ページ数）を返す
'   マルチページTIFF判定に使用。
'   通常のTIFF → 1 / マルチページ → 2以上
' =========================================
Private Function GetTiffFrameCount(ByVal filePath As String) As Long
    Dim wiaImg As Object
    Set wiaImg = CreateObject("WIA.ImageFile")
    wiaImg.LoadFile filePath
    GetTiffFrameCount = wiaImg.FrameCount
    Set wiaImg = Nothing
End Function

' =========================================
' ColorFromName - 色名 → RGB値 変換
'   設定シートの色指定（文字列）を RGB Long値 に変換する。
'   未知の色名はデフォルトで赤を返す。
' =========================================
Private Function ColorFromName(ByVal Name As String) As Long
    Select Case LCase(Trim(Name))
        Case "red":    ColorFromName = RGB(255, 0, 0)
        Case "blue":   ColorFromName = RGB(0, 0, 255)
        Case "green":  ColorFromName = RGB(0, 128, 0)
        Case "black":  ColorFromName = RGB(0, 0, 0)
        Case "white":  ColorFromName = RGB(255, 255, 255)
        Case "yellow": ColorFromName = RGB(255, 255, 0)
        Case Else:     ColorFromName = RGB(255, 0, 0)  ' デフォルト=赤
    End Select
End Function

' =========================================
' ColorToJsExpr - 色名 → Acrobat JS の color 式 に変換
'   Acrobat / PDF-XChange 両対応。
'   ※ color.green は RGB(0,255,0) = 蛍光グリーンで Word 側と合わないため、
'     RGB直接指定 ["RGB",0,0.502,0] = RGB(0,128,0) に統一。
' =========================================
Private Function ColorToJsExpr(ByVal Name As String) As String
    Select Case LCase(Trim(Name))
        Case "red":    ColorToJsExpr = "color.red"
        Case "blue":   ColorToJsExpr = "color.blue"
        Case "green":  ColorToJsExpr = "[""RGB"",0,0.502,0]"  ' RGB(0,128,0) = Word側と同じ渋緑
        Case "black":  ColorToJsExpr = "color.black"
        Case "white":  ColorToJsExpr = "color.white"
        Case "yellow": ColorToJsExpr = "color.yellow"
        Case "none":   ColorToJsExpr = "[""T""]"   ' 透明
        Case Else:     ColorToJsExpr = "color.red"  ' デフォルト=赤
    End Select
End Function

' =========================================
' FontToPdfName - 設定シートのフォント名 → PDF標準フォント名 に変換
'   FreeText注釈の textFont プロパティ用。
'   ※ 日本語テキストはエディタ側が自動でCJKフォントに代替表示する。
'
'   PDF標準14フォントの短縮名:
'     Helv = Helvetica       HeBo = Helvetica-Bold
'     Cour = Courier         CoBo = Courier-Bold
'     TiRo = Times-Roman     TiBo = Times-Bold
' =========================================
Private Function FontToPdfName(ByVal Name As String) As String
    Select Case LCase(Replace(Trim(Name), " ", ""))
        ' --- 一般向け名称（日本語） ---
        Case "ゴシック":       FontToPdfName = "Helv"
        Case "ゴシック太字":   FontToPdfName = "HeBo"
        Case "明朝":           FontToPdfName = "TiRo"
        Case "明朝太字":       FontToPdfName = "TiBo"
        Case "等幅":           FontToPdfName = "Cour"
        Case "等幅太字":       FontToPdfName = "CoBo"
        Case "メイリオ":       FontToPdfName = "Helv"
        Case "メイリオ太字":   FontToPdfName = "HeBo"
        ' --- CAD系短縮名 ---
        Case "helvb":  FontToPdfName = "HeBo"
        Case "helv":   FontToPdfName = "Helv"
        Case "courb":  FontToPdfName = "CoBo"
        Case "cour":   FontToPdfName = "Cour"
        Case "timesb": FontToPdfName = "TiBo"
        Case "times":  FontToPdfName = "TiRo"
        ' --- Windowsフォント名 ---
        Case "arial":          FontToPdfName = "Helv"
        Case "arial太字":      FontToPdfName = "HeBo"
        Case "couriernew":     FontToPdfName = "Cour"
        Case "timesnewroman":  FontToPdfName = "TiRo"
        Case "yugothic":       FontToPdfName = "Helv"
        Case Else:             FontToPdfName = "Helv"
    End Select
End Function


'##############################################################################
'#  あとからコメント追加（JavaScript 生成 → クリップボードコピー）
'##############################################################################
'
'  既に作成済みの PDF にコメントを追加したい場合に使う。
'  E列のコメントから、Acrobat / PDF-XChange 互換の JavaScript を生成し、
'  クリップボードにコピーする。
'
'  【マルチページTIFF対応】
'    TIFFフォルダを参照してフレーム数を検出し、正しいPDFページ番号を算出。
'    マルチページTIFFは全ページに同一コメントを貼付（PDF生成時と同じ動作）。
'    TIFFフォルダが空や未設定の場合は、従来通り 1行=1ページ として動作。
'
'  【使い方】
'    1. Alt+F8 →「JS生成_クリップボードコピー」を実行
'    2. PDFエディタで対象PDFを開く
'    3. JSコンソール（Ctrl+J）を開く
'    4. Ctrl+V で貼り付け → 実行
'##############################################################################

' =========================================
' JS生成_クリップボードコピー（公開マクロ / ボタン割当用）
'
' 処理フロー:
'   1. E列からコメントを読込 + TIFFフレーム数でページ番号算出
'   2.「設定」シートからスタイル設定を読込
'   3. JavaScript コードを文字列として組み立て（Array+Join で高速結合）
'   4. クリップボードにコピー
'   5. 確認メッセージ表示
' =========================================
Public Sub JS生成_クリップボードコピー()

    Dim ws As Worksheet: Set ws = ActiveSheet

    '==========================================================================
    ' STEP 1: E列からコメントを読込 + TIFFフレーム数でページ番号算出
    '   マルチページTIFF対応: TIFFフォルダから各TIFFのフレーム数を取得し、
    '   正しいPDFページ番号を算出する（PDF生成時と同じページ配置を再現）。
    '==========================================================================

    ' --- TIFFフォルダからフレーム数を取得する準備 ---
    Dim tiffFolder As String: tiffFolder = Trim(CStr(ws.Range(CELL_TIF_PATH).Value))
    Dim hasTiffFolder As Boolean: hasTiffFolder = False
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim tiffDict As Object: Set tiffDict = CreateObject("Scripting.Dictionary")
    tiffDict.CompareMode = vbTextCompare

    ' TIFFフォルダが有効ならDictionaryを構築
    If tiffFolder <> "" Then
        If Right(tiffFolder, 1) <> "\" Then tiffFolder = tiffFolder & "\"
        If fso.FolderExists(tiffFolder) Then
            hasTiffFolder = True
            Dim f As Object, ext As String
            For Each f In fso.GetFolder(tiffFolder).Files
                ext = LCase(fso.GetExtensionName(f.Name))
                If ext = "tif" Or ext = "tiff" Then
                    Dim bn As String: bn = fso.GetBaseName(f.Name)
                    If Not tiffDict.Exists(bn) Then tiffDict.Add bn, f.Path
                End If
            Next f
        End If
    End If

    ' --- E列読込 + ページ番号算出 ---
    Dim pageComments As Collection  ' 各要素: Array(0ベースページ番号, コメント文)
    Set pageComments = New Collection

    Dim r As Long: r = DATA_START_ROW
    Dim pdfPageIdx As Long: pdfPageIdx = 0  ' 累計PDFページ番号（0ベース）
    Dim totalPdfPages As Long: totalPdfPages = 0

    Do While ws.Cells(r, COL_NUM).Value <> ""
        Dim cmt As String: cmt = Trim(CStr(ws.Cells(r, COL_COMMENT).Value))
        Dim drawingNum As String: drawingNum = Trim(CStr(ws.Cells(r, COL_NUM).Value))

        ' このTIFFのフレーム数を取得（マルチページ対応）
        Dim fc As Long: fc = 1  ' デフォルト: 1ページ
        If hasTiffFolder Then
            ' 先頭一致でTIFFを検索
            Dim tiffKeys() As Variant
            If tiffDict.Count > 0 Then
                tiffKeys = tiffDict.Keys
                Dim tk As Long
                Dim matchPath As String: matchPath = ""
                For tk = 0 To UBound(tiffKeys)
                    If Left(CStr(tiffKeys(tk)), Len(drawingNum)) = drawingNum Then
                        matchPath = tiffDict(tiffKeys(tk))
                        Exit For
                    End If
                Next tk
                If matchPath <> "" Then fc = GetTiffFrameCount(matchPath)
            End If
        End If

        ' マルチページTIFFは全ページに同一コメントを配置
        If cmt <> "" Then
            Dim fi As Long
            For fi = 0 To fc - 1
                pageComments.Add Array(pdfPageIdx + fi, cmt)
            Next fi
        End If

        pdfPageIdx = pdfPageIdx + fc  ' フレーム数分だけページ番号を進める
        totalPdfPages = totalPdfPages + fc
        r = r + 1
    Loop

    If pageComments.Count = 0 Then
        MsgBox "E列にコメントが1件もありません。" & vbCrLf & _
               "コメントを追加したいページの E列 にテキストを入力してください。", _
               vbExclamation, "コメントなし"
        Exit Sub
    End If

    '==========================================================================
    ' STEP 2: 「設定」シートからスタイル設定を読込
    '==========================================================================
    Dim fontSize   As Long:   fontSize = 10
    Dim pdfFont    As String: pdfFont = "Helv"
    Dim jsTextClr  As String: jsTextClr = "color.red"
    Dim jsFillClr  As String: jsFillClr = "color.white"
    Dim jsStrokeClr As String: jsStrokeClr = "[""T""]"  ' デフォルト=透明（枠なし）
    Dim borderW    As String: borderW = "0"
    Dim position   As String: position = "TL"

    Dim wsSetting As Worksheet
    On Error Resume Next
    Set wsSetting = ThisWorkbook.Sheets("設定")
    On Error GoTo 0

    If Not wsSetting Is Nothing Then
        Dim sv As String
        ' フォントサイズ
        If wsSetting.Range(SET_FONT_SIZE).Value <> "" Then fontSize = CLng(wsSetting.Range(SET_FONT_SIZE).Value)
        ' フォント名 → PDF標準名に変換
        If wsSetting.Range(SET_FONT_NAME).Value <> "" Then pdfFont = FontToPdfName(CStr(wsSetting.Range(SET_FONT_NAME).Value))
        ' 文字色
        If wsSetting.Range(SET_TEXT_COLOR).Value <> "" Then jsTextClr = ColorToJsExpr(CStr(wsSetting.Range(SET_TEXT_COLOR).Value))
        ' 背景色
        If wsSetting.Range(SET_BG_COLOR).Value <> "" Then
            sv = LCase(CStr(wsSetting.Range(SET_BG_COLOR).Value))
            If sv = "none" Then jsFillClr = "[""T""]" Else jsFillClr = ColorToJsExpr(sv)
        End If
        ' 枠線
        If wsSetting.Range(SET_BORDER).Value <> "" Then
            If CStr(wsSetting.Range(SET_BORDER).Value) = "あり" Then
                borderW = "0.5"
                If wsSetting.Range(SET_BORDER_CLR).Value <> "" Then
                    jsStrokeClr = ColorToJsExpr(CStr(wsSetting.Range(SET_BORDER_CLR).Value))
                Else
                    jsStrokeClr = "color.black"
                End If
            End If
        End If
        ' 配置位置 → JS用コードに変換
        If wsSetting.Range(SET_POSITION).Value <> "" Then
            Select Case CStr(wsSetting.Range(SET_POSITION).Value)
                Case "左上": position = "TL"
                Case "右上": position = "TR"
                Case "左下": position = "BL"
                Case "右下": position = "BR"
            End Select
        End If
    End If

    '==========================================================================
    ' STEP 3: JavaScript コード組み立て（Array + Join 方式で高速結合）
    '==========================================================================
    Dim jsLines() As String
    Dim jsIdx As Long: jsIdx = 0
    Dim LF As String: LF = Chr(10)

    Dim jsCapacity As Long: jsCapacity = 100 + pageComments.Count * 5
    ReDim jsLines(1 To jsCapacity)

    ' --- ヘッダ ---
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "// ======================================="
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "// コメント自動貼付JS（VBAマクロで自動生成）"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "// 対象: " & pageComments.Count & " ページ（総PDFページ: " & totalPdfPages & "）"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "// 生成: " & Format(Now, "yyyy/mm/dd hh:nn:ss")
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "// Acrobat / PDF-XChange 共通"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "// ======================================="
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "var doc = this;"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "(function() {"

    ' --- 設定値 ---
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "  var fontSize = " & fontSize & ";"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "  var fontName = """ & pdfFont & """;"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "  var textClr  = " & jsTextClr & ";"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "  var fillClr  = " & jsFillClr & ";"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "  var strokeClr = " & jsStrokeClr & ";"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "  var borderW  = " & borderW & ";"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "  var pos = """ & position & """;"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "  var margin = 6;"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = ""

    ' --- コメントデータ配列 ---
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "  var data = ["

    Dim i As Long
    For i = 1 To pageComments.Count
        Dim pg As Long:  pg = pageComments(i)(0)
        Dim tx As String: tx = CStr(pageComments(i)(1))

        ' JavaScript文字列内のエスケープ
        tx = Replace(tx, "\", "\\")
        tx = Replace(tx, """", "\""")
        tx = Replace(tx, vbCrLf, "\n")
        tx = Replace(tx, vbCr, "\n")
        tx = Replace(tx, vbLf, "\n")

        Dim comma As String: If i < pageComments.Count Then comma = "," Else comma = ""
        jsIdx = jsIdx + 1: jsLines(jsIdx) = "    {p:" & pg & ", t:""" & tx & """}" & comma
    Next i

    jsIdx = jsIdx + 1: jsLines(jsIdx) = "  ];"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = ""

    ' --- メイン処理ループ ---
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "  var count = 0;"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "  for (var i = 0; i < data.length; i++) {"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "    var d = data[i];"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "    if (d.p >= doc.numPages) continue;"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = ""

    ' ページサイズ取得
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "    // ページサイズ取得（Acrobat=getPageBox, PDF-XChange=A3横フォールバック）"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "    var pgW = 841.89, pgH = 595.28;"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "    try { var box = doc.getPageBox(""Media"", d.p); pgW = box[2]-box[0]; pgH = box[1]-box[3]; } catch(e) {}"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = ""

    ' テキスト幅概算
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "    var tw = 0;"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "    for (var j = 0; j < d.t.length; j++) {"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "      tw += (d.t.charCodeAt(j) > 255) ? fontSize : fontSize * 0.55;"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "    }"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "    tw += 8;"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "    var th = fontSize + 8;"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = ""

    ' 配置位置
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "    var x1, y1, x2, y2;"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "    if (pos===""TL"") { x1=margin;            y2=pgH-margin;      }"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "    else if (pos===""TR"") { x1=pgW-margin-tw;   y2=pgH-margin;      }"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "    else if (pos===""BL"") { x1=margin;            y2=margin+th;       }"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "    else              { x1=pgW-margin-tw;   y2=margin+th;       }"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "    x2 = x1 + tw;"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "    y1 = y2 - th;"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = ""

    ' addAnnot
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "    doc.addAnnot({"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "      type: ""FreeText"","
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "      page: d.p,"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "      rect: [x1, y1, x2, y2],"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "      contents: d.t,"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "      textFont: fontName,"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "      textSize: fontSize,"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "      textColor: textClr,"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "      fillColor: fillClr,"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "      strokeColor: strokeClr,"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "      width: borderW,"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "      alignment: 0,"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "      readOnly: false"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "    });"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "    count++;"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "  }"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = ""

    ' 完了通知
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "  app.alert(""完了: "" + count + "" 件のコメントを追加しました。"", 3);"
    jsIdx = jsIdx + 1: jsLines(jsIdx) = "})();"

    ' --- 配列を Join で一括結合 ---
    ReDim Preserve jsLines(1 To jsIdx)
    Dim js As String: js = Join(jsLines, LF)

    '==========================================================================
    ' STEP 4: クリップボードにコピー
    '==========================================================================
    Dim cb As Object
    Set cb = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    cb.SetText js
    cb.PutInClipboard
    Set cb = Nothing

    '==========================================================================
    ' STEP 5: 確認メッセージ
    '==========================================================================
    Dim posLabel As String: posLabel = ""
    If Not wsSetting Is Nothing Then posLabel = CStr(wsSetting.Range(SET_POSITION).Value)

    Dim msgBody As String
    msgBody = "JavaScript をクリップボードにコピーしました！" & vbCrLf & vbCrLf & _
              "【対象】 " & pageComments.Count & " / " & totalPdfPages & " ページ" & vbCrLf & _
              "【設定】 " & posLabel & " / " & CStr(fontSize) & "pt / " & pdfFont

    If hasTiffFolder Then
        msgBody = msgBody & vbCrLf & "【TIFF参照】 マルチページ展開済み（総PDFページ: " & totalPdfPages & "）"
    End If

    msgBody = msgBody & vbCrLf & vbCrLf & _
              "▼ 使い方" & vbCrLf & _
              "  1. PDFエディタで対象PDFを開く" & vbCrLf & _
              "  2. Ctrl+J でJSコンソールを開く" & vbCrLf & _
              "  3. Ctrl+V で貼り付け → 実行" & vbCrLf & _
              "  4. 保存" & vbCrLf & vbCrLf & _
              "※ 実行後、JSコンソールは閉じてOKです。" & vbCrLf & _
              "※ コードはPDFに残りません（保存されるのはコメントのみ）。"

    MsgBox msgBody, vbInformation, "JS生成完了"

End Sub
TIFtoPDFダウンロード

どんなツール？

設計図面やスキャン画像（TIFF）を、シート上のリスト順に並べて 1 つの PDF にまとめる VBA マクロです。

できること：

  • TIFF → PDF 一括結合（A3 横、余白ゼロ、リスト順）
  • コメント埋め込み（PDF 生成時にテキストボックスを重ねて出力）
  • JS コード生成（既存 PDF にあとからコメントを追加するスクリプトをワンクリック生成）
  • マルチページ TIFF 自動展開（複数ページの TIFF も全ページ取り込み）
  • 縦長画像の自動回転（A 列のフラグで回転方向を指定）

セットアップ（5 分で完了）

1. ファイル準備

.xlsm（マクロ有効ブック）を用意します。シートは 2 つ：

シート用途
メインシートTIFF リスト・設定パス・モード切替
設定コメントのフォント・色・配置などのスタイル設定

2. VBA モジュールの貼り付け

Alt + F11 で VBA エディタを開き、2 箇所 にコードを貼り付けます。

標準モジュール（Module1）： VBAマクロ_貼り付け用.txt の内容をそのまま貼り付け。

シートモジュール： メインシートのシートモジュール（VBA エディタ左ペインでシート名をダブルクリック）に以下を貼り付け：

vb

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("G9")) Is Nothing Then モード反映
End Sub

これで G9 セルのプルダウンを切り替えるだけでモードが自動反映されます。

3. メインシートのレイアウト

セル内容例
A 列反転フラグ（縦画像を回す方向）R＝右270°回転 / 空欄＝左90°回転
B 列ファイル番号（TIFF と先頭一致で照合）A4_001
E 列コメント（埋め込み or JS 生成に使用）PS-2024-001
G2TIFF 格納先フォルダパスZ:\SharedData\Drawings
G4出力 PDF ファイル名図面一覧.pdf
G6PDF 出力先フォルダパスC:\Users\...\Desktop
G9モード切替プルダウン下記参照

G9 のプルダウン選択肢（データの入力規則で設定）：

  • PDF作成時には埋め込まない → コメントなしで PDF 生成（ヘッダ青系）
  • PDF作成時に埋め込み → E 列のコメントをテキストボックスとして PDF に埋め込み（ヘッダ緑系）

使い方

PDF 生成（メイン機能）

  1. B 列に TIFF ファイル番号を入力（TIFF フォルダ内のファイル名と 先頭一致 で照合）
  2. G2・G4・G6 にパスとファイル名を設定
  3. G9 でモードを選択
  4. コメント埋め込みモードなら E 列にコメントを入力
  5. Alt + F8 → TiffToPdf → 実行

処理が始まると、ステータスバーに進捗が表示されます：

モード：PDF作成時に埋め込み　　12/60ページ目（バックグラウンドでWordにtif読込中...）

完了すると、処理件数・ページ数・処理時間がダイアログで表示されます。

あとからコメント追加（JS 生成）

既に PDF を作成済みで、あとからコメントを追加したい場合：

  1. E 列にコメントを入力
  2. Alt + F8 → JS生成_クリップボードコピー → 実行
  3. JavaScript がクリップボードにコピーされる
  4. PDF エディタ（Acrobat / PDF-XChange）で PDF を開く
  5. Ctrl + J で JS コンソールを開く
  6. Ctrl + V で貼り付けて実行
  7. 保存

JS コンソール実行後、コード自体は PDF に残りません（コメント注釈だけが保存されます）。

設定シートのカスタマイズ

「設定」シートでコメントの見た目を変更できます。PDF 生成・JS 生成の両方に反映されます。

セル項目設定例
B3フォントサイズ10
B4フォント名ゴシック, 明朝, 等幅, メイリオ など（「太字」付きも可）
B5文字色red, blue, green, black
B7背景色white, yellow / none で透明
B8枠線あり / なし
B9枠線色black, red など
B11配置位置左上, 右上, 左下, 右下

フォント名の対応表：

設定シートに書く名前PDF 埋め込み時のフォントJS 生成時のフォント
ゴシック / ArialArialHelv
ゴシック太字Arial BoldHeBo
明朝 / Times New RomanTimes New RomanTiRo
等幅 / Courier NewCourier NewCour
メイリオメイリオHelv

マルチページ TIFF の扱い

1 つの TIFF ファイルに複数ページが含まれている場合、全ページを自動展開 して PDF に取り込みます。

  • PDF 生成時：フレームごとに 1 ページとして出力。コメントは 全ページに同一テキスト を貼付。
  • JS 生成時：TIFF フォルダを参照してフレーム数を自動検出し、正しいページ番号でコメントを配置。
  • 完了メッセージ例：tifファイル 60 件 → 69 ページ（マルチページ TIFF 分だけページが増える）

PDF 品質の調整

コード先頭の定数 PDF_QUALITY で出力品質を切り替えられます：

値品質用途
0高品質（220dpi+）印刷・納品向け（デフォルト）
1軽量（150dpi）メール添付・画面確認向け

変更する場合は、VBA エディタで Private Const PDF_QUALITY As Long = 0 の値を書き換えてください。

エラー時の安全設計

  • PDF 上書き防止：同名 PDF が存在する場合、確認ダイアログを表示。ファイルが開かれていたらロック検出でブロック。
  • Word 孤児プロセス防止：エラー発生時も Word を確実に終了するクリーンアップ処理を搭載。
  • Excel 設定の復元保証：ScreenUpdating・EnableEvents・Calculation は処理後に必ず元の状態に戻ります。
  • 一時ファイルの自動削除：処理中に作成する一時 PNG ファイルはシステム Temp フォルダに保存され、処理後に削除されます。

パフォーマンス

60 枚の TIFF を処理した場合の目安：約 30 秒

高速化のポイント：

  • Excel の画面更新・イベント・再計算を処理中は一時停止
  • シートデータは配列で一括読込（セル個別アクセスの数十倍高速）
  • 一時ファイルをシステム Temp フォルダに保存（Explorer のサムネ再描画による I/O 競合を回避）
  • JS 文字列は Array + Join で O(n) 結合

クイックリファレンス

やりたいこと操作
コメントなし PDF を作るG9 →「PDF作成時には埋め込まない」→ Alt+F8 → TiffToPdf
コメント付き PDF を作るG9 →「PDF作成時に埋め込み」＋ E列入力 → Alt+F8 → TiffToPdf
既存 PDF にコメント追加E列入力 → Alt+F8 → JS生成_クリップボードコピー → PDFエディタの JSコンソールで実行
PDF 品質を変えるVBA エディタで PDF_QUALITY の値を変更（0=高品質 / 1=軽量）
コメントの見た目を変える「設定」シートの B3〜B11 を

コメント

タイトルとURLをコピーしました