Gleichmäßiger Linienverlauf, vielleicht hat einer eine Idee

[koter]

Hallo Thorsten,

mit jeder beliebigen Fläche wird das nicht gehen. Die Breite muß ein Vielfaches von 5mm sein und die Höhe von 2,5mm.

Wenn Du ein Rechteck zeichnest, es auswählst und dann folgendes Makro auführst, werden Breite und Höhe angepasst und das Raster gezeichnet.

Code:

Sub RR4bis1()
    Dim x As Double, y As Double, w As Double, h As Double
    Dim s0 As Shape
    Dim s1 As Shape
    If ActiveShape Is Nothing Then Exit Sub
    ActiveDocument.Unit = cdrMillimeter
    ActiveDocument.BeginCommandGroup "Raster Zeichnen"
    ActiveShape.GetBoundingBox x, y, w, h
    h = Round((h / 2.5), 0) * 2.5
    w = Round((w / 5), 0) * 5
    ActiveShape.SetBoundingBox x, y, w, h
    n = h / 2.5 - 2
    a = (4 - 1) / (n + 1)
    Set s0 = ActiveLayer.CreateLineSegment(x, y + h, x + w, y + h)
    b = 4
    Set s1 = ActiveLayer.CreateLineSegment(x, y + h - b, x + w, y + h - b)
    s0.AddToSelection
    s1.AddToSelection
    ActiveDocument.Selection.Group
    s1.OrderFrontOf s0
    c = b
    For i = 1 To n
        b = b - a
        c = c + b
        Set s1 = ActiveLayer.CreateLineSegment(x, y + h - c, x + w, y + h - c)
        s1.OrderFrontOf s0
    Next i
    Set s1 = ActiveLayer.CreateLineSegment(x, y, x + w, y)
    s1.OrderFrontOf s0
    For i = 0 To w Step 5
        Set s1 = ActiveLayer.CreateLineSegment(x + i, y + h, x + i, y)
        s1.OrderFrontOf s0
    Next i
    ActiveDocument.EndCommandGroup
End Sub

Gruß

koter