linwanglian 发表于 2020-7-24 15:07:08

从EXCELL提取CAD文字和坐标，坐标出错

今天把，上一个贴子的源码改到EXCELL里了，但是运行到坐标的时候，提示错误了。改了好几遍了，都不行。还是请前辈们帮忙看看，问题出在哪里吧。运行到“arrText(lngCount, 2) = Format(.InsertionPoint(0), "0.000000")'Y值坐标'”，这里提示错误。
“property let过程未定义，property get过程未返回对象”
一下是代码

Public Sub Com_Button1_Click()
On Error Resume Next
Set acadApp = GetObject(, "AUTOCAD.APPLICATION")
acadApp.Visible = True
Set acadDoc = acadApp.ActiveDocument
Set Thisdrawing = acadApp.ActiveDocument
If Err Then
Err.Clear
acadApp.WindowState = acMin
Application.WindowState = xlMaximized
MsgBox "此插件只能提取AutoCAD2016版的数据内容" & vbCrLf & "为防止获取CAD对象错误，请将其它版本CAD关闭" & vbCrLf & "请打开要提取的AutoCAD2016进行尝试"
Exit Sub
End If
On Error GoTo 0
Dim SSet As Object
Set SSet = createSSet(Thisdrawing, "AA")
SSet.SelectOnScreen
    Dim lngCount As Long
    Dim arrText() As String
    Dim txtCount As Long

    Dim objEntity As Object

    txtCount = SSet.count
    ReDim arrText(1 To txtCount, 1 To 4)

    Dim objTextAs Object

   For Each objEntity In SSet
      lngCount = lngCount + 1
      Set objText = objEntity

      arrText(lngCount, 1) = objEntity.TextString   '文本字符串值

      With objText
            arrText(lngCount, 2) = Format(.InsertionPoint(0), "0.000000")'Y值坐标'
            arrText(lngCount, 3) = Format(.InsertionPoint(1), "0.000000")   'X值坐标'
            arrText(lngCount, 4) = Format(.InsertionPoint(2), "0.00")       '高程'
      End With
   Next objEntity

   GetTextInsertCoord = arrText


Range("A1").Resize(UBound(arrText), 4) = arrText

    Range("B1:C" & UBound(arrText)).NumberFormatLocal = "0.000000"
   Range("D1:D" & UBound(arrText)).NumberFormatLocal = "0.00"
    Range("A:D").EntireColumn.AutoFit



sgwsssxm 发表于 2020-7-24 23:31:15

Dim objTextAs Object
改成
Dim objTextAs AcadText
或者
arrText(lngCount, 2) = Format(.InsertionPoint(0), "0.000000")
改成
Dim Point() As Double
Point = objText.InsertionPoint
arrText(lngCount, 2) = Format(Point(0), "0.000000")
另外如果文字对齐方式不同，定位点也不一样，不能全用InsertionPoint

sunny_8848 发表于 2020-7-26 19:57:11

支持一下，excel vba的帖子少见

linwanglian 发表于 2020-8-9 10:08:32

sgwsssxm 发表于 2020-7-24 23:31
Dim objTextAs Object
改成
Dim objTextAs AcadText


非常感谢，下面这个更改好用

arrText(lngCount, 2) = Format(.InsertionPoint(0), "0.000000")
改成
Dim Point() As Double
Point = objText.InsertionPoint
arrText(lngCount, 2) = Format(Point(0), "0.000000")

linwanglian 发表于 2020-8-9 14:28:02

sgwsssxm 发表于 2020-7-24 23:31
Dim objTextAs Object
改成
Dim objTextAs AcadText


哥，我想把单行文字的旋转特征导出来，我猜着写了个.TextRotate，好像不对，能告诉我用哪个吗？

sgwsssxm 发表于 2020-8-9 23:09:16

用.Rotation

linwanglian 发表于 2020-8-10 16:35:14

sgwsssxm 发表于 2020-8-9 23:09
用.Rotation

写好了，感谢

linwanglian 发表于 2020-12-18 18:16:12

最近想吧这些文字的图层信息一起提取出来，不知道能不能实现。因为不带图层信息提取，写回去的时候文字颜色比较单调。
页: [1]
查看完整版本: 从EXCELL提取CAD文字和坐标，坐标出错