엑셀 드릴 펀치용 중심선을 자동 출력(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: 시트를 한 페이지에 인쇄하는 설정의 경우.
⑤-8 : 확대율 설정

Function 종횡 피트 배율 계산

⑥: 중심선을 출력하는 위치(픽셀 위치)를 계산
⑦ : 중심선의 시작, 끝의 좌표 계산
⑧: 드릴 중심선 출력

해설 쓰기 중