[编程交流] vba自动填充图形寄存器

Public MyTxtStr(0 To 3) As String
Public Cnt As Integer
Public WorkbookOpen As Integer
Public RowCnt As Integer
Public ErrorHandler As Error
Public Excel As Excel.Application
Public ExcelSheet As Object
Public ExcelWorkbook As Object
Public CurrRange As Range
Sub DrgRecivedRegAutoComplete3()
'allows selecting text on screen
'stores the  text  value
Dim MyMTxt As AcadMText
Dim MyoEnt As AcadEntity
Dim MyObjSS As AcadSelectionSet
Dim i As Double
i = 0
'
On Error Resume Next
ThisDrawing.SelectionSets("Selecttext").Delete
On Error Resume Next
       Set MyObjSS = ThisDrawing.SelectionSets.Add("Selecttext") '' create a new selectionset
                 
           
       MyObjSS.SelectOnScreen '' let user select entities interactively
       
           
'      ThisDrawing.Utility.prompt objSS.Count & " entities selected"
          ' ThisDrawing.Utility.GetString True, vbLf & "Enter to continue Escape To Exit"
   
    
       
       MyObjSS.Highlight True
           If MyObjSS.Count = "0" Then GoTo ErrorHandler
       
       For Each MyoEnt In MyObjSS
       
   
       
        
        
          If TypeOf MyoEnt Is AcadMText Then
          
               Set MyMTxt = MyoEnt
            
                   MyTxtStr(i) = MyMTxt.TextString
                       MyObjSS.Highlight False
                         i = i + 1
                         
                        
                         
       
       
           End If
           Next
        
           Cnt = MyObjSS.Count - 1
           
Tranfer2Excel
ErrorHandler:
Close
End Sub
Private Sub Tranfer2Excel()
 If WorkbookOpen = 1 Then GoTo SkipCreatingWorkbook
 
   ' Launch Excel.
   
   
   Set Excel = New Excel.Application
   ' Create a new workbook and find the active sheet.
   Set ExcelWorkbook = Excel.Workbooks.Add
   Set ExcelSheet = Excel.ActiveSheet
   
   ExcelWorkbook.SaveAs "Drawing Register Transfer Sheet.xls"
 
Excel.Visible = True
 
RowCnt = 1
 
     With Worksheets("Sheet1")
   .Select
   .Range("a1").Activate
       End With
   
SkipCreatingWorkbook:
   
    For i = 0 To Cnt
       Set CurrRange = ActiveCell
           CurrRange.Value = MyTxtStr(i)
               CurrRange.Offset(0, 1).Select
   
   Next
   
   RowCnt = RowCnt + 1
   
    With Worksheets("Sheet1")
   .Select
   .Range("a" & RowCnt).Activate
       End With
   
  WorkbookOpen = 1
  
       
   
   DrgRecivedRegAutoComplete3
  ' Excel.Application.Quit
   'Excel.Application.
  
End Sub