Option Explicit

Public obj As AcadEntity

Public blnBezug As Boolean

Public dblBezug As Double

Public dblEinfuegePunkt(0 To 2) As Double

Public objblockref As AcadBlockReference

Public blnPruef As Boolean

Public varPosition As Variant

Sub KoteEinfuegen()

Dim dblAktuellerPunkt As Double

Dim varAtt As Variant

On Error resume next

varPosition(0) = 0: varPosition(1) = 0

If MsgBox("Ist eine Bezugskote vorhanden?", vbYesNo) = vbYes Then

varPosition = ThisDrawing.Utility.GetPoint(, "Bezugspunkt zeigen:")

dblBezug = varPosition(1)

blnBezug = True

Else

MsgBox "Die nächste Kote wird die Bezugskote"

End If

Call KoteVorhanden

Do While varPosition(0) <> 1 And varPosition(1) <> 1

varPosition = ThisDrawing.Utility.GetPoint _

(, vbCrLf & "Wo soll die Kote hin? (beenden mit 1,1): ")

If blnBezug = False Then

dblBezug = varPosition(1)

blnBezug = True

End If

If varPosition(0) = 1 And varPosition(1) = 1 Then Exit Sub

Set objblockref = ThisDrawing.ModelSpace.InsertBlock(varPosition, "kote", 1, 1, 1, 0)

Call yWertEintragen

Loop

End Sub

Public Sub yWertEintragen()

'Trägt den Y-Wert als Attribut in den Block ein, geht auch über Xdata oder Text: so besser

Dim varAtt As Variant

varAtt = objblockref.GetAttributes

varAtt(0).TextString = varPosition(1) - dblBezug

End Sub

Sub BlockEinfuegen()

'Fügt den Block ein, falls er nicht vorhanden ist

Dim blockRefObj As AcadBlockReference

Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(dblEinfuegePunkt, "c:\Block\kote.dwg", 1, 1, 1, 0)

ThisDrawing.SendCommand ("hoppla")

End Sub

Private Function KoteVorhanden()

'Prüft, ob bereits ein Block mit dem Namen kote eingefügt wurde

Dim objBl As AcadBlock

For Each objBl In ThisDrawing.Blocks

If objBl.Name = "kote" Then

blnPruef = True

Exit For

End If

Next

If blnPruef = False Then

Call BlockEinfuegen

blnPruef = True

End If

End Function