Sub BrushGeks(X As Double, Y As Double, Size As Double, St As Double)
    '
    ' Recorded 02.10.2007
    '
    ' Description:
    '
    '
    Dim OrigSelection As ShapeRange
    Set OrigSelection = ActiveSelectionRange
    Dim s1 As Shape
    Set s1 = ActiveLayer.CreateLineSegment(0, 0, 0, 0)
    s1.Fill.ApplyNoFill
    s1.Outline.SetProperties 0.003, OutlineStyles(0), CreateCMYKColor(0, 0, 0, 100), ArrowHeads(0), ArrowHeads(0), False, False, cdrOutlineButtLineCaps, cdrOutlineMiterLineJoin, 0#, 100, , , 5#
    Dim crv As Curve
    Set crv = ActiveDocument.CreateCurve()
    With crv.CreateSubPath(X, Y)
        .AppendLineSegment X + Size * Sqr(3) / 2, Y + Size / 2
        .AppendLineSegment X + Size * Sqr(3) / 2, Y + Size / 2 + Size
        .AppendLineSegment X, Y + 2 * Size
        .AppendLineSegment X - Size * Sqr(3) / 2, Y + Size / 2 + Size
        .AppendLineSegment X - Size * Sqr(3) / 2, Y + Size / 2
        .AppendLineSegment X, Y
        .Closed = True
    End With
    s1.Curve.CopyAssign crv
    s1.Outline.SetProperties St
End Sub

Sub BrushSetka(X0 As Double, Y0 As Double, R As Double, A As Double, SS As Double)
    Dim d As Document
    Dim sh As Shape
    Dim t As Text
    Dim Nx, Ny As Double
    
    ' количество ячеек
    Nx = Int(R / A / Sqr(3))
    Ny = Int(R / A / 3)
    
    ' вывод подписи
    Set d = ActiveDocument
    Set sh = d.ActiveLayer.CreateParagraphText(X0, Y0 + 0.05, X0 + R, Y0 + 0.1, "l=" + Trim(Str(Nx)) + " h=" + Trim(Str(Ny * 2)) + " a=" + Trim(Str(A)) + " s=" + Trim(Str(SS)))
    Set t = sh.Text
    t.FitTextToFrame
    
    ' строим нечетные ряды
    For j = 1 To Ny
        For i = 1 To Nx
            Call BrushGeks(X0 + i * Sqr(3) * A, Y0 - j * 3 * A, A, (SS))
        Next i
    Next j
    
    ' строим четные ряды
    X0 = X0 + A * Sqr(3) / 2
    Y0 = Y0 - 1.5 * A
    For j = 1 To Ny
        For i = 1 To Nx
            Call BrushGeks(X0 + i * Sqr(3) * A, Y0 - j * 3 * A, A, (SS))
        Next i
    Next j

End Sub

Sub Macro2()
    Dim X0, Y0 As Double
    Dim SS, R, A As Double
    
    '
    ' все данные в дюймах
    '
    ' размер стороны ячейки шестигранника
    A = 0.002
    ' толщина линии
    SS = 0.001
    ' размер пластины
    R = 1.6
    ' координаты начальной точки для построения
    X0 = 0
    Y0 = 0
    
    'Call BrushSetka((X0), (Y0), (R), (A), (SS))
    BrushSetka X0:=0.5, Y0:=10.5, R:=1.6, A:=0.002, SS:=0.0006

End Sub