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

linwanglian

今天把，上一个贴子的源码改到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 objText  As 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

Dim objText  As Object
改成
Dim objText  As 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

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

linwanglian

sgwsssxm 发表于 2020-7-24 23:31
Dim objText  As Object
改成
Dim objText  As 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

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

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

sgwsssxm

用.Rotation

linwanglian

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

写好了，感谢

linwanglian

最近想吧这些文字的图层信息一起提取出来，不知道能不能实现。因为不带图层信息提取，写回去的时候文字颜色比较单调。