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

zl-sir

请教楼主您这个程序怎么使用。谢谢！！！

老虎

我是一菜鸟，请问如何加载这一程序？

乔峰

我也想知道怎么用的，我的邮箱是xj220102@sina.com,谢谢

xjjy

我是一菜鸟，请问如何加载这一程序？

jackgan

我把程序改一改,生成零件上小圆圈,大大人指教 Sub ljbh() '零件序号生成程序
Nums! = 1
Dim keyWord As String
ThisDrawing.Utility.InitializeUserInput 0, "y n"
keyWord = ThisDrawing.Utility.GetKeyword(vbCrLf & "编号是否带圈[否(N)/是(Y)][N]: ")
ThisDrawing.ActiveLayer = ThisDrawing.Layers("2标注层")

RETRY:
Dim PPck1 As Variant, PPck2 As Variant
Dim textobject(0) As AcadObject, line1 As AcadLine, line2 As AcadLine
Dim ppt(0 To 2) As Double, Numbers1 As String, 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

PPck2 = ThisDrawing.Utility.GetPoint(PPck1, "请指定编号位置：")
If Err <> 0 Then Err.Clear: ThisDrawing.Utility.Prompt " 没有指定编号位置,退出": Exit Sub
TextHeight = ThisDrawing.GetVariable("dimtxt") * 1.3
Set line1 = ThisDrawing.ModelSpace.AddLine(PPck1, PPck2)

'------------------------------零件上的小圈圈划满它
Dim hatchObj As AcadHatch '声明剖面线对象变量
Dim patternName As String '保存剖面线模式名称的对象变量
Dim PatternType As Long '保存剖面线模式类型的对象变量
Dim assocVar As Boolean '判断剖面线与轮廓是否结合 patternName = "SOLID": PatternType = 0: assocVar = False '定义剖面线模式

Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, assocVar) '创建剖面线对象
Dim outerLoop(0 To 0) As AcadEntity
Set outerLoop(0) = ThisDrawing.ModelSpace.AddCircle(PPck1, 0.1 * TextHeight) '零件上的小圈圈
hatchObj.AppendOuterLoop (outerLoop): hatchObj.Evaluate '将外轮廓线与剖面线关联起来 'Set Cirobj = ThisDrawing.ModelSpace.AddCircle(PPck1, 0.1 * TextHeight)
'PPck1 = Cirobj.IntersectWith(line1, acExtendNone) '求交点
'line1.StartPoint = PPck1 '剪切引线
'------------------------------零件上的小圈圈划满它 Numbers1 = ThisDrawing.Utility.GetString(0, vbCrLf & "限于输入二位数字" & vbCrLf & "请输入编号数字(上一编号为" & Nums - 1 & ")" & "[" & Nums & "]:")
If Numbers1 = "" Then Numbers1 = Nums


If keyWord = "" Or keyWord = "N" Then '划横线的 pd = 2: If PPck1(0) > PPck2(0) Then pd = 1
ppt(0) = PPck2(0) + ((-1) ^ pd) * 2 * TextHeight: ppt(1) = PPck2(1)

Set line2 = ThisDrawing.ModelSpace.AddLine(PPck2, ppt)

line2.Lineweight = acLnWt030
ThisDrawing.SendCommand "_LWDISPLAY" & vbCr & "on" & vbCr '显示线宽

Inserpt(1) = ppt(1) + 0.4 * TextHeight
If pd = 1 Then '字在左边
If Len(Numbers1) = 1 Then
Inserpt(0) = ppt(0) + 0.6 * TextHeight
Else
Inserpt(0) = ppt(0) + 0.1 * TextHeight
End If
Else
If Len(Numbers1) = 1 Then
Inserpt(0) = ppt(0) - 1.2 * TextHeight
Else
Inserpt(0) = ppt(0) - 1.8 * TextHeight
End If
End If

Else '-------------------------划;圆圈的 ppt(0) = PPck2(0) + 0.7 * TextHeight: ppt(1) = PPck2(1) - 0.5 * TextHeight
Set Cirobj = ThisDrawing.ModelSpace.AddCircle(PPck2, 1.2 * TextHeight)
PPck2 = Cirobj.IntersectWith(line1, acExtendNone) '求交点
line1.EndPoint = PPck2 '剪切引线

Inserpt(1) = ppt(1) + 0.01 * TextHeight
a! = 1: If Numbers1 = 1 Then a = 0.8
If Len(Numbers1) = 2 Then Inserpt(0) = ppt(0) - 1.4 * TextHeight
If Len(Numbers1) = 1 Then Inserpt(0) = ppt(0) - 1.1 * TextHeight * a 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

cjj_jx

我是一菜鸟，请问如何加载这一程序？         我的邮箱是:cjj_jc@com

zfc8932

是LISP程序吧。


把正文复制下来另存为LSP文件。


原后在CAD里LOAD                                         LSP 文件。


是这样吧。


15楼的同志的好像是个子程序。不知这样行不？

pfrynwgkq

精神可加。。。

SWAYWOOD

zfc8932发表于2004-10-11 23:08:00是LISP程序吧。 把正文复制下来另存为LSP文件。 原后在CAD里LOAD LSP 文件。 是这样吧。 15楼的同志的好像是个子程序。不知这样行不？

瞎说，明明是VBA

anston

好文章，正好能用到。多谢楼主