vba
本帖最后由 1291500406 于 2020-11-18 19:01 编辑模型解读日记
AutoCAD 2016 20.1 acax20<language>.tlb axdb20<language>.tlb
AutoCAD 2015 20.0 acax20<language>.tlb axdb20<language>.tlb
AutoCAD 2014 19.1 acax19<language>.tlb axdb19<language>.tlb
AutoCAD 2013 19.0 acax19<language>.tlb axdb19<language>.tlb
AutoCAD 2012 18.2 acax18<language>.tlb axdb18<language>.tlb
AutoCAD 2011 18.1 acax18<language>.tlb axdb18<language>.tlb
AutoCAD 2010 18.0 acax18<language>.tlb axdb18<language>.tlb
AutoCAD 2009 17.2 acax17<language>.tlb axdb17<language>.tlb
AutoCAD 2008 17.1 acax17<language>.tlb axdb17<language>.tlb
AutoCAD 2007 17.0 acax17<language>.tlb axdb17<language>.tlb
AutoCAD 2006 16.2 acax16<language>.tlb axdb16<language>.tlb
AutoCAD 2005 16.1 acax16<language>.tlb axdb16<language>.tlb
AutoCAD 2004 16.0 acax16<language>.tlb axdb16<language>.tlb
AutoCAD 2002 15.2 acax15.tlb axdb15.tlb
AutoCAD 2000i 15.1 acax15.tlb axdb15.tlb
AutoCAD 2000 15.0 acax15.tlb axdb15.tlb
Public Sub ErgodicDim()
Dim ent As AcadEntity '对象基类
For Each ent In ThisDrawing.ModelSpace '所有对象
If TypeOf ent Is AcadText Then '单行文本
'访问ent的属性和方法
ElseIf TypeOf ent Is AcadMText Then '多行文本
ElseIf TypeOf ent Is AcadDimension Then '标注
End If
Next
End Sub
Sub AlignEnt()
Dim ss As AcadSelectionSet
Set ss = CreateSelectionSet
ss.SelectOnScreen
Dim ent As AcadEntity
Dim MinPoint As Variant
Dim MaxPoint As Variant
If ss.Count > 0 Then
Dim AlignMode As String
On Error Resume Next
ThisDrawing.Utility.InitializeUserInput 0, "Left Middle Right"
AlignMode = ThisDrawing.Utility.GetKeyword("选择对齐方式[左对齐(L)/对中(M)/右对齐(R)]<左对齐>：")
If Err Then AlignMode = "Left"
If AlignMode = "" Then AlignMode = "Left"
Dim AlignPoint As Variant
Dim MovePoint(2) As Double
AlignPoint = ThisDrawing.Utility.GetPoint(, "请选择对起点：")
For Each ent In ss
ent.GetBoundingBox MinPoint, MaxPoint
Select Case AlignMode
Case "Left"
MovePoint(0) = MinPoint(0)
MovePoint(1) = AlignPoint(2)
MovePoint(2) = MinPoint(2)
Case "Middle"
MovePoint(0) = (MinPoint(0) + MaxPoint(0)) / 2
MovePoint(1) = AlignPoint(1)
MovePoint(2) = MinPoint(2)
Case "Right"
MovePoint(0) = MaxPoint(0)
MovePoint(1) = AlignPoint(1)
MovePoint(2) = MaxPoint(2)
End Select
ent.Move MovePoint, AlignPoint
Update
Next
Else
ThisDrawing.Utility.Prompt vbCr & "未选定对象，自动退出……"
End If
End Sub
Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet
Dim ss As AcadSelectionSet
On Error Resume Next
Set ss = ThisDrawing.SelectionSets(ssName)
If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
ss.Clear
Set creatselectionset = ss
End Function
Public Function AddCircle(ByVal ptCen As Variant, ByVal radius As Variant) As Variant
Dim objCir As AcadCircle
Set objCir = ThisDrawing.ModelSpace.AddCircle(ptCen, radius)
Set AddCircle = objCir
End Function
Public Function AddCircleCD(ByVal ptCen As Variant, ByVal diameter As Variant) As AcadCircle
Dim objCir As AcadCircle
Set objCir = ThisDrawing.ModelSpace.AddCircle(ptCen, diameter / 2)
Set AddCircleCD = objCir
End Function
Public Function AddCircle2P(ByVal pt1 As Variant, ByVal pt2 As Variant) As AcadCircle
Dim ptCen(0 To 2) As Double
Dim objCir As AcadCircle
Dim diateter As Double
ptCen(0) = (pt1(0) + pt2(0)) / 2
ptCen(1) = (pt1(1) + pt2(2)) / 2
ptCen(2) = 0
diameter = Sqr((pt2(0) - pt1(0)) ^ 2 + (pt2(1) - pt1(1)) ^ 2)
Set objCir = ThisDrawing.ModelSpace.AddCircle(ptCen, diameter / 2)
Set AddCircle2P = objCir
End Function
Public Function AddCircle3P(ByVal pt1 As Variant, ByVal pt2 As Variant, ByVal pt3 As Variant) As AcadCircle
Dim xysm, xyse, xy As Double
Dim ptCen(0 To 2) As Double
Dim radius As Double
Dim objCir As AcadCircle
xy = pt1(0) ^ 2 + pt1(1) ^ 2
xyse = xy - pt3(0) ^ 2 - pt3(1) ^ 2
xysm = xy - pt2(0) ^ 2 - pt2(1) ^ 2
xy = (pt1(0) - pt2(0)) * (pt1(1) - pt3(1)) - (pt1(0) - pt3(0)) * (pt1(1) - pt2(1))
If Abs(xy) < 0.000001 Then
MsgBox "所输入的参数无法创建圆形"
Exit Function
End If
ptCen(0) = (xysm * (pt1(1) - pt3(1)) - xyse * (pt1(1) - pt2(1))) / (2 * xy)
ptCen(1) = (xyse * (pt1(0) - pt2(0)) - xysm * (pt1(0) - pt3(0))) / (2 * xy)
ptCen(2) = 0
radius = Sqr((pt1(0) - ptCen(0)) * (pt1(0) - ptCen(0)) + (pt1(1) - ptCen(1)) * (pt1(1) - ptCen(1)))
If radius < 0.000001 Then
MsgBox "半径过小！"
Exit Function
End If
Set objCir = ThisDrawing.ModelSpace.addcir(ptCen, radius)
Set AddCircle3P = objCir
End Function
Public Sub TestCircle()
Dim pt1, pt2, pt3 As Variant
Dim radius As Double
pt1 = ThisDrawing.Utility.GetPoint(, "指定圆心：")
radius = ThisDrawing.Utility.GetReal("输入半径：")
AddCircle pt1, radius
pt1 = ThisDrawing.Utility.GetPoint(, "指定圆心：")
radius = ThisDrawing.Utility.GetReal("输入直径：")
AddCircleCD pt1, radius
pt1 = ThisDrawing.Utility.GetPoint(, "输入第一点：")
pt2 = ThisDrawing.Utility.GetPoint(pt1, "输入第二点：")
AddCircle2P pt1, pt2
pt1 = ThisDrawing.Utility.GetPoint(, "输入第一点：")
pt2 = ThisDrawing.Utility.GetPoint(pt1, "输入第二点：")
pt3 = ThisDrawing.Utility.GetPoint(pt2, "输入第三点：")
AddCircle3P pt1, pt2, pt3
End Sub
已解决，谢谢帮助 阿石你这么屌还需要求助吗？ 菜卷鱼 发表于 2020-3-31 09:36
阿石你这么屌还需要求助吗？
算法，要有公式的，帮助的人发了一个公式给我
K码
经纬度
UTM（Universal Transverse Mercator Grid System，通用横墨卡托格网系统）
之间的转换公式
1291500406 发表于 2020-3-31 09:59
算法，要有公式的，帮助的人发了一个公式给我
K码
经纬度
你在学校的时候学的什么？怎么感觉你接触CAD二次开发没多久，但是很屌，是什么渠道学习的，让人佩服，我11年就接触AUTOLISP了，都快10年了还是很菜 本帖最后由 1291500406 于 2020-3-31 10:39 编辑
1.善于利用搜索功能
lisp已经发展二三四十年
我能想到的问题，可能已经有了答案
2.多门语言参考
lisp函数库很缺，很少有人发展函数库
找函数用法：只研究lisp是不够的
vbs vba js 比较接近lisp语法 ，就可以翻译代码
c++就算了哈哈
3.实时编写程序，不断调试运行
我是直接记事本写的，移动到命令行测试结果
时间长了就会默写代码了
不断的找对应参数，用法就可以了
会发现很多出人意料的，比如(vl-string-left-trim"屺""屺╟") 返回"c"
cad很多东西都是通过arx定义的
arx，比较吸引人，我想学一点
语言是c++
我经常会为了一个问题，写到两多点，虽然那样不太好 还不可以看再回帖
页:
[1]