[分享]闲来无事，写了这个编号的程序 - 源码共享 - AutoCAD论坛 - 明经CAD社区 - 第3页

cag 发表于 2005-1-17 08:42:00

'by gzy <A href="mailto:'gzy@mjtd.com" target="_blank" >'gzy@mjtd.com</A> 'scuta

Dim Nums As Integer Sub Numbers() Nums = 1 Dim keyWord As String ThisDrawing.Utility.InitializeUserInput 0, "y n" keyWord = ThisDrawing.Utility.GetKeyword(vbCrLf & "编号是否带圈[否(N)/是(Y)]: ") If keyWord = "" Then keyWord = "N" Call Ncircle Else Call Cir End If If keyWord = "N" Then Call Ncircle End Sub

Sub Ncircle() RETRY: Dim PPck1 As Variant, PPck2 As Variant Dim textobject(0) As AcadObject: Dim line1 As AcadLine: Dim line2 As AcadLine Dim ppt(0 To 2) As Double: Dim Numbers1 As String: Dim Inserpt(0 To 2) As Double On Error Resume Next ' ThisDrawing.GetVariable ("osnap") PPck1 = ThisDrawing.Utility.GetPoint(, "请指定零件：") If Err <> 0 Then Err.Clear ThisDrawing.Utility.Prompt " 没有指定零件,退出" Exit Sub End If PPck2 = ThisDrawing.Utility.GetPoint(PPck1, "请指定编号位置：") If Err <> 0 Then Err.Clear ThisDrawing.Utility.Prompt " 没有指定编号位置,退出" Exit Sub End If Set line1 = ThisDrawing.ModelSpace.AddLine(PPck1, PPck2) TextHeight = ThisDrawing.GetVariable("dimtxt") '沿用系统文字高度 If pd(PPck1, PPck2) = True Then ppt(0) = PPck2(0) - 2 * TextHeight: ppt(1) = PPck2(1): ppt(2) = PPck2(2) Else ppt(0) = PPck2(0) + 2 * TextHeight: ppt(1) = PPck2(1): ppt(2) = PPck2(2) End If Set line2 = ThisDrawing.ModelSpace.AddLine(PPck2, ppt) line2.Lineweight = acLnWt030 ThisDrawing.SendCommand "_LWDISPLAY" & vbCr & "on" & vbCr '显示线宽 Numbers1 = ThisDrawing.Utility.GetString(0, vbCrLf & "请输入编号数字(上一编号为" & Nums - 1 & ")" & "[" & Nums & "]:") If Numbers1 = "" Then Numbers1 = Nums If pd(PPck1, PPck2) = True Then If Len(Numbers1) = 1 Then Inserpt(0) = ppt(0) + 0.6 * TextHeight: Inserpt(1) = ppt(1) + 0.2 * TextHeight: Inserpt(2) = ppt(2) Else Inserpt(0) = ppt(0) + 0.1 * TextHeight: Inserpt(1) = ppt(1) + 0.2 * TextHeight: Inserpt(2) = ppt(2) End If Else If Len(Numbers1) = 1 Then Inserpt(0) = ppt(0) - 1.2 * TextHeight: Inserpt(1) = ppt(1) + 0.2 * TextHeight: Inserpt(2) = ppt(2) Else Inserpt(0) = ppt(0) - 1.8 * TextHeight: Inserpt(1) = ppt(1) + 0.2 * TextHeight: Inserpt(2) = ppt(2) End If End If Set textobject(0) = ThisDrawing.ModelSpace.AddText(Numbers1, Inserpt, TextHeight) Nums = Numbers1 '使提示与上一编号关联 Nums = Nums + 1 Dim Group1 As AcadGroup Dim objgroup(0 To 2) As AcadEntity Set objgroup(0) = line1 Set objgroup(1) = line2 Set objgroup(2) = textobject(0) Set Group1 = ThisDrawing.Groups.Add("*") Group1.AppendItems objgroup

GoTo RETRY End Sub

Sub Cir() RETRY: Dim PPck1 As Variant, PPck2 As Variant Dim textobject(0) As AcadObject: Dim line1 As AcadLine: Dim Cirobj As AcadCircle Dim ppt(0 To 2) As Double: Dim Numbers1 As String: Dim Inserpt(0 To 2) As Double On Error Resume Next PPck1 = ThisDrawing.Utility.GetPoint(, "请指定零件：") If Err <> 0 Then Err.Clear ThisDrawing.Utility.Prompt " 没有指定零件,退出" Exit Sub End If PPck2 = ThisDrawing.Utility.GetPoint(PPck1, "请指定编号位置：") If Err <> 0 Then Err.Clear ThisDrawing.Utility.Prompt " 没有指定编号位置,退出" Exit Sub End If Set line1 = ThisDrawing.ModelSpace.AddLine(PPck1, PPck2) TextHeight = ThisDrawing.GetVariable("dimtxt") '沿用系统文字高度 ppt(0) = PPck2(0) + 0.7 * TextHeight: ppt(1) = PPck2(1) - 0.5 * TextHeight: ppt(2) = PPck2(2) Set Cirobj = ThisDrawing.ModelSpace.AddCircle(PPck2, 1.2 * TextHeight) PPck2 = Cirobj.IntersectWith(line1, acExtendNone) '求交点 line1.EndPoint = PPck2 '剪切引线 Numbers1 = ThisDrawing.Utility.GetString(0, vbCrLf & "限于输入二位数字" & vbCrLf & "请输入编号数字(上一编号为" & Nums - 1 & ")" & "[" & Nums & "]:") If Numbers1 = "" Then Numbers1 = Nums If Len(Numbers1) = 2 Then Inserpt(0) = ppt(0) - 1.5 * TextHeight: Inserpt(1) = ppt(1) + 0.01 * TextHeight: Inserpt(2) = ppt(2) End If If Len(Numbers1) = 1 Then Inserpt(0) = ppt(0) - TextHeight: Inserpt(1) = ppt(1) + 0.01 * TextHeight: Inserpt(2) = ppt(2) End If Set textobject(0) = ThisDrawing.ModelSpace.AddText(Numbers1, Inserpt, TextHeight) Nums = Numbers1 '使提示与上一编号关联 Nums = Nums + 1 Dim Group2 As AcadGroup Dim objgroup(0 To 2) As AcadEntity Set objgroup(0) = line1 Set objgroup(1) = Cirobj Set objgroup(2) = textobject(0) Set Group1 = ThisDrawing.Groups.Add("*") Group1.AppendItems objgroup

GoTo RETRY End Sub Function pd(p1 As Variant, p2 As Variant) As Boolean '判断斜率，以便确定文字位置 If p1(0) > p2(0) Then pd = True Else pd = False End If End Function

呵呵,这样可视性启非更强?

还有好些语句都有重复使用,何不做成sub来调动,启不更好?

呵呵,纯属个人拙见,请别见笑.

杜红元 发表于 2005-2-21 17:48:00

如何处理？？？？

_appload 已成功加载编号.LSP。 命令: ; 错误: no function definition: VBCRLF

ctclsc 发表于 2005-3-15 18:49:00

美中不足的是 1、用STRETCH命令进行拉伸的时候，直线的延长线不再通过圆心了

2、圆的直径能否和图框插入比例相关联，否则圆看起来太小了

3、直线的那一部分能否换成箭头（qleader）,这个正好和我们公司的绘图习惯一样

帮忙修改，谢谢！！！

wyj7485 发表于 2005-3-17 17:18:00

杜红元发表于2005-2-21 17:48:00static/image/common/back.gif如何处理？？？？

_appload 已成功加载编号.LSP。命令: ; 错误: no function definition: VBCRLF

 进入到CAD的VB编辑器中保存使用

cqy 发表于 2005-3-31 14:48:00

我这里有对直线两端的编号，但端点相同会重复，那位仁兄帮调一调。

Public Sub 端点编号() Dim number As Integer Dim ObjSelectionSet As AcadSelectionSet i = 0 '获取当前图形中选择集的个数 number = ThisDrawing.SelectionSets.Count '删除当前图形中所有的选择集 While i < number Set ObjSelectionSet = ThisDrawing.SelectionSets.Item(0) ObjSelectionSet.Delete i = i + 1 Wend '创建命令执行需要的选择集 Set ObjSelectionSet = ThisDrawing.SelectionSets.Add("SSET") '建立延伸操作对象的集合 ThisDrawing.Utility.Prompt vbCr & "请选择两个角点定义要延伸的对象集合..." PtCorner01 = ThisDrawing.Utility.GetPoint(, "请选择第一点：") PtCorner02 = ThisDrawing.Utility.GetPoint(, "请选择第二点：") Dim gpCode(0) As Integer Dim dataValue(0) As Variant gpCode(0) = 0 dataValue(0) = "Line" Dim groupCode As Variant, dataCode As Variant groupCode = gpCode dataCode = dataValue '以直线作为对象类型的过滤条件 ObjSelectionSet.Select acSelectionSetCrossing, PtCorner01, PtCorner02, groupCode, dataCode Dim n As Integer Dim linea As AcadLine Dim text As AcadText Dim PtInter As Variant n = ObjSelectionSet.Count While n > 0 Set linea = ObjSelectionSet.Item(n - 1) Set objText = ThisDrawing.ModelSpace.AddText((2 * n - 1), linea.StartPoint, 10) Set objText = ThisDrawing.ModelSpace.AddText(2 * n, linea.EndPoint, 10) n = n - 1 Wend End Sub

 Public Function AddText(ByVal text As String, ByVal ptInsert As Variant, ByVal height As Double) As AcadText Set AddText = ThisDrawing.ModelSpace.AddText(text, ptInsert, height) End Function

cag 发表于 2007-4-4 13:02:00

cag发表于2005-1-17 8:42:00static/image/common/back.gif'by gzy'gzy@mjtd.com'scuta Dim Nums As IntegerSub Numbers()Nums = 1Dim keyWord As String    ThisDrawing.Utility.InitializeUserInput 0, \"y n\"    key

好程序，但不是我写的。不知道为什么最近这个论坛有好多用我的注册名发的帖子？？？

abcxyz0517 发表于 2007-4-4 17:31:00

什么时候学学VB不过学的慢~

he520930 发表于 2007-4-6 09:02:00

建议楼主修改两点:1.圆圈标注的那个,文字的中心与圆的中心不距中,2.能否两种标注与当前尺寸标注比例成正比?把这两个地方修改过来后就更完美了.

dgw 发表于 2007-10-23 20:19:00

好东西，支持，谢谢

linux1234 发表于 2007-11-8 14:29:00

绝对好东西,要是最后能规整一下让大家使用,岂不更好?

页: 1 2 [3] 4

明经CAD社区's Archiver