请教楼主您这个程序怎么使用。谢谢！！！
我是一菜鸟，请问如何加载这一程序？
我也想知道怎么用的，我的邮箱是<A href="mailto:xj220102@sina.com" target="_blank" >xj220102@sina.com</A>,谢谢
我是一菜鸟，请问如何加载这一程序？
我把程序改一改,生成零件上小圆圈,大大人指教
Sub ljbh() '零件序号生成程序<BR>Nums! = 1<BR>Dim keyWord As String<BR> ThisDrawing.Utility.InitializeUserInput 0, "y n"<BR> keyWord = ThisDrawing.Utility.GetKeyword(vbCrLf & "编号是否带圈[否(N)/是(Y)]: ")<BR>ThisDrawing.ActiveLayer = ThisDrawing.Layers("2标注层")<BR> <BR>RETRY:<BR> Dim PPck1 As Variant, PPck2 As Variant<BR> Dim textobject(0) As AcadObject, line1 As AcadLine, line2 As AcadLine<BR> Dim ppt(0 To 2) As Double, Numbers1 As String, Inserpt(0 To 2) As Double<BR> On Error Resume Next<BR> ' ThisDrawing.GetVariable ("osnap")<BR> PPck1 = ThisDrawing.Utility.GetPoint(, "请指定零件：")<BR> If Err <> 0 Then Err.Clear: ThisDrawing.Utility.Prompt " 没有指定零件,退出": Exit Sub<BR> <BR> PPck2 = ThisDrawing.Utility.GetPoint(PPck1, "请指定编号位置：")<BR> If Err <> 0 Then Err.Clear: ThisDrawing.Utility.Prompt " 没有指定编号位置,退出": Exit Sub<BR> TextHeight = ThisDrawing.GetVariable("dimtxt") * 1.3<BR> Set line1 = ThisDrawing.ModelSpace.AddLine(PPck1, PPck2)<BR> <BR>'------------------------------零件上的小圈圈划满它<BR>Dim hatchObj As AcadHatch '声明剖面线对象变量<BR> Dim patternName As String '保存剖面线模式名称的对象变量<BR> Dim PatternType As Long '保存剖面线模式类型的对象变量<BR> Dim assocVar As Boolean '判断剖面线与轮廓是否结合
patternName = "SOLID": PatternType = 0: assocVar = False '定义剖面线模式<BR> <BR> Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, assocVar) '创建剖面线对象<BR> Dim outerLoop(0 To 0) As AcadEntity<BR> Set outerLoop(0) = ThisDrawing.ModelSpace.AddCircle(PPck1, 0.1 * TextHeight) '零件上的小圈圈<BR> hatchObj.AppendOuterLoop (outerLoop): hatchObj.Evaluate '将外轮廓线与剖面线关联起来
'Set Cirobj = ThisDrawing.ModelSpace.AddCircle(PPck1, 0.1 * TextHeight)<BR> 'PPck1 = Cirobj.IntersectWith(line1, acExtendNone) '求交点<BR> 'line1.StartPoint = PPck1 '剪切引线<BR>'------------------------------零件上的小圈圈划满它
Numbers1 = ThisDrawing.Utility.GetString(0, vbCrLf & "限于输入二位数字" & vbCrLf & "请输入编号数字(上一编号为" & Nums - 1 & ")" & "[" & Nums & "]:")<BR> If Numbers1 = "" Then Numbers1 = Nums<BR> <BR> <BR>If keyWord = "" Or keyWord = "N" Then '划横线的
pd = 2: If PPck1(0) > PPck2(0) Then pd = 1<BR> ppt(0) = PPck2(0) + ((-1) ^ pd) * 2 * TextHeight: ppt(1) = PPck2(1)<BR> <BR> Set line2 = ThisDrawing.ModelSpace.AddLine(PPck2, ppt)<BR> <BR> line2.Lineweight = acLnWt030<BR> ThisDrawing.SendCommand "_LWDISPLAY" & vbCr & "on" & vbCr '显示线宽<BR> <BR>Inserpt(1) = ppt(1) + 0.4 * TextHeight<BR> If pd = 1 Then '字在左边<BR> If Len(Numbers1) = 1 Then<BR> Inserpt(0) = ppt(0) + 0.6 * TextHeight<BR> Else<BR> Inserpt(0) = ppt(0) + 0.1 * TextHeight<BR> End If<BR>Else<BR> If Len(Numbers1) = 1 Then<BR> Inserpt(0) = ppt(0) - 1.2 * TextHeight<BR> Else<BR> Inserpt(0) = ppt(0) - 1.8 * TextHeight<BR> End If<BR> End If<BR> <BR>Else '-------------------------划;圆圈的
ppt(0) = PPck2(0) + 0.7 * TextHeight: ppt(1) = PPck2(1) - 0.5 * TextHeight<BR> Set Cirobj = ThisDrawing.ModelSpace.AddCircle(PPck2, 1.2 * TextHeight)<BR> PPck2 = Cirobj.IntersectWith(line1, acExtendNone) '求交点<BR> line1.EndPoint = PPck2 '剪切引线<BR> <BR>Inserpt(1) = ppt(1) + 0.01 * TextHeight<BR> a! = 1: If Numbers1 = 1 Then a = 0.8<BR> If Len(Numbers1) = 2 Then Inserpt(0) = ppt(0) - 1.4 * TextHeight<BR> If Len(Numbers1) = 1 Then Inserpt(0) = ppt(0) - 1.1 * TextHeight * a
End If
Set textobject(0) = ThisDrawing.ModelSpace.AddText(Numbers1, Inserpt, TextHeight)<BR> <BR> Nums = Numbers1: Nums = Nums + 1 '使提示与上一编号关联<BR> <BR>Dim Group2 As AcadGroup<BR>Dim objgroup(0 To 2) As AcadEntity<BR>Set objgroup(0) = line1<BR>Set objgroup(1) = Cirobj<BR>Set objgroup(2) = textobject(0)<BR> Set Group1 = ThisDrawing.Groups.Add("*")<BR> Group1.AppendItems objgroup
GoTo RETRY<BR>End Sub
我是一菜鸟，请问如何加载这一程序？ 我的邮箱是:cjj_jc@com
是LISP程序吧。
把正文复制下来另存为LSP文件。
原后在CAD里LOAD LSP 文件。
是这样吧。
15楼的同志的好像是个子程序。不知这样行不？
精神可加。。。
zfc8932发表于2004-10-11 23:08:00static/image/common/back.gif是LISP程序吧。
把正文复制下来另存为LSP文件。
原后在CAD里LOAD LSP 文件。
是这样吧。
15楼的同志的好像是个子程序。不知这样行不？
瞎说，明明是VBA<BR>
好文章，正好能用到。多谢楼主