[分享]闲来无事，写了这个编号的程序

cag

'by gzy
'gzy@mjtd.com
'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)][N]: ")

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来调动,启不更好? 呵呵,纯属个人拙见,请别见笑.

杜红元

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

ctclsc

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


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


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


帮忙修改，谢谢！！！

wyj7485

杜红元发表于2005-2-21 17:48:00如何处理？？？？ _appload 已成功加载 编号.LSP。命令: ; 错误: no function definition: VBCRLF

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

cqy

我这里有对直线两端的编号，但端点相同会重复，那位仁兄帮调一调。 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

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

好程序，但不是我写的。

不知道为什么最近这个论坛有好多用我的注册名发的帖子？？？

abcxyz0517

什么时候学学VB

不过学的慢~

he520930

建议楼主修改两点:1.圆圈标注的那个,文字的中心与圆的中心不距中,2.能否两种标注与当前尺寸标注比例成正比?

把这两个地方修改过来后就更完美了.

dgw

好东西，支持，谢谢

linux1234

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