一种cdr文件提取到excel方法

---

Sub cdrTQ()
'cdrpath = InputBox("请输入cdr文件路径：", "FilePath", "示例：E:\cdrFiles") & "\"
'th_old = InputBox("请输入cdr旧编号(任意一个或多个，以英文逗号分隔):", "th_old ", "")
'arr = Split(th_old, ",")
cdrpath = "E:\cdr\"
'创建新 Excel 工作簿和工作表
Dim excelApp As Object
Dim excelWorkbook As Object
Dim excelWorksheet As Object
Set excelApp = CreateObject("Excel.Application")
Set excelWorkbook = excelApp.Workbooks.Add
Set excelWorksheet = excelWorkbook.Worksheets(1)
'遍历cdr
cdrFile = Dir(cdrpath & "*.cdr")
Do While cdrFile <> ""
Set Doc = OpenDocument(cdrpath & cdrFile)
    For Each pg In ActiveDocument.Pages
            For Each Atext In pg.ActiveLayer.Shapes
                If Atext.Type = cdrTextShape Then
                    i = i + 1
                   excelWorksheet.Cells(i + 1, 1) = Atext.Text.Story.Text
                End If
            Next
    Next
ActiveDocument.Close
cdrFile = Dir
Loop
excelWorkbook.SaveAs cdrpath & "1.xlsx"
excelWorkbook.Close
excelApp.Quit
End Sub