'はがき用ものさし作成マクロ
'　このマクロは自由に改変、配布して構いません。

'Visual Basic Editor を起動、標準モジュールを挿入して
'以下のコードをコピー貼り付けして、マクロを実行してください。

Sub はがき用ものさし()
    Dim x As Long
    Dim y As Long
    Dim i As Long
    Dim l As Long
    Dim x0 As Double
    Dim y0 As Double
    Dim ws As Worksheet
    Dim x2 As Double
    Dim y2 As Double

    'ものさしの大きさ
    x = 95   '幅   95mm
    y = 135  '高さ 135mm

    'ものさしを印刷して大きさがずれるときは
    '以下の印刷結果の幅と高さを実際の長さに書き換えてください。
    Const xx As Double = 95 / 95   'ものさしの幅 / 印刷結果の幅
    Const yy As Double = 135 / 135 'ものさしの高さ / 印刷結果の高さ

    'ページ余白
    Const m As Long = 5  '余白5mm

    x = x - m
    y = y - m

    Worksheets.Add
    Set ws = ActiveSheet
    With ws.PageSetup
        .TopMargin = Application.CentimetersToPoints(m / 10)
        .BottomMargin = Application.CentimetersToPoints(m / 10)
        .LeftMargin = Application.CentimetersToPoints(m / 10)
        .RightMargin = Application.CentimetersToPoints(m / 10)
    End With
    On Error Resume Next
    ws.Name = "はがき"
    On Error GoTo 0
    ws.Copy
    ActiveSheet.Lines.Add 0, 0, 3 * x, 0
    For i = 1 To x
        If (i + m) Mod 10 = 0 Then l = 5 Else: If (i + m) Mod 5 = 0 Then l = 4 Else l = 3
        ActiveSheet.Lines.Add 3 * i, 0, 3 * i, 3 * l
    Next
    ActiveSheet.Lines.Add 0, 0, 0, 3 * y
    For i = 1 To y
        If (i + m) Mod 10 = 0 Then l = 5 Else: If (i + m) Mod 5 = 0 Then l = 4 Else l = 3
        ActiveSheet.Lines.Add 0, 3 * i, 3 * l, 3 * i
    Next
    ActiveSheet.Lines.Border.ColorIndex = 55

    x0 = 100 - 55.7 - ActiveSheet.PageSetup.LeftMargin / Application.CentimetersToPoints(0.1)
    y0 = 11.7 - ActiveSheet.PageSetup.TopMargin / Application.CentimetersToPoints(0.1)
    ActiveSheet.Rectangles.Add 3 * (x0 + 0), 3 * y0, 3 * 5.7, 3 * 8
    ActiveSheet.Rectangles.Add 3 * (x0 + 7), 3 * y0, 3 * 5.7, 3 * 8
    ActiveSheet.Rectangles.Add 3 * (x0 + 14), 3 * y0, 3 * 5.7, 3 * 8
    ActiveSheet.Rectangles.Add 3 * (x0 + 21.6), 3 * y0, 3 * 5.7, 3 * 8
    ActiveSheet.Rectangles.Add 3 * (x0 + 28.4), 3 * y0, 3 * 5.7, 3 * 8
    ActiveSheet.Rectangles.Add 3 * (x0 + 35.2), 3 * y0, 3 * 5.7, 3 * 8
    ActiveSheet.Rectangles.Add 3 * (x0 + 42), 3 * y0, 3 * 5.7, 3 * 8
    x0 = 5.5 - ActiveSheet.PageSetup.LeftMargin / Application.CentimetersToPoints(0.1)
    y0 = 122.5 - ActiveSheet.PageSetup.TopMargin / Application.CentimetersToPoints(0.1)
    ActiveSheet.Rectangles.Add 3 * (x0 + 0), 3 * y0, 3 * 4, 3 * 6.5
    ActiveSheet.Rectangles.Add 3 * (x0 + 4), 3 * y0, 3 * 4, 3 * 6.5
    ActiveSheet.Rectangles.Add 3 * (x0 + 8), 3 * y0, 3 * 4, 3 * 6.5
    ActiveSheet.Rectangles.Add 3 * (x0 + 13), 3 * y0, 3 * 4, 3 * 6.5
    ActiveSheet.Rectangles.Add 3 * (x0 + 17), 3 * y0, 3 * 4, 3 * 6.5
    ActiveSheet.Rectangles.Add 3 * (x0 + 21), 3 * y0, 3 * 4, 3 * 6.5
    ActiveSheet.Rectangles.Add 3 * (x0 + 25), 3 * y0, 3 * 4, 3 * 6.5
    ActiveSheet.Rectangles.Border.ColorIndex = 3
    ActiveSheet.Rectangles.Interior.ColorIndex = xlNone

    For i = Int((m - 1) / 10) * 10 + 20 To x + m - 1 Step 10
        With ActiveSheet.TextBoxes.Add(3 * (i - m) - 9, 3 * 5, 18, 12)
            .Text = Format(i \ 10, "!@@")
        End With
    Next
    For i = Int((m - 1) / 10) * 10 + 20 To y + m - 1 Step 10
        With ActiveSheet.TextBoxes.Add(3 * 5, 3 * (i - m) - 9, 12, 18)
            .Orientation = xlDownward
            .Text = Format(i \ 10, "!@@")
        End With
    Next
    With ActiveSheet.TextBoxes
        .Font.Size = 9
        .Font.ColorIndex = 55
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Border.ColorIndex = xlNone
        .Interior.ColorIndex = xlNone
    End With

    With ActiveSheet.DrawingObjects.Group
        .Placement = xlFreeFloating
        .Width = Application.CentimetersToPoints(x / 10)
        .Height = Application.CentimetersToPoints(y / 10)
        .CopyPicture xlScreen, xlPicture
        ActiveSheet.Paste
        x2 = (Selection.Width - .Width) / 3
        y2 = (Selection.Height - .Height) / 3
        Selection.Delete
        .CopyPicture xlPrinter, xlPicture
        ActiveSheet.Paste
        .Width = .Width * .Width / (Selection.Width - x2 * 2) * xx
        .Height = .Height * .Height / (Selection.Height - y2 * 2) * yy
        Selection.Delete
        If Val(Application.Version) < 9 Then Exit Sub
        .Copy
        ActiveSheet.PasteSpecial Format:="図 (PNG)"
        x2 = (Selection.Width - .Width) / 3
        y2 = (Selection.Height - .Height) / 3
        Selection.ShapeRange.PictureFormat.CropLeft = x2
        Selection.ShapeRange.PictureFormat.CropTop = y2
        Selection.ShapeRange.PictureFormat.CropRight = x2
        Selection.ShapeRange.PictureFormat.CropBottom = y2
        Selection.Copy
        ws.Activate
        ws.PasteSpecial Format:="図 (PNG)"
        Selection.Placement = xlFreeFloating
        .Parent.Parent.Close False
    End With
End Sub

Sub はがき用ものさし横()
    Dim x As Long
    Dim y As Long
    Dim i As Long
    Dim l As Long
    Dim x0 As Double
    Dim y0 As Double
    Dim ws As Worksheet
    Dim x2 As Double
    Dim y2 As Double

    'ものさしの大きさ
    x = 135  '幅  135mm
    y = 95   '高さ 95mm

    'ものさしを印刷して大きさがずれるときは
    '以下の印刷結果の幅と高さを実際の長さに書き換えてください。
    Const xx As Double = 135 / 135 'ものさしの幅 / 印刷結果の幅
    Const yy As Double = 95 / 95   'ものさしの高さ / 印刷結果の高さ

    'ページ余白
    Const m As Long = 5  '余白5mm

    x = x - m
    y = y - m

    Worksheets.Add
    Set ws = ActiveSheet
    With ws.PageSetup
        .TopMargin = Application.CentimetersToPoints(m / 10)
        .BottomMargin = Application.CentimetersToPoints(m / 10)
        .LeftMargin = Application.CentimetersToPoints(m / 10)
        .RightMargin = Application.CentimetersToPoints(m / 10)
    End With
    On Error Resume Next
    ws.Name = "はがき横"
    On Error GoTo 0
    ws.Copy
    ActiveSheet.Lines.Add 0, 0, 3 * x, 0
    For i = 1 To x
        If (i + m) Mod 10 = 0 Then l = 5 Else: If (i + m) Mod 5 = 0 Then l = 4 Else l = 3
        ActiveSheet.Lines.Add 3 * i, 0, 3 * i, 3 * l
    Next
    ActiveSheet.Lines.Add 0, 0, 0, 3 * y
    For i = 1 To y
        If (i + m) Mod 10 = 0 Then l = 5 Else: If (i + m) Mod 5 = 0 Then l = 4 Else l = 3
        ActiveSheet.Lines.Add 0, 3 * i, 3 * l, 3 * i
    Next
    ActiveSheet.Lines.Border.ColorIndex = 55

    x0 = 11.7 - ActiveSheet.PageSetup.LeftMargin / Application.CentimetersToPoints(0.1)
    y0 = 55.7 - 5.7 - ActiveSheet.PageSetup.TopMargin / Application.CentimetersToPoints(0.1)
    ActiveSheet.Rectangles.Add 3 * x0, 3 * (y0 - 0), 3 * 8, 3 * 5.7
    ActiveSheet.Rectangles.Add 3 * x0, 3 * (y0 - 7), 3 * 8, 3 * 5.7
    ActiveSheet.Rectangles.Add 3 * x0, 3 * (y0 - 14), 3 * 8, 3 * 5.7
    ActiveSheet.Rectangles.Add 3 * x0, 3 * (y0 - 21.6), 3 * 8, 3 * 5.7
    ActiveSheet.Rectangles.Add 3 * x0, 3 * (y0 - 28.4), 3 * 8, 3 * 5.7
    ActiveSheet.Rectangles.Add 3 * x0, 3 * (y0 - 35.2), 3 * 8, 3 * 5.7
    ActiveSheet.Rectangles.Add 3 * x0, 3 * (y0 - 42), 3 * 8, 3 * 5.7
    
    x0 = 122.5 - ActiveSheet.PageSetup.LeftMargin / Application.CentimetersToPoints(0.1)
    y0 = 100 - 4 - 5.7 - ActiveSheet.PageSetup.TopMargin / Application.CentimetersToPoints(0.1)
    ActiveSheet.Rectangles.Add 3 * x0, 3 * (y0 - 0), 3 * 6.5, 3 * 4
    ActiveSheet.Rectangles.Add 3 * x0, 3 * (y0 - 4), 3 * 6.5, 3 * 4
    ActiveSheet.Rectangles.Add 3 * x0, 3 * (y0 - 8), 3 * 6.5, 3 * 4
    ActiveSheet.Rectangles.Add 3 * x0, 3 * (y0 - 13), 3 * 6.5, 3 * 4
    ActiveSheet.Rectangles.Add 3 * x0, 3 * (y0 - 17), 3 * 6.5, 3 * 4
    ActiveSheet.Rectangles.Add 3 * x0, 3 * (y0 - 21), 3 * 6.5, 3 * 4
    ActiveSheet.Rectangles.Add 3 * x0, 3 * (y0 - 25), 3 * 6.5, 3 * 4
    ActiveSheet.Rectangles.Border.ColorIndex = 3
    ActiveSheet.Rectangles.Interior.ColorIndex = xlNone

    For i = Int((m - 1) / 10) * 10 + 20 To x + m - 1 Step 10
        With ActiveSheet.TextBoxes.Add(3 * (i - m) - 9, 3 * 5, 18, 12)
            .Text = Format(i \ 10, "!@@")
        End With
    Next
    For i = Int((m - 1) / 10) * 10 + 20 To y + m - 1 Step 10
        With ActiveSheet.TextBoxes.Add(3 * 5, 3 * (i - m) - 9, 12, 18)
            .Orientation = xlDownward
            .Text = Format(i \ 10, "!@@")
        End With
    Next
    With ActiveSheet.TextBoxes
        .Font.Size = 9
        .Font.ColorIndex = 55
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Border.ColorIndex = xlNone
        .Interior.ColorIndex = xlNone
    End With

    With ActiveSheet.DrawingObjects.Group
        .Placement = xlFreeFloating
        .Width = Application.CentimetersToPoints(x / 10)
        .Height = Application.CentimetersToPoints(y / 10)
        .CopyPicture xlScreen, xlPicture
        ActiveSheet.Paste
        x2 = (Selection.Width - .Width) / 3
        y2 = (Selection.Height - .Height) / 3
        Selection.Delete
        .CopyPicture xlPrinter, xlPicture
        ActiveSheet.Paste
        .Width = .Width * .Width / (Selection.Width - x2 * 2) * xx
        .Height = .Height * .Height / (Selection.Height - y2 * 2) * yy
        Selection.Delete
        If Val(Application.Version) < 9 Then Exit Sub
        .Copy
        ActiveSheet.PasteSpecial Format:="図 (PNG)"
        x2 = (Selection.Width - .Width) / 3
        y2 = (Selection.Height - .Height) / 3
        Selection.ShapeRange.PictureFormat.CropLeft = x2
        Selection.ShapeRange.PictureFormat.CropTop = y2
        Selection.ShapeRange.PictureFormat.CropRight = x2
        Selection.ShapeRange.PictureFormat.CropBottom = y2
        Selection.Copy
        ws.Activate
        ws.PasteSpecial Format:="図 (PNG)"
        Selection.Placement = xlFreeFloating
        .Parent.Parent.Close False
    End With

End Sub