AutoCAD CAD 二次开发 CAD VBA开发。

 我来答

3个回答

#热议# 为什么有人显老，有人显年轻？

快乐小朱家
2011-08-05 · TA获得超过1013个赞

知道小有建树答主

回答量：649

采纳率：40%

帮助的人：381万

我也去答题访问个人页

关注

展开全部

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


本回答被网友采纳






已赞过已踩过<

你对这个回答的评价是？
评论收起