坐标网格标注 vba
本帖最后由 yealor 于 2022-12-22 16:47 编辑需求：对坐标网格进行批量标注
cad版本：2016
Sub Start_WangGeZuoBiao()
Dim Px As AcadEntity'AcadObject ' AcadLine
Dim PLX As AcadLine
Dim PtPick As Variant
On Error GoTo Err_handle
Do While ThisDrawing.SelectionSets.Count > 0 '选择集使用完了就要删除，图中原有的选择集
ThisDrawing.SelectionSets.Item(0).Delete
Loop
Dim XuanZeji As AcadSelectionSet
Set XuanZeji = ThisDrawing.SelectionSets.Add("XZJ") '添加选择集,选择集名为XZJ
Dim ft(0) As Integer
Dim fd(0) As Variant
ft(0) = 0
fd(0) = "Line"
XuanZeji.SelectOnScreen ft, fd'在屏幕上批量选择对象,但只选直线到选择集中
Dim JiaoDian As Variant
'''Dim Str As String
Dim Yi(0) As AcadEntity
'''Dim Yd(0) As AcadEntity
'''Dim tt As AcadEntity
Dim TXT As AcadText
For Each Px In XuanZeji
Set Yi(0) = Px
''' Debug.Print Px.Handle
XuanZeji.RemoveItems Yi'在选择集中删掉本图元,减少自和自己比较有没有交点
For Each PLX In XuanZeji
''' Debug.Print PLX.Handle '看看在和什么图元比较
JiaoDian = Px.IntersectWith(PLX, acExtendNone)'计算交点坐标
If UBound(JiaoDian) > 0 Then '判断交点是否存在
ThisDrawing.ModelSpace.AddText "N" & Format(JiaoDian(0), "0.000"), JiaoDian, 1
Set TXT = ThisDrawing.ModelSpace.AddText("S" & Format(JiaoDian(1), "0.000"), JiaoDian, 1)
TXT.Rotate JiaoDian, (270 * 3.14159265358979 / 180) '''弧度旋转
''' Str = JiaoDian(0) & "," & JiaoDian(1)
''' Debug.Print Str
''' Set Yd(0) = PLX
''' Debug.Print Px.Handle
'''' XuanZeji.RemoveItems Yi '此处不能移除配对项，否则在循环过程中会出现跳过的现象
''' For Each tt In XuanZeji
''' Debug.Print tt.Handle
''' Next
Exit For
End If
Next
Next
Err_handle:
End Sub
本帖最后由 陈宫在家吗 于 2023-2-21 09:16 编辑
为什么我发表的回复，自己编辑了一下，就不见了？
'==================================
原来跑最上面去了……
yealor 发表于 2022-12-22 16:46
天，我是12年注册的，今天居然才发第一个帖子
我也差不多，13年注册的，今天才发第2个帖子 我是15年注册的，今天居然才发第一个帖子 谢谢楼主分享 谢谢大佬，大佬有空可以多发帖子 20060510412 发表于 2022-12-22 17:42
之前接触过一段时间的vba，了解一点皮毛。
想请教一个问题，VBA能引用外部文件中的子函数吗？
对于你的疑问，我不甚了解，抱歉，抱歉 之前接触过一段时间的vba，了解一点皮毛。
想请教一个问题，VBA能引用外部文件中的子函数吗？
之前接触vba的时候，都是在当前代码中直接写一个子函数，好像是Private Function。 天，我是12年注册的，今天居然才发第一个帖子
页:
[1]