加载个合并工具

fanshu · 发表于 2008-7-29 11:52:36

马上注册，结识高手，享用更多资源，轻松玩转三维网社区。

您需要登录才可以下载或查看，没有帐号？注册

x

有那个CAD辅助工具(外挂)具有合并功能?我想把它加载到CAD2004上用,可以不?

[ 本帖最后由唐昕晨于 2009-1-11 09:38 编辑 ]

唐昕晨 · 发表于 2008-7-29 14:19:54

当然可以

fanshu · 发表于 2008-7-29 17:40:50

怎么搞?版主忽悠人?

hebei · 发表于 2008-7-29 17:58:46

提示: 作者被禁止或删除内容自动屏蔽

xiaoma76 · 发表于 2008-7-29 18:02:40

VBA的我不忽悠人!

Sub LianX()
On Error GoTo xx
Dim ssetObj As AcadSelectionSet
Set ssetObj = CreateSelectionSet("uniteSS"

  Dim fType, fData
  BuildFilter fType, fData, -4, "<or", 0, "line", 0, "LWPolyline", -4, "or>"
  '屏选直线或多段线
  ssetObj.SelectOnScreen fType, fData
  Dim i As Integer
  If ssetObj.Count <= 1 Then
ThisDrawing.Utility.Prompt "选择的线少于两个，退出命令。"
Exit Sub
  End If

  Dim line1 As Object
  Dim line2 As Object

  Set line1 = ssetObj(0)
  Dim pd As Boolean
  For i = 1 To ssetObj.Count
Set line2 = ssetObj(i)
'连接线
pd = unite2Line(line1, line2)
      '如果连接不成功，则退出命令。
If Not pd Then ssetObj.Delete: Exit Sub
  Next
xx:
   Select Case line1.ObjectName
         Case "AcDbLine"
            ThisDrawing.Utility.Prompt ssetObj.Count & "条线段已连接为直线．"
         Case "AcDbPolyline"
            ThisDrawing.Utility.Prompt ssetObj.Count & "条线段已连接为多段线．"
   End Select
  ssetObj.Delete
End Sub

Sub uniteline()
  On Error Resume Next
  '取得线
  Dim line1 As Object
  Dim line2 As Object
  Dim pt1, pt2, pt3, pt4, basePnt As AcadEntity
  Dim lpt1, lpt2 As Variant

  gwGetEntity line1, basePnt, "请选择第一根直线或多段线：", "AcDbLine", "AcDbPolyline"
  If line1 Is Nothing Then
ThisDrawing.Utility.Prompt "用户取消，退出命令。"
Exit Sub
  End If

  gwGetEntity line2, basePnt, "请选择第二根直线或多段线：", "AcDbLine", "AcDbPolyline"
  If line2 Is Nothing Then
ThisDrawing.Utility.Prompt "用户取消，退出命令。"
Exit Sub
  End If
  '连接线
  unite2Line line1, line2
End Sub

Function unite2Line(ByRef line1 As Object, ByVal line2 As Object) As Boolean
  '连接线函数，连接后的线返回到变量line1中，如果连接成功，unite2Line返回true，否则为false
On Error Resume Next
  unite2Line = False

  If line1.Handle = line2.Handle Then
ThisDrawing.Utility.Prompt "选择的是同一直线或多段线，退出命令。"
Exit Function
  End If

  getLinePoint line1, pt1, pt2
  getLinePoint line2, pt3, pt4

  Dim A1, A2, A3 As Double
  Dim maxdi As Double
  A1 = ThisDrawing.Utility.AngleFromXAxis(pt1, pt2)
  A2 = ThisDrawing.Utility.AngleFromXAxis(pt3, pt4)
  A3 = ThisDrawing.Utility.AngleFromXAxis(pt1, pt3)
  '判断四点是否共线
  If Abs(A1 - A2) < 0.0000001 And (Abs(A1 - A3) < 0.0000001 Or Abs(Abs(A1 - A3) - PI) < 0.0000001) Then
   '取得距离最远的两个点。
   maxdi = MaxDouble(GetDistance(pt1, pt2), GetDistance(pt1, pt3), GetDistance(pt1, pt4), _
                     GetDistance(pt2, pt3), GetDistance(pt2, pt4), GetDistance(pt3, pt4))
   If GetDistance(pt1, pt2) = maxdi Then lpt1 = pt1: lpt2 = pt2
   If GetDistance(pt1, pt3) = maxdi Then lpt1 = pt1: lpt2 = pt3
   If GetDistance(pt1, pt4) = maxdi Then lpt1 = pt1: lpt2 = pt4
   If GetDistance(pt2, pt3) = maxdi Then lpt1 = pt2: lpt2 = pt3
   If GetDistance(pt2, pt4) = maxdi Then lpt1 = pt2: lpt2 = pt4
   If GetDistance(pt3, pt4) = maxdi Then lpt1 = pt3: lpt2 = pt4
   '画直线
   Select Case line1.ObjectName
      Case "AcDbLine"
         line1.StartPoint = lpt1
         line1.EndPoint = lpt2
         line2.Delete
         unite2Line = True
      Case "AcDbPolyline"
         Dim newPline As AcadLWPolyline
         Set newPline = AddLWPlineSeg(lpt1, lpt2, line1.ConstantWidth)
         newPline.Layer = line1.Layer
         newPline.color = line1.color
         newPline.Linetype = line1.Linetype
         line1.Delete
         line2.Delete
         Set line1 = newPline
            unite2Line = True
   End Select
  Else: ThisDrawing.Utility.Prompt "两线不在同一直线上，退出命令．"
  End If
End Function

'以下是上述代码调用的函数?

'创建轻量多段线（只有两个顶点的直线多段线）
Public Function AddLWPlineSeg(ByVal ptSt As Variant, ByVal ptEn As Variant, Optional ByVal width As Double = 0) As AcadLWPolyline
Dim objPline As AcadLWPolyline
Dim ptArr(0 To 3) As Double

ptArr(0) = ptSt(0)
ptArr(1) = ptSt(1)
ptArr(2) = ptEn(0)
ptArr(3) = ptEn(1)

Set objPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptArr)
objPline.ConstantWidth = width
objPline.Update
Set AddLWPlineSeg = objPline
End Function
Public Function getLinePoint(ent As AcadEntity, ByRef Point1 As Variant, ByRef Point2 As Variant)
   '本函数得到线的端点，其中point1为Ｙ坐标较小的点
Dim p1(2) As Double
Dim p2(2) As Double
Dim k As Integer
On Error Resume Next
      Select Case ent.ObjectName
         Case "AcDbLine"
            Point1 = ent.StartPoint
            Point2 = ent.EndPoint
            If ThisDrawing.Utility.AngleFromXAxis(Point1, Point2) >= PI Then
                  Point1 = ent.EndPoint
                  Point2 = ent.StartPoint
            End If
         Case "AcDbPolyline"
            Dim entCo As Variant
            entCo = ent.Coordinates
            k = UBound(entCo)
            If k >= 3 Then
                  p1(0) = entCo(0): p1(1) = entCo(1)
                  p2(0) = entCo(k - 1): p2(1) = entCo(k)
                  If ThisDrawing.Utility.AngleFromXAxis(p1, p2) >= PI Then
                     p2(0) = entCo(0): p2(1) = entCo(1)
                     p1(0) = entCo(k - 1): p1(1) = entCo(k)
                  End If
                  Point1 = p1: Point2 = p2
            End If
      End Select
End Function
Public Function PI() As Double
  PI = Atn(1) * 4
End Function
Public Sub GetEntityEx(ent As Object, pickedPoint, Optional Prompt)
  '选择实体，直到用户取消操作
On Error Resume Next
StartLoop:
ThisDrawing.Utility.GetEntity ent, pt, Prompt
If Err Then
      If ThisDrawing.GetVariable("errno") = 7 Then
         Err.Clear
         GoTo StartLoop
      Else
         Err.Raise vbObjectError + 5, , "用户取消操作"
      End If
End If
End Sub
Public Sub gwGetEntity(ent As Object, pickedPoint, Prompt As String, ParamArray gType())
'选择某一类型的实体，如果选择错误则继续，按ESC退出
'gtype是实体名称，不区分大小写，可以用通配符号，如"AcDbBlockReference"，"acdb*text"等
Dim i As Integer
Dim pd As Boolean
pd = False
Do
  GetEntityEx ent, pickedPoint, Prompt

  If ent Is Nothing Then
Exit Do
  ElseIf UBound(gType) - LBound(gType) + 1 = 0 Then
Exit Do
  Else
For i = LBound(gType) To UBound(gType)
   If UCase(ent.ObjectName) Like UCase(gType(i)) Then
      Exit Do
   Else
      pd = True
   End If
Next i
If pd Then ThisDrawing.Utility.Prompt "选择的实体不符合要求．"
  End If
Loop

End Sub
'计算两点之间距离
Public Function GetDistance(sp As Variant, ep As Variant) As Double
Dim X As Double
Dim y As Double
Dim z As Double

X = sp(0) - ep(0)
y = sp(1) - ep(1)
z = sp(2) - ep(2)

GetDistance = Sqr((X ^ 2) + (y ^ 2) + (z ^ 2))
End Function
'返回两个Double类型变量的最大值
Public Function MaxDouble(ByVal a As Double, ParamArray b()) As Double
  MaxDouble = a
  Dim i As Integer
  For i = LBound(b) To UBound(b)
If b(i) > MaxDouble Then MaxDouble = b(i)
  Next i
End Function
Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet
  '返回一个空白选择集

Dim ss As AcadSelectionSet

On Error Resume Next
Set ss = ThisDrawing.SelectionSets(ssName)
If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
ss.Clear
Set CreateSelectionSet = ss
End Function
Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes())
'用数组方式填充一对变量以用作为选择集过滤器使用
Dim fType() As Integer, fData()
Dim index As Long, i As Long

index = LBound(gCodes) - 1

For i = LBound(gCodes) To UBound(gCodes) Step 2
      index = index + 1
      ReDim Preserve fType(0 To index)
      ReDim Preserve fData(0 To index)
      fType(index) = CInt(gCodes(i))
      fData(index) = gCodes(i + 1)
Next
typeArray = fType: dataArray = fData
End Sub

[ 本帖最后由 xiaoma76 于 2008-7-29 18:10 编辑 ]

fanshu · 发表于 2008-7-29 19:15:07

原帖由 xiaoma76 于 2008-7-29 18:02 发表 http://www.3dportal.cn/discuz/images/common/back.gif( ~/ y  V( O0 e
VBA的我不忽悠人! " `6 E* d" q- _! z1 E! M( w; v
3 }& R: r* B# B$ o
Sub LianX()
3 q1 m" }+ p) `) j" zOn Error GoTo xx
$ q/ X/ N4 v0 l* |' i  Dim ssetObj As AcadSelectionSet
9 F( ~) n+ x, g( J3 O, h+ t  Set ssetObj = CreateSelectionSet("uniteSS", ~; `+ O5 P5 J
  Dim fType, fData
, M# `" I$ w3 `  BuildFilter fType, fData, -4, ""
( E/ E5 t" @. v) K1 ~  '屏 ...

我晕了~~~~~~~~~~~~~~~~

fanshu · 发表于 2008-7-30 13:00:14

不好意思,我这个二次开发这东西从来没有搞过,所以不懂~
感谢xiaoma76工程师~

[ 本帖最后由 fanshu 于 2008-7-30 13:03 编辑 ]

fanshu · 发表于 2008-7-30 13:18:17

不知道怎么使用

woaishuijia · 发表于 2008-7-30 15:05:02

1、确认你的ACAD安装了VBA支持；
2、由于页面上的代码与表情有混淆，下载5楼附件，解压后是一个文本文件，打开它，全部选择，复制；
3、运行CAD，“Alt+F11”打开“VBA编辑器”；
4、双击“工程资源管理器”中的“Thisdrawing”对象，显示代码窗口，在其上粘贴。
5、保存，便于以后使用；
6、回到CAD界面，“Alt+F8”，对话框中有两个程序，任选一个“运行”，按命令行提示操作。两个程序的异同点请自已尝试。

以后再次使用：
1、“appload”命令，在打开文件对话框中选择前面保存的dvb格式文件，加载；
2、“Alt+F8”，“运行”；或“-vbarun”命令，在提示输入宏名称时键入“lianx”或“uniteline”，回车。

		自动登录	找回密码
密码			注册

通知

[已解决] 加载个合并工具

马上注册，结识高手，享用更多资源，轻松玩转三维网社区。

评分

回复 8# 的帖子

评分

浏览过的版块

hebei hebei 当前离线积分 2978 UID 494886 主题在线时间小时注册时间 2008-3-22 头像被屏蔽	发表于 2008-7-29 17:58:46 \| 显示全部楼层来自：中国河北衡水提示: 作者被禁止或删除内容自动屏蔽

	回复支持 1 反对 0 举报