Sub drawLine()
Dim startPoint(0 To 2) As Double
Dim endPoint(0 To 2) As Double
Dim LineObj As AcadLine
startPoint(0) = 0: startPoint(1) = 0: startPoint(2) = 0
endPoint(0) = 300: endPoint(1) = 200: endPoint(2) = 0
Set LineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
ThisDrawing.Application.ZoomAll
End Sub
Sub addLayers()
Dim newLayer As AcadLayer
Set newLayer = ThisDrawing.Layers.Add("MyNewLayer")
End Sub
Sub IterateLayer()
On Error Resume Next
Dim I As Integer
Dim msg As String
msg = ""
For I = 0 To ThisDrawing.Layers.Count - 1
msg = msg + ThisDrawing.Layers.Item(I).Name + vbCrLf
Next
MsgBox msg
End Sub
Sub FindLayers()
On Error Resume Next
Dim ABCLayer As AcadLayer
Dim layerName As String
layerName = "採空區"
Set ABCLayer = ThisDrawing.Layers.Item(layerName)
If Err <> 0 Then
MsgBox "圖層'" & layerName & "'不存在！"
Set ABCLayer = ThisDrawing.Layers.Add(layerName)
ABCLayer.Lock = True
Else
MsgBox "找到圖層:" & ABCLayer.Name
ABCLayer.Delete
End If
End Sub
Sub CalculateDistance()
Dim point1 As Variant
Dim point2 As Variant
point1 = ThisDrawing.Utility.GetPoint(, vbCrLf & "第一點:")
point2 = ThisDrawing.Utility.GetPoint(, vbCrLf & "第二點:")
Dim x As Double, y As Double, z As Double
Dim dist As Double
x = point1(0) - point2(0)
y = point1(1) - point2(1)
z = point1(2) - point2(2)
dist = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
MsgBox "兩點之間的距離為:" & dist, , "間距"
End Sub
Sub OpenDrawing()
Dim dwgName As String
dwgName = "c:\1.dwg"
If Dir(dwgName) <> "" Then
ThisDrawing.Application.Documents.Open dwgName
Else
MsgBox "檔" & dwgName & "不存在"
End If
End Sub
Sub newDrawing()
Dim docObj As AcadDocument
Set docObj = ThisDrawing.Application.Documents.Add
End Sub
Sub saveDrawing()
ThisDrawing.Save
ThisDrawing.SaveAs "Mydrawing.dwg"
End Sub
Sub TestIfSave()
If Not (ThisDrawing.Saved) Then
If MsgBox("你是否想保存該圖形?", vbYesNo) = vbYes Then
ThisDrawing.Save
End If
End If
End Sub
Sub GetDistance()
Dim returnDist As Double
returnDist = ThisDrawing.Utility.GetDistance(, "拾取兩點")
MsgBox "兩點間的距離為:" & returnDist
End Sub
Sub getArea()
Dim p1 As Variant
Dim p2 As Variant
Dim p3 As Variant
Dim p4 As Variant
Dim p5 As Variant
p1 = ThisDrawing.Utility.GetPoint(, vbCrLf & "第一個點:")
p2 = ThisDrawing.Utility.GetPoint(p1, vbCrLf & "第二個點:")
p3 = ThisDrawing.Utility.GetPoint(p2, vbCrLf & "第三個點:")
p4 = ThisDrawing.Utility.GetPoint(p3, vbCrLf & "第四個點:")
p5 = ThisDrawing.Utility.GetPoint(p4, vbCrLf & "第五個點:")
Dim polyObj As AcadLWPolyline
Dim vertices(0 To 9) As Double
vertices(0) = p1(0): vertices(1) = p1(1)
vertices(2) = p2(0): vertices(3) = p2(1)
vertices(4) = p3(0): vertices(5) = p3(1)
vertices(6) = p4(0): vertices(7) = p4(1)
vertices(8) = p5(0): vertices(9) = p5(1)
Set polyObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(vertices)
polyObj.Closed = True
ThisDrawing.Application.ZoomAll
MsgBox "面積: " & polyObj.Area, , "計算定義的面積"
End Sub
Sub getStringFromUser()
Dim retVal As String
retVal = ThisDrawing.Utility.GetString(1, vbCrLf & "輸入你的名字:")
MsgBox "輸入的名字為:" & retVal
End Sub
Sub GetPointFromUser()
Dim startPnt As Variant
Dim endPnt As Variant
Dim prompt1 As String
Dim prompt2 As String
prompt1 = vbCrLf & "輸入直線起點:"
prompt2 = vbCrLf & "輸入直線終點:"
startPnt = ThisDrawing.Utility.GetPoint(, prompt1)
endPnt = ThisDrawing.Utility.GetPoint(startPnt, prompt2)
ThisDrawing.ModelSpace.AddLine startPnt, endPnt
ThisDrawing.Application.ZoomAll
End Sub
Sub keyWord()
Dim keyWord As String
ThisDrawing.Utility.InitializeUserInput 1, "Line Circle Arc"
keyWord = ThisDrawing.Utility.GetKeyword(vbCrLf & "輸入選項[直線(L)/圓(C)/圓弧(A)]:")
MsgBox keyWord, , "示例"
End Sub
Sub keyWord2()
Dim keyWord As String
ThisDrawing.Utility.InitializeUserInput 0, "Line Circle Arc"
keyWord = ThisDrawing.Utility.GetKeyword(vbCrLf & "輸入選項[直線(L)/圓(C)/圓弧(A)]:")
If keyWord = "" Then keyWord = "Arc"
MsgBox keyWord, , "示例"
End Sub
Sub SendCommandToAutoCad()
ThisDrawing.SendCommand "_Circle 2,2,0 100 "
ThisDrawing.SendCommand "_zoom a "
End Sub
全站熱搜
留言列表
