[编程交流] 绘制垂直线

Dim p0 as AcadPoint
Dim p1 as AcadPoint
Dim p2(1) as double
Dim p3(1) as Double
'The following only seems to work when I Dim p0 and p1 as variant
Set p0 = ThisDrawing.Utility.GetPoint()
Set p1 = ThisDrawing.Utility.GetPoint()
'Calculate the first point
p2(0) = p0(0) - 0.3 * (p0(1) - p1(1))/((p0(0)-p1(0))^2+(p0(1)-p1(1))^2)^0.5
'And so on for the other coördinates
'Then draw the lines
Dim pLine1 as AcadPolyLine
Set pLine1 = Thisdrawing.Application.ActiveDocument.Modelspade.Addline(p0, p2)
'Dito for the second line

Sub TestDrawLines()
   Dim p0 As Variant
   Dim p1 As Variant
   Dim p2(2) As Double
   Dim p3(2) As Double
   On Error GoTo ErrorTrapping
   'The following only seems to work when I Dim p0 and p1 as variant
   p0 = ThisDrawing.Utility.GetPoint()
   p1 = ThisDrawing.Utility.GetPoint(p0)
   'Calculate the first point
   p2(0) = p0(0) - 0.3 * (p0(1) - p1(1)) / ((p0(0) - p1(0)) ^ 2 + (p0(1) - p1(1)) ^ 2) ^ 0.5
   'And so on for the other coordinates
   'Then draw the lines
   Dim Line1 As AcadLine
   Set Line1 = ThisDrawing.ModelSpace.AddLine(p0, p2)
   'Dito for the second line
   Exit Sub
ErrorTrapping:
   MsgBox "Program ends due to error!"
End Sub

 
Option Explicit
'' ---> request check "Break on Unhandled Errors" in  Tools-> Options -> General tab  <---
Public Sub DrawTicks()
Dim stPt As Variant, endPt As Variant
Dim intOsm As Integer
intOsm = ThisDrawing.GetVariable("OSMODE")
ThisDrawing.SetVariable "OSMODE", 0
Dim Pi As Double
Pi = Atn(1#) * 4
Do
On Error Resume Next
stPt = ThisDrawing.Utility.GetPoint(, vbCrLf & "First point (ENTER or Right click to exit): ")
If Err Then
Err.Clear
Exit Do
End If
On Error GoTo 0
endPt = ThisDrawing.Utility.GetPoint(stPt, vbCrLf & "End point: ")
If Err Then
Err.Clear
Exit Do
End If
On Error GoTo 0
Dim ang As Double
ang = ThisDrawing.Utility.AngleFromXAxis(stPt, endPt)
Dim tmp As Variant
tmp = ThisDrawing.Utility.PolarPoint(stPt, ang + Pi / 2, 0.3)
Dim oLine As AcadLine
Set oLine = ThisDrawing.ModelSpace.AddLine(stPt, endPt)
Set oLine = ThisDrawing.ModelSpace.AddLine(stPt, tmp)
tmp = ThisDrawing.Utility.PolarPoint(endPt, ang + Pi / 2, 0.3)
Set oLine = ThisDrawing.ModelSpace.AddLine(endPt, tmp)
Loop
On Error GoTo 0
ThisDrawing.SetVariable "OSMODE", intOsm
End Sub

Sub Kop3()   Dim p0 As Variant   Dim p1 As Variant   Dim p2(2) As Double   Dim p3(2) As Double   Dim pLine1, pLine2 As AcadLine      On Error GoTo ErrorTrapping          p0 = ThisDrawing.Utility.GetPoint(, "Eerste punt (ENTER of Rechtse klik om te verlaten):")   p1 = ThisDrawing.Utility.GetPoint(p0, "Eindpunt (ENTER of Rechtse klik om te verlaten):")      p2(0) = p0(0) - (0.3 * (p0(1) - p1(1)) / ((p0(0) - p1(0)) ^ 2 + (p0(1) - p1(1)) ^ 2) ^ 0.5)   p2(1) = p0(1) + (0.3 * (p0(0) - p1(0)) / ((p0(0) - p1(0)) ^ 2 + (p0(1) - p1(1)) ^ 2) ^ 0.5)      p3(0) = p1(0) - (0.3 * (p0(1) - p1(1)) / ((p0(0) - p1(0)) ^ 2 + (p0(1) - p1(1)) ^ 2) ^ 0.5)   p3(1) = p1(1) + (0.3 * (p0(0) - p1(0)) / ((p0(0) - p1(0)) ^ 2 + (p0(1) - p1(1)) ^ 2) ^ 0.5)   Set pLine1 = ThisDrawing.Application.ActiveDocument.ModelSpace.AddLine(p0, p2)   Set pLine2 = ThisDrawing.Application.ActiveDocument.ModelSpace.AddLine(p1, p3)      Dim Layer As AcadLayer   Set Layer = ThisDrawing.Application.ActiveDocument.Layers.Add("N_WLI2")   pLine1.Layer = "N_WLI2"   pLine2.Layer = "N_WLI2"      Exit Sub   ErrorTrapping:   MsgBox "Fout bij het aanduiden!"End Sub