エクセル 穴あけパンチ用の中心線を自動出力（VBA）

事務用品の穴あけパンチで、プリントに穴を空けるときの目印の線をセル上に出力するVBA。
難易度 ★★★☆☆
実用度 ★☆☆☆☆

結構複雑な計算をしている割に、実用性はほとんどなし。

なんだかんだで、コード内にはVBAコーディングのいろんな技術がチャンポンされているので、
VBAコードに興味がある人だけ読んでいただければ

尚、印刷機の設定などによって出力位置が正確には出力されなかったりするのであしからず。

##実行例

実行前

↓
実行後

印刷プレビュー画面

横向きに印刷するときにも有効

##コード
そのまま(多分)使えるコード

プロシージャの構成は以下の通り

穴あけ中心線出力
┗最初のページの印刷範囲取得
┗縦横フィット倍率計算

詳しい解説は、コード後

'''VBA:穴あけ

Sub 穴あけ中心線出力()

    Dim TargetSheet
    Set TargetSheet = ActiveSheet
    
    '①：既に出力済みの穴あけ中心線を削除
    On Error Resume Next 'まだ穴あけ中心線を作成していない場合はエラーとなるので、エラーで止まらないように設定
    TargetSheet.Shapes("穴あけ中心線").Delete
    On Error GoTo 0
    
    '②：印刷範囲の取得
    Dim Dummy
    Dim StartTop, StartLeft, EndTop, EndLeft
    Dim InsatuTakasa, InsatuHaba
    
    Dummy = 最初のページの印刷範囲取得(TargetSheet)
    
    StartTop = Dummy(1)
    StartLeft = Dummy(2)
    EndTop = Dummy(3)
    EndLeft = Dummy(4)
    InsatuTakasa = EndTop - StartTop
    InsatuHaba = EndLeft - StartLeft
    
    '③：1mmあたりのピクセル数設定（縦横で違う）（実測値）(印刷機によって違うかも)
    Dim mmtopx_Tate, mmtopx_Yoko
    mmtopx_Tate = 2.8228 '←←←←←←←←←←←←←←←←←←←←←←←
    mmtopx_Yoko = 2.7346 '←←←←←←←←←←←←←←←←←←←←←←←
    
    '④：出力する中央線の長さ(mm)
    Dim CenterLineNagasa_mm
    CenterLineNagasa_mm = 10 '←←←←←←←←←←←←←←←←←←←←←←←
    
    '⑤：他、各種印刷設定の取得
    Dim InsatuTateNaraTrue, Bairitu, InsatuSize, YokoCenterNaraTrue, TateCenterNaraTrue
    Dim MarginLeft, MarginRight, MarginTop, MarginBottom '余白
    Dim InsatuHanniTate, InsatuHanniYoko
    Dim OutputHoukou
    Dim TateNiFitNaraTrue
    With TargetSheet.PageSetup
        
        '⑤-1：印刷方向の取得
        If .Orientation = xlPortrait Then
            InsatuTateNaraTrue = True '印刷が縦
        Else
            InsatuTateNaraTrue = False '印刷が横
        End If
        
        
        '⑤-2：印刷用紙の取得
        InsatuSize = .PaperSize 'A4:xlPaperA4 A3:xlPaperA3
        
        '⑤-3：穴あけ中心線を出力する方向を設定
        If InsatuSize = xlPaperA4 Or InsatuSize = xlPaperA3 Then
            'A4でもA3でもない場合は中心線はメンドクサイので表示しない('ω')ノ
            If InsatuSize = xlPaperA4 And InsatuTateNaraTrue Then 'A4サイズで縦向→縦位置に出力
                OutputHoukou = "縦"
            ElseIf InsatuSize = xlPaperA4 And InsatuTateNaraTrue = False Then 'A4サイズで横向→横位置に出力
                OutputHoukou = "横"
            ElseIf InsatuSize = xlPaperA3 And InsatuTateNaraTrue Then 'A3サイズで縦向→横位置に出力
                OutputHoukou = "横"
            ElseIf InsatuSize = xlPaperA3 And InsatuTateNaraTrue = False Then 'A3サイズで横向→縦位置に出力
                OutputHoukou = "縦"
            Else
                Exit Sub
            End If
        End If
        
        '⑤-4：中央ぞろいかどうか
        '横方向に印刷が中央ぞろいかどうか(True：中央ぞろい)
        YokoCenterNaraTrue = .CenterHorizontally
        
        '縦方向に印刷が中央ぞろいかどうか(True：中央ぞろい)
        TateCenterNaraTrue = .CenterVertically
        
        '⑤-5：余白の取得(ポイント→インチ→mmに変換)
        MarginLeft = .LeftMargin / 72 * 25.4
        MarginRight = .RightMargin / 72 * 25.4
        MarginTop = .TopMargin / 72 * 25.4
        MarginBottom = .BottomMargin / 72 * 25.4
        
        '⑤-6：プリントに印刷される範囲（余白を除いた部分の範囲）を取得（以降：印刷先範囲）
        If InsatuSize = xlPaperA4 And InsatuTateNaraTrue Then
            InsatuHanniTate = 297 - MarginTop - MarginBottom
            InsatuHanniYoko = 210 - MarginLeft - MarginBottom
        ElseIf InsatuSize = xlPaperA4 And InsatuTateNaraTrue = False Then
            InsatuHanniTate = 210 - MarginTop - MarginBottom
            InsatuHanniYoko = 297 - MarginLeft - MarginBottom
        ElseIf InsatuSize = xlPaperA3 And InsatuTateNaraTrue Then
            InsatuHanniTate = 420 - MarginTop - MarginBottom
            InsatuHanniYoko = 297 - MarginLeft - MarginBottom
        ElseIf InsatuSize = xlPaperA3 And InsatuTateNaraTrue = False Then
            InsatuHanniTate = 297 - MarginTop - MarginBottom
            InsatuHanniYoko = 420 - MarginLeft - MarginBottom
        End If
        
        '⑤-7：シートを1ページに印刷する設定の場合。
        If .FitToPagesWide = 1 And .FitToPagesTall = 1 Then
            '印刷範囲の縦横比と、余白を除いた印刷先範囲の縦横比を比較して、縦横どちらにフィットするか計算
            If InsatuHanniTate / InsatuHanniYoko > InsatuTakasa / InsatuHaba Then
                '印刷先範囲のほうが縦長・・・横にフィット
                TateNiFitNaraTrue = False
            Else
                '印刷先範囲のほうが横長・・・縦にフィット
                TateNiFitNaraTrue = True
            End If
        End If

        '⑤-8：拡大率の設定
        If .Zoom = False Then '拡大率が指定されていない
            'すべて列または行を1ページに印刷する設定の場合は、ページにフィットする拡大率を計算する必要がある。
            If OutputHoukou = "縦" Then
                If TateCenterNaraTrue = False Then
                '縦に中心線を入れる場合で、縦方向に印刷が中央ぞろいでない場合
                    If TateNiFitNaraTrue = "" Then
                        Bairitu = 縦横フィット倍率計算(True)
                    Else
                        Bairitu = 縦横フィット倍率計算(TateNiFitNaraTrue)
                    End If
                Else
                    Bairitu = "" '倍率を空白にしておく
                End If
            ElseIf OutputHoukou = "横" Then
                If YokoCenterNaraTrue = False Then
                '横に中心線を入れる場合で、横方向に印刷が中央ぞろいでない場合
                    If TateNiFitNaraTrue = "" Then
                        Bairitu = 縦横フィット倍率計算(False)
                    Else
                        Bairitu = 縦横フィット倍率計算(TateNiFitNaraTrue)
                    End If
                Else
                    Bairitu = "" '倍率を空白にしておく
                End If
            End If
            
        Else
            Bairitu = .Zoom
        End If
        
    End With
    
    '⑥：中心線を出力する位置（ピクセル位置）を計算
    Dim OutputPx
    If Bairitu = "" Then
        '印刷が中央ぞろい
        If OutputHoukou = "縦" Then
            OutputPx = Int((EndTop - StartTop) / 2)
        Else
            OutputPx = Int((EndLeft - StartLeft) / 2)
        End If
    Else
        '印刷が中央ぞろいでない
        If OutputHoukou = "縦" Then
            OutputPx = InsatuHanniTate * mmtopx_Tate / 2 * 100 / Bairitu
            If OutputPx > EndTop Then
                '印刷範囲外に穴あけ中心線が来るので、出力はしない。
                Exit Sub
            End If
        Else
            OutputPx = InsatuHanniYoko * mmtopx_Yoko / 2 * 100 / Bairitu
            If OutputPx > EndLeft Then
                '印刷範囲外に穴あけ中心線が来るので、出力はしない。
                Exit Sub
            End If
        End If
    End If
    
    '⑦：中心線の始端、終端の座標を計算
    Dim LineStartTate, LineStartYoko, LineEndTate, LineEndYoko
    If OutputHoukou = "縦" Then
        LineStartTate = OutputPx
        LineStartYoko = 0
        LineEndTate = OutputPx
        LineEndYoko = CenterLineNagasa_mm * 72 / 25.4
    Else
        LineStartTate = 0
        LineStartYoko = OutputPx
        LineEndTate = CenterLineNagasa_mm * 72 / 25.4
        LineEndYoko = OutputPx
    End If
    
    '⑧：穴あけ中心線の出力
    TargetSheet.Shapes.AddConnector(msoConnectorStraight, LineStartYoko, LineStartTate, LineEndYoko, LineEndTate).Select
    Selection.Name = "穴あけ中心線"
    Selection.ShapeRange.Line.BeginArrowheadStyle = msoArrowheadOpen
    
End Sub
Function 最初のページの印刷範囲取得(TargetSheet)
    '②印刷範囲の取得
    Dim strPrintArea, StartCell, EndCell
    strPrintArea = TargetSheet.PageSetup.PrintArea '印刷範囲の取得
    
    '②-1：印刷範囲が設定されているかどうかで、計算するかどうか判定（エラー回避）
    If strPrintArea = "" Then
        MsgBox ("印刷範囲が指定されていません。")
        End
    End If

    '②-2：印刷範囲における最初のセル（左上）と最後のセル（右下）を取得
    Dummy = Split(strPrintArea, ":")
    Set StartCell = TargetSheet.Range(Dummy(0))
    Set EndCell = TargetSheet.Range(Dummy(1))

    '②-3：ページの区切り線があるかどうかから、1ページ目だけの印刷範囲を取得する。
    Dim HBreakCell, VBreakCell
    If TargetSheet.HPageBreaks.Count > 0 Then '横方向のページの区切りがある
        Set HBreakCell = TargetSheet.HPageBreaks(1).Location '1番目の印刷横区切り位置のセル
        Set EndCell = TargetSheet.Cells(HBreakCell.Row - 1, EndCell.Column) '最後のセル（右下）を修正
    End If
    
    If TargetSheet.VPageBreaks.Count > 0 Then '縦方向のページの区切りがある
        Set VBreakCell = TargetSheet.VPageBreaks(1).Location '1番目の印刷縦区切り位置のセル
        Set EndCell = TargetSheet.Cells(EndCell.Row, VBreakCell.Column - 1) '最後のセル（右下）を修正
    End If
    
    '②-4：印刷範囲の左上座標、右下座標を取得
    Dim StartTop, StartLeft, EndTop, EndLeft
    StartTop = StartCell.Top
    StartLeft = StartCell.Left
    EndTop = EndCell.Offset(1, 1).Top
    EndLeft = EndCell.Offset(1, 1).Left
    
    Dim Output
    ReDim Output(1 To 4)
    Output(1) = StartTop
    Output(2) = StartLeft
    Output(3) = EndTop
    Output(4) = EndLeft
    
    '②-5：出力
    最初のページの印刷範囲取得 = Output
    
End Function
Function 縦横フィット倍率計算(Optional TateNaraTrue = True)
    '⑤-8：拡大率の取得
    
    Dim strPrintArea
    Dim TargetSheet
    Set TargetSheet = ActiveSheet
    

    '印刷設定を取得しておく（後で戻すため）
    Dim PageWide, PageTall
    With TargetSheet.PageSetup
        PageWide = .FitToPagesWide
        PageTall = .FitToPagesTall
    End With
    
    Dim Bairitu
    Dim FitBairitu
    Dim PageCount
    Application.PrintCommunication = False
    
    Dim Bairitu1, Bairitu2, Bairitu3
    Dim PageCount1, PageCount2, PageCount3
    
    Bairitu1 = 10
    Bairitu2 = 50
    Bairitu3 = 100
    PageCount1 = 0
    PageCount3 = 1
    
    With TargetSheet.PageSetup
        strPrintArea = .PrintArea
        
        'もし100%倍率（フィット時の最大設定倍率）でページ数が1なら結果を100%倍率で出力
        .Zoom = Bairitu3
        Application.PrintCommunication = True
        
        If TateNaraTrue Then
            PageCount2 = .Parent.HPageBreaks.Count
        Else
            PageCount2 = .Parent.VPageBreaks.Count
        End If
        
        Application.PrintCommunication = False
        
        If PageCount2 = 0 Then
            FitBairitu = Bairitu3
        End If
        
        
        Do While FitBairitu = "" '二進法でフィット倍率を探索する（計算高速化）
            
            .Zoom = Bairitu2
            Application.PrintCommunication = True
            
            If TateNaraTrue Then
                PageCount2 = .Parent.HPageBreaks.Count
            Else
                PageCount2 = .Parent.VPageBreaks.Count
            End If
            
            Application.PrintCommunication = False
            
            If Bairitu2 - Bairitu1 = 1 Then
                If PageCount2 > 0 Then
                    FitBairitu = Bairitu1
                Else
                    FitBairitu = Bairitu2
                End If
                
                Exit Do
            End If
            
            If PageCount2 > 0 Then
                'Bairitu1,Bairitu2の間
                Bairitu3 = Bairitu2
                Bairitu2 = Int((Bairitu1 + Bairitu2) / 2)
            Else
                'Bairitu2,Bairitu3の間
                Bairitu1 = Bairitu2
                Bairitu2 = Int((Bairitu2 + Bairitu3) / 2)
            End If
            
        Loop
        
    End With
    
    '印刷設定を戻す
    Application.PrintCommunication = False
    
    With TargetSheet.PageSetup
        .Zoom = False
        .FitToPagesWide = PageWide
        .FitToPagesTall = PageTall
    End With
    Application.PrintCommunication = True
    
    縦横フィット倍率計算 = FitBairitu
    
End Function

'''

##コード解説
まず穴あけ中心線を出力するときのパターンを解説

A4サイズのフラットファイルにプリントを綴じるのを想定して、
対象とするプリントサイズはA4,A3のみとする。

モノタロウ

エクセルの印刷設定で縦方向と横方向があるので、

A4サイズ
┗縦方向・・・縦位置に出力
┗横方向・・・横位置に出力
A3サイズ
┗縦方向・・・横位置に出力
┗横方向・・・縦位置に出力

イメージ

構成の詳細

Sub 穴あけ中心線出力

①：既に出力済みの穴あけ中心線を削除
②：印刷範囲の取得

Function 最初のページの印刷範囲取得

②-1：印刷範囲が設定されているかどうかで、計算するかどうか判定（エラー回避）
②-2：印刷範囲における最初のセル（左上）と最後のセル（右下）を取得
②-3：ページの区切り線があるかどうかから、1ページ目だけの印刷範囲を取得する。
②-4：印刷範囲の左上座標、右下座標を取得
②-5：出力

③：1mmあたりのピクセル数設定
④：出力する中央線の長さ(mm)
⑤：他、各種印刷設定の取得

⑤-1：印刷方向の取得
⑤-2：印刷用紙の取得
⑤-3：穴あけ中心線を出力する方向を設定
⑤-4：中央ぞろいかどうか
⑤-5：余白の取得(ポイント→インチ→mmに変換)
⑤-6：プリントに印刷される範囲（余白を除いた部分の範囲）を取得
⑤-7：シートを1ページに印刷する設定の場合。
⑤-8：拡大率の設定

Function 縦横フィット倍率計算

⑥：中心線を出力する位置（ピクセル位置）を計算
⑦：中心線の始端、終端の座標を計算
⑧：穴あけ中心線の出力

##解説執筆中