'---------------------------------------------------------
' Autor..........: Ralf Kunsmann - http://www.kunsmann.de
' Datum..........: 2007 09 12
' Kontext........: Microsoft Excel VBA
' Zweck..........: Technische Zeichnung erstellen.
'---------------------------------------------------------
Option Explicit

Private Const MM_TO_POINT As Double = 2.835
Private Const START_ROW As Long = 6

Public Sub DrawObject()

' Referenz auf aktuelles Arbeitsblatt besorgen
' (dieses Blatt sollte die Zeichenelemente beinhalten!)
    Dim wsSource As Worksheet
    Set wsSource = ActiveSheet

' Neues Arbeitsblatt erzeugen
' (Auf dieses Blatt wird gezeichnet)
    Dim wsTarget As Worksheet
    Set wsTarget = Sheets.Add
    wsTarget.Select
    ActiveWindow.DisplayGridlines = False

' Skalierungsfaktor unter Berücksichtigung von Maßstab und Excel-Skala
    Dim rScale As Double
    rScale = MM_TO_POINT / wsSource.Cells(1, 2)

' Horizontaler Offset
    Dim rVOffset As Double
    rVOffset = wsSource.Cells(2, 2)

' Linker Rand
    Dim rLeftBorder As Double
    rLeftBorder = wsSource.Cells(3, 2)

' Anzahl der Zeilen mit Definitionen für Zeichnungselemente
    Dim iRows As Long
    iRows = wsSource.Cells.SpecialCells(xlCellTypeLastCell).Row

' Referenz auf Liste der Shapes-Elemente in Zielblatt
' (ist anfangs leer)
    Dim sps As Shapes
    Set sps = wsTarget.Shapes

    Dim cRow As Long
    Dim rLeft As Double
    Dim rBottom As Double
    Dim rRight As Double
    Dim rTop As Double

' Jetzt das eigentliche Zeichnen (unglaublich einfach!)
    For cRow = START_ROW To iRows
    ' Hilfsvariablen mit Positionsangaben füllen
        rLeft = wsSource.Cells(cRow, 3) + rLeftBorder
        rBottom = rVOffset - wsSource.Cells(cRow, 4)
        rRight = rLeft + wsSource.Cells(cRow, 5)
        rTop = rBottom - wsSource.Cells(cRow, 6)
    ' Ein neues Shape-Objekt von Typ Line erstellen
        sps.AddLine rLeft * rScale, _
                    rBottom * rScale, _
                    rRight * rScale, _
                    rTop * rScale
    Next

End Sub