明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
楼主: gzy

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

  [复制链接]
发表于 2004-9-7 10:23 | 显示全部楼层
请教楼主您这个程序怎么使用。谢谢!!!
发表于 2004-9-10 14:53 | 显示全部楼层
我是一菜鸟,请问如何加载这一程序?
发表于 2004-9-11 08:50 | 显示全部楼层
我也想知道怎么用的,我的邮箱是xj220102@sina.com,谢谢
发表于 2004-9-15 20:42 | 显示全部楼层
我是一菜鸟,请问如何加载这一程序?
发表于 2004-9-16 16:45 | 显示全部楼层
我把程序改一改,生成零件上小圆圈,大大人指教 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
发表于 2004-10-7 14:15 | 显示全部楼层
我是一菜鸟,请问如何加载这一程序?         我的邮箱是:cjj_jc@com
发表于 2004-10-11 23:08 | 显示全部楼层
是LISP程序吧。


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


原后在CAD里LOAD                                         LSP 文件。


是这样吧。


15楼的同志的好像是个子程序。不知这样行不?
发表于 2004-11-12 15:23 | 显示全部楼层
精神可加。。。
发表于 2004-12-3 20:38 | 显示全部楼层
zfc8932发表于2004-10-11 23:08:00是LISP程序吧。 把正文复制下来另存为LSP文件。 原后在CAD里LOAD LSP 文件。 是这样吧。 15楼的同志的好像是个子程序。不知这样行不?
瞎说,明明是VBA
发表于 2004-12-28 15:36 | 显示全部楼层
好文章,正好能用到。多谢楼主
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-29 23:56 , Processed in 0.167806 second(s), 17 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表