CAD+VBA 实现图块的旋转平移缩放和拼接

前言
一、需求
二、实现步骤
- 1.识别文件中的正确的坐标信息
- 2.选择图块上的角点，计算正确坐标信息与正确角点坐标之间的平移旋转参数，并进行平移旋转,加入缩放0.001倍
- 3.选择2图块复制，之后另存在另一个CAD中
- 4.其他实用函数，可能用到的
总结

提示：文章写完后，目录可以自动生成，如何生成可参考右边的帮助文档

文章目录

前言
一、需求
二、实现步骤
- 1.识别文件中的正确的坐标信息
- 2.选择图块上的角点，计算正确坐标信息与正确角点坐标之间的平移旋转参数，并进行平移旋转,加入缩放0.001倍
- 3.选择2图块复制，之后另存在另一个CAD中
- 4.其他实用函数，可能用到的
总结

前言

提示：这里可以添加本文要记录的大概内容：
例如：随着人工智能的不断发展，机器学习这门技术也越来越重要，很多人都开启了学习机器学习，本文就介绍了机器学习的基础内容。

提示：以下是本篇文章正文内容，下面案例可供参考

一、需求

大概有80几个CAD文件里面的图块位置不对，其标示的坐标是正确的，但是实际位置并不对，存在平移旋转缩放的问题。并且这些有问题的图块需要整合至一个CAD 文件中，目前针对这个需求进行一个思路实现整理。

二、实现步骤

1.识别文件中的正确的坐标信息

目前参考的是

https://blog.csdn.net/end1n9/article/details/112801674

此处实现了对选择的文本数据进行输出，并存出了一个txt文件

还需更改成将识别的坐标提取出来

Sub AcadGetText()Dim sset As AcadSelectionSet   '声明定义选择集Dim ent As AcadEntity          '声明实体Dim fso, fDim filename As String         '声明文件字符串Dim str As StringDim pp(0 To 1) As Doublefilename = "d:/output.txt"Do While ThisDrawing.SelectionSets.Count > 0ThisDrawing.SelectionSets.Item(0).DeleteLoopSet sset = ThisDrawing.SelectionSets.Add("sst")  '添加选择集sset.SelectOnScreen                              '在屏幕上选择对象Set fso = CreateObject("Scripting.FileSystemObject")Set f = fso.OpenTextFile(filename, 8, True)' 可能选取到非文本，所以。。。On Error Resume NextFor i = 0 To sset.Count - 1str = sset(i).TextStringpp(i) = Val(str)'转换成doubleNextMsgBox pp(0) & pp(1)'For Each ent In sset'str = ""'str = str & ent.TextString & Chr(10)'str = ent.TextString'pp = Val(str)'MsgBox pp'If str <> "" Then f.WriteLine str' Nextf.CloseEnd Sub

2.选择图块上的角点，计算正确坐标信息与正确角点坐标之间的平移旋转参数，并进行平移旋转,加入缩放0.001倍

下面基本实现了平移和旋转

Sub AcadGetText()Dim objEntity As AcadEntity
Dim pt As VariantDim point1 As VariantDim point2 As VariantDim point3 As VariantDim point4 As VariantDim basepoint  As VariantDim rotationangle As VariantDim angle1 As VariantDim angle2 As VariantDim topoint As VariantDim copyEntity As AcadEntity'利用 p1,p2形成的要旋转的直线和P3,P4形成的直线之间的夹角，将其p1p2直线旋转至p3p4直线
point1 = ThisDrawing.Utility.GetPoint(, "请选择点1：")
point2 = ThisDrawing.Utility.GetPoint(, "请选择点2：")'最后就是说p3p4为地图坐标
point3 = ThisDrawing.Utility.GetPoint(, "请选择点3：")
point4 = ThisDrawing.Utility.GetPoint(, "请选择点4：")
angle1 = Atn((point1(1) - point2(1)) / (point1(0) - point2(0)))
angle2 = Atn((point3(1) - point4(1)) / (point3(0) - point4(0)))'MsgBox angle1
'MsgBox angle2ThisDrawing.Utility.GetEntity objEntity, pt, "选择图元:"
basepoint = ThisDrawing.Utility.GetPoint(, "请选择基点(必须为X值小的位置）：")topoint = point3rotationangle = angle2 - angle1Set copyEntity = objEntity.copy()copyEntity.Rotate basepoint, rotationangle'旋转copyEntity.Move basepoint, topoint'平移copyEntity.ScaleEntity topoint, 0.001 '缩放0.001,就是改单位，从mm变成mEnd Sub

3.选择2图块复制，之后另存在另一个CAD中

4.其他实用函数，可能用到的


zoomextents'显示整个图形''打开新的文件dwgName = "d:\all.dwg"If Dir(dwgName) <> "" ThenThisDrawing.Application.Documents.Open dwgNameElseMsgBox "File " & dwgName & " does not exist."End If''

总结

基本实现了，就是没搞另存为
明天改吧。整体的代码如下

Sub AcadGetText()Dim objEntity As AcadEntity
Dim pt As VariantDim point1 As VariantDim point2 As VariantDim point3(0 To 1) As DoubleDim point4(0 To 1) As DoubleDim basepoint  As VariantDim rotationangle As VariantDim angle1 As VariantDim angle2 As VariantDim topoint(0 To 2) As DoubleDim copyEntity As AcadEntityDim sset As AcadSelectionSet   '声明定义选择集Dim ent As AcadEntity          '声明实体Dim str As String'利用 p1,p2形成的要旋转的直线和P3,P4形成的直线之间的夹角，将其p1p2直线旋转至p3p4直线
point1 = ThisDrawing.Utility.GetPoint(, "请选择点1：")
point2 = ThisDrawing.Utility.GetPoint(, "请选择点2：")'从图中识别出来坐标值Do While ThisDrawing.SelectionSets.Count > 0ThisDrawing.SelectionSets.Item(0).DeleteLoopSet sset = ThisDrawing.SelectionSets.Add("sst")  '添加选择集sset.SelectOnScreen                              '在屏幕上选择对象For i = 0 To 1str = sset(i).TextStringstr1 = sset(i + 2).TextStringpoint3(i) = Val(str)point4(i) = Val(str1)Nextangle1 = Atn((point1(1) - point2(1)) / (point1(0) - point2(0)))
angle2 = Atn((point3(1) - point4(1)) / (point3(0) - point4(0)))ThisDrawing.Utility.GetEntity objEntity, pt, "选择图元:"
basepoint = ThisDrawing.Utility.GetPoint(, "请选择基点(必须为X值小的位置）：")
topoint(0) = point3(0)
topoint(1) = point3(1)
topoint(2) = 0rotationangle = angle2 - angle1Set copyEntity = objEntity.copy()copyEntity.Rotate basepoint, rotationanglecopyEntity.Move basepoint, topointcopyEntity.ScaleEntity topoint, 0.001 '缩放0.001,就是改单位，从mm变成mEnd Sub

【工作需要】CAD+VBA 实现图块的旋转平移缩放和拼接相关推荐

CAD图块编辑：CAD软件中图块转化命令怎么用？
在使用国产CAD制图软件绘制建筑图纸的过程中,有些时候会需要进行CAD图块编辑,比如图块转化.那么接下来的CAD教程就让小编来给大家介绍一下国产CAD制图软件--浩辰CAD建筑软件中CAD图块编辑之图 ...
CAD软件中图块转化命令怎么用？
在使用国产CAD制图软件绘制建筑图纸的过程中,有些时候会需要进行CAD图块编辑,比如图块转化.那么接下来的CAD教程就让小编来给大家介绍一下国产CAD制图软件--浩辰CAD建筑软件中CAD图块编辑之图 ...
建筑CAD图库之图块输出的格式有哪些？
在使用正版CAD软件绘制图纸的过程中,有些时候会使用到建筑CAD图库中的相关图块,那么如果将这些图块输出会有哪些格式呢?接下来的CAD教程就让小编来给大家分享一下正版CAD软件--浩辰CAD建筑软件中 ...
为什么CAD软件中图块插入时无法分开设置XYZ轴比例？
在使用浩辰CAD软件绘制图纸的过程中,插入图块时可以设置XYZ轴统一比例,也可以取消勾选"统一比例"分别设置XY轴的比例,但有时候插入图块时 "统一比例"选项是 ...
梦想CAD控件图块COM接口知识点
梦想CAD控件图块COM接口知识点图块是将多个实体组合成一个整体,并给这个整体命名保存,在以后的图形编辑中图块就被视为一个实体.一个图块包括可见的实体如线.圆.圆弧以及可见或不可见的属性数据.图块的 ...
CAD怎么删除图块注释？删除CAD图块注释步骤
CAD设计过程中,有时候会在图纸中添加许多注释,如:文字注释,图块注释,标注样式注释等.当需要删除图纸中的CAD图块注释时,你知道该如何操作吗?本节课程小编就来给大家分享一下浩辰CAD软件中删除CAD ...
CAD中怎么修改图块名称？CAD图块改名教程
在使用正版CAD软件绘制建筑图纸的过程中,进行CAD图块编辑的时候偶尔需要给图块改名,这个时候该如何操作呢?下面的CAD教程就让小编来给大家介绍一下正版CAD软件--浩辰CAD建筑软件中CAD图块编辑 ...
CAD中 OLE不能旋转_CAD入门学习技巧：图块的各种相关操作和概念汇总（下）
上篇文章中我们介绍了CAD软件中关于图块的相关操作和概念,本文我们将继续接介绍图块相关知识,让刚开始进行CAD入门学习的小伙伴对CAD图块有更全面的了解,这样在使用CAD软件绘图的时候也能更加得心应手 ...
CAD如何统计各类数据？CAD图块/文字/面积统计教程
在CAD绘图过程中,我们常常需要统计各类数据,如楼层门窗数量.不同设备名称数量.花卉植物面积.某一区域周长等信息.那么浩辰CAD软件中怎么统计CAD图块.文字及面积周长呢? 无需安装繁琐的插件,浩辰C ...

【工作需要】CAD+VBA 实现图块的旋转平移缩放和拼接