CAD取点输出到Excel及Txt.docx

Sub CAD取点输出到Excel及Txt()On Error GoTo veno出错转至veno语句后执行Dim xlApp As New Excel.ApplicationDim xlBook As Excel.WorkbookSet xlBook = xlApp.Workbooks.AddDim xlSheet As Excel.WorksheetSet xlSheet = xlBook.Worksheets(sheet1)定义xlApp、xlBook、xlSheet为主程序，工作簿及工作表类型，设置xlBook为xlApp下的工作簿类的实例化对象，设置xlSheet为工作簿xlBook的一个工作表需要在工具菜单中添加MicroSoft Excel 15.0 labrary引用，否则无法运行 Dim ReturnPoint As Variant Dim i As Integer Dim high As Single Dim Ptext, Fname As String Dim skim As Integer Dim textObj As AcadText Dim pointObj As AcadPoint Dim layerObj As AcadLayer Dim drawInCad As Boolean Dim tFname As String Dim eFname As String 以上定义需要用到的变量 i = 0 high = 1 初始化i、high变量，其中i用于计数，high用于设置字体高度 Fname = InputBox(请给出文件名。) Fname返回InputBox弹出时用户输入的数据，该数据为String型，代表输出文件的文件名，本次演示输出坐标为xlsx文件及txt文件类型 If StrPtr(Fname) = 0 Then Exit Sub 若取消则退出过程 Dim skimx As String skimx = Trim(InputBox(请给出小数点后保留几位。) 用户输入skimx的值，skimx代表小数点后保留的位数，须转换为int型。 If skimx = Then skimx = 0 若为空，则默认为“0” skim = CInt(skimx) skim定义为skimx的int型 msrst = MsgBox(是否绘制在模型中？, vbYesNo, 选择是否绘制坐标) msrst返回msgbox的结果 If msrst = vbYes Then drawInCad = True Else drawInCad = False End If 若选是，则drawInCad值为true，代表将坐标值绘制在CAD图纸上 If Fname = Then Fname = LoactionPoints 若用户未输入文件名，则默认为LocationPoints tFname = E: & Fname & .txt eFname = E: & Fname & .xlsx 输出的txt完整目录tFname及xlsx完整目录为eFname，此时设置为E盘，用户亦可设置为其他目录 xlApp.Visible = False 本过程设置excel打开时不可见，为了更好地显性展示，亦可设置为true Set layerObj = ThisDrawing.Layers.Add(PointsData) 添加图层“PointsData”，赋值给layerObj变量 Open tFname For Output As #1 txt输出时打开tFname目录，并命名为文件1 Do ReturnPoint = ThisDrawing.Utility.GetPoint 提示用户自己点取坐标，并返回ReturnPoint i = i + 1 计数器+1,此时第一个为1 If drawInCad = True Then 如果选是，则绘制在Cad模型中 Ptext = i & :( & Round(ReturnPoint(0), skim) & , & Round(ReturnPoint(1), skim) & ) 设置所要绘制的Ptext值，形式为“1:12444,2222”，保留小数点位数由skim决定 Set textObj = ThisDrawing.ModelSpace.AddText(Ptext, ReturnPoint, high) textObj.Layer = PointsData 设置文字的起点为所点取的点位，内容为Ptext,字高为high,并设置为PointsData图层，此时绘制在图中 Set pointObj = ThisDrawing.ModelSpace.AddPoint(ReturnPoint) pointObj.color = acGreen pointObj.Layer = PointsData 同样设置取点处绘制点，并设置会绿色，并入PointsData图层 Else 如果选否，则不绘制在Cad模型中 Set pointObj = ThisDrawing.ModelSpace.AddPoint(ReturnPoint) pointObj.color = acGreen pointObj.Layer = PointsData 此时仅绘制点 End If Print #1, i; Round(ReturnPoint(1), skimx), Round(ReturnPoint(0), skimx) 在文件1中输出点取的点的坐标，由于实际坐标总是与cad坐标xy相反，因此输出时调换位置 xlSheet.Range(A & i) = Round(ReturnPoint(1), skimx) xlSheet.Range(B & i) = Round(ReturnPoint(0), skimx) 设置在工作表中第一行输出xy坐标，同样跟cad图相反 Loop 以上为do.loop循环，取点结束按esc时会返回错误，跳转到veno后的代码段veno: Close #1 关闭文件1 xlApp.ActiveWorkbook.SaveAs eFname 保存excel文件为e