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

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

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

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

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

![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/902314/33aa38a4-1d8e-5bd4-bbfb-a836735dc850.png)

##実行例

実行前
<img src="https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/902314/9b411e17-8b69-2a2c-0c0e-33724cbbd459.png" width="300">
↓
実行後
<img src="https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/902314/dd36ff70-d6ca-a112-fdac-55f15d6cc086.png" width="300">

印刷プレビュー画面
<img src="https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/902314/8f5a177f-ea4b-2109-a928-39c5132caa44.png" width="300">

横向きに印刷するときにも有効
<img src="https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/902314/0d9932a8-ed78-f4e2-d1ad-40c7873f7354.png" width="500">

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

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

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

詳しい解説は、コード後

'''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のみとする。
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/902314/64e2b763-615a-3826-9520-fd23fecabdb1.png)
[モノタロウ](https://www.monotaro.com/p/2657/0294/?utm_medium=cpc&utm_source=Adwords&utm_campaign=246-833-4061_6466659573&utm_content=96539050923&utm_term=_419857551521__aud-905373680070:pla-879055534935&gclid=CjwKCAiA_9r_BRBZEiwAHZ_v163air_RkBIPHZyNs-Cs7zIhgfH5NvNp9cvHeuxXRRwj8G8VBeUsgBoCAocQAvD_BwE)

エクセルの印刷設定で縦方向と横方向があるので、
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/902314/761d23d6-f897-8476-3ab1-5d2a81f096c5.png)

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

イメージ
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/902314/b6fdd464-bef9-7447-6adc-bfee57848852.png)

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

>>③：1mmあたりのピクセル数設定
>>④：出力する中央線の長さ(mm)
>>⑤：他、各種印刷設定の取得
>>>⑤-1：印刷方向の取得
>>>⑤-2：印刷用紙の取得
>>>⑤-3：穴あけ中心線を出力する方向を設定
>>>⑤-4：中央ぞろいかどうか
>>>⑤-5：余白の取得(ポイント→インチ→mmに変換)
>>>⑤-6：プリントに印刷される範囲（余白を除いた部分の範囲）を取得
>>>⑤-7：シートを1ページに印刷する設定の場合。
>>>⑤-8：拡大率の設定
>>>>Function 縦横フィット倍率計算

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

##解説執筆中