AutoCAD CAD 二次开发 CAD VBA开发。

Dim BlockNameSt As String

Sub DimDimaligned()
On Error GoTo Err
Dim Po(0 To 2) As Double
Dim Pr(0 To 2) As Double
Dim Var As Variant
Dim DimDimalign As AcadDimRotated
Dim BlokName As String
Dim Ang As Double
Dim LDob As Double
Dim XDob As Double
Dim PtH As String

Var = ThisDrawing.Utility.GetPoint(, vbCr & "指定第一条尺寸界线原点:")
Po(0) = Var(0): Po(1) = Var(1): Po(2) = Var(2)

Var = ThisDrawing.Utility.GetPoint(Po, vbCr & "指定第二条尺寸界线原点:")
Pr(0) = Var(0): Pr(1) = Var(1): Pr(2) = Var(2)

XDob = Pr(0) - Po(0)
LDob = Sqr(((Pr(0) - Po(0)) * (Pr(0) - Po(0))) + ((Pr(1) - Po(1)) * (Pr(1) - Po(1))))
Ang = XDob / LDob

If Pr(1) > Po(1) Then
Ang = Atn(-Ang / Sqr(-Ang * Ang + 1)) + 2 * Atn(1)
End If
If Pr(1) < Po(1) Then
Ang = -Atn(-Ang / Sqr(-Ang * Ang + 1)) + 2 * Atn(1) - 180 * 3.1415926 / 180
End If
If Pr(1) = Po(1) And Pr(0) < Po(0) Then
Ang = 180 * 3.1415926 / 180
End If
If Pr(1) = Po(1) And Pr(0) > Po(0) Then
Ang = 0
End If
Set DimDimalign = ThisDrawing.ModelSpace.AddDimRotated(Po, Pr, Pr, Ang)
Err:

End Sub

Sub Linkblok()
On Error GoTo Err
Dim Po(0 To 2) As Double
Dim Pr(0 To 2) As Double
Dim Var As Variant
Dim BlokIn As AcadBlockReference
Dim BlokName As String
Dim Ang As Double
Dim LDob As Double
Dim XDob As Double
Dim PtH As String

Dim UcsObj As AcadUCS
Dim Origin(0 To 2) As Double
Dim XAxisPo(0 To 2) As Double
Dim YAxisPo(0 To 2) As Double

Origin(0) = 0#: Origin(1) = 0#: Origin(2) = 0#
XAxisPo(0) = 3: XAxisPo(1) = 0: XAxisPo(2) = 0
YAxisPo(0) = 0: YAxisPo(1) = 3: YAxisPo(2) = 0
Set UcsObj = ThisDrawing.UserCoordinateSystems.Add(Origin, XAxisPo, YAxisPo, "WUCS")
ThisDrawing.ActiveUCS = UcsObj

BlokName = ThisDrawing.Utility.GetString(False, vbCr & "输入的块名<" + BlockNameSt + ">: ")

If BlokName = "" Then BlokName = BlockNameSt

PtH = "D:\CAD块\" + BlokName + ".dwg"

If Dir(PtH) <> "" Then
BlockNameSt = BlokName

Do

Var = ThisDrawing.Utility.GetPoint(, vbCr & "选取图块放置点:")
Po(0) = Var(0): Po(1) = Var(1): Po(2) = Var(2)
Set BlokIn = ThisDrawing.ModelSpace.InsertBlock(Po, PtH, 1, 1, 1, 0)

Var = ThisDrawing.Utility.GetPoint(Po, vbCr & "指定图块方向:")
Pr(0) = Var(0): Pr(1) = Var(1): Pr(2) = Var(2)
XDob = Pr(0) - Po(0)
LDob = Sqr(((Pr(0) - Po(0)) * (Pr(0) - Po(0))) + ((Pr(1) - Po(1)) * (Pr(1) - Po(1))))
Ang = XDob / LDob

If Pr(1) > Po(1) Then
Ang = Atn(-Ang / Sqr(-Ang * Ang + 1)) + 2 * Atn(1)
End If
If Pr(1) < Po(1) Then
Ang = -Atn(-Ang / Sqr(-Ang * Ang + 1)) + 2 * Atn(1) - 180 * 3.1415926 / 180
End If
If Pr(1) = Po(1) And Pr(0) < Po(0) Then
Ang = 180 * 3.1415926 / 180
End If
If Pr(1) = Po(1) And Pr(0) > Po(0) Then
Ang = 0
End If

BlokIn.Rotate Po, Ang

Loop

Else
ThisDrawing.Utility.Prompt vbCr & PtH + "的文件路径不存在!"
End If

Err:

End Sub

Sub LinkblokR0()
On Error GoTo Err
Dim Po(0 To 2) As Double
Dim Pr(0 To 2) As Double
Dim Var As Variant
Dim BlokIn As AcadBlockReference
Dim BlokName As String
Dim Ang As Double
Dim LDob As Double
Dim XDob As Double
Dim PtH As String

Dim UcsObj As AcadUCS
Dim Origin(0 To 2) As Double
Dim XAxisPo(0 To 2) As Double
Dim YAxisPo(0 To 2) As Double

Origin(0) = 0#: Origin(1) = 0#: Origin(2) = 0#
XAxisPo(0) = 3: XAxisPo(1) = 0: XAxisPo(2) = 0
YAxisPo(0) = 0: YAxisPo(1) = 3: YAxisPo(2) = 0
Set UcsObj = ThisDrawing.UserCoordinateSystems.Add(Origin, XAxisPo, YAxisPo, "WUCS")
ThisDrawing.ActiveUCS = UcsObj

BlokName = ThisDrawing.Utility.GetString(False, vbCr & "输入的块名<" + BlockNameSt + ">: ")

If BlokName = "" Then BlokName = BlockNameSt

PtH = "D:\CAD块\" + BlokName + ".dwg"

If Dir(PtH) <> "" Then
BlockNameSt = BlokName

Do

Var = ThisDrawing.Utility.GetPoint(, vbCr & "选取图块放置点:")
Po(0) = Var(0): Po(1) = Var(1): Po(2) = Var(2)
Set BlokIn = ThisDrawing.ModelSpace.InsertBlock(Po, PtH, 1, 1, 1, 0)

'Var = ThisDrawing.Utility.GetPoint(Po, vbCr & "指定图块方向:")
'Pr(0) = Var(0): Pr(1) = Var(1): Pr(2) = Var(2)
Pr(0) = 0#: Pr(1) = 0#: Pr(2) = 0#
XDob = Pr(0) - Po(0)
LDob = Sqr(((Pr(0) - Po(0)) * (Pr(0) - Po(0))) + ((Pr(1) - Po(1)) * (Pr(1) - Po(1))))
Ang = XDob / LDob

If Pr(1) > Po(1) Then
Ang = Atn(-Ang / Sqr(-Ang * Ang + 1)) + 2 * Atn(1)
End If
If Pr(1) < Po(1) Then
Ang = -Atn(-Ang / Sqr(-Ang * Ang + 1)) + 2 * Atn(1) - 180 * 3.1415926 / 180
End If
If Pr(1) = Po(1) And Pr(0) < Po(0) Then
Ang = 180 * 3.1415926 / 180
End If
If Pr(1) = Po(1) And Pr(0) > Po(0) Then
Ang = 0
End If

BlokIn.Rotate Po, Ang

Loop

Else
ThisDrawing.Utility.Prompt vbCr & PtH + "的文件路径不存在!"
End If

Err:

End Sub

Sub PlineLenX()
On Error GoTo Err

Dim Plx As String
Dim Obj As AcadEntity
Dim LenTxt As AcadText
Dim Po(0 To 2) As Double
Dim Var As Variant

ThisDrawing.Utility.GetEntity Obj, Var, vbCr & "选取PolyLine对象:"

If Obj.ObjectName = "AcDbPolyline" Then
Plx = CStr(Int(Obj.Length * 100) / 100)

Var = ThisDrawing.Utility.GetPoint(, vbCr & "选取文字放置点:")
Po(0) = Var(0): Po(1) = Var(1): Po(2) = Var(2)
Set LenTxt = ThisDrawing.ModelSpace.AddText("heater len", Po, 4)
LenTxt.StyleName = "HEATERTXT": LenTxt.Layer = "3"
Po(0) = Po(0): Po(1) = Po(1) - 6: Po(2) = Po(2)
Set LenTxt = ThisDrawing.ModelSpace.AddText(Plx, Po, 4)
LenTxt.StyleName = "HEATERTXT": LenTxt.Layer = "3"
Else
ThisDrawing.Utility.Prompt vbCr & "选取对象无效!"

End If
Err:

End Sub本回答被网友采纳

这算是什么问题？要资料还是有问题？