Results 1 to 4 of 4

Thread: today i write code: select one column cad text, then turn to excel

  1. #1
    Member
    Join Date
    2013-02
    Posts
    17
    Login to Give a bone
    0

    Default today i write code: select one column cad text, then turn to excel


    '--------------------------------------------
    Code:
      '定义模块及变量
    Public xlApp As Excel.Application 'Excel对象
    Public xlBook As Excel.Workbook '工作簿
    Public xlsheet As Excel.Worksheet '工作表
    Public tmpcol As String
    Public n As Integer
    
    
    Sub CommandButton1_Click()
    
    
    Me.Hide
    
    
    '公共变量值。
      
    tmpcol = Label1.Caption
    
    
    n = 0
    
    
      '定义过程及变量。
    Dim docA As AcadDocument
    
    
    Dim SLST As AcadSelectionSet
    
    
    Set docA = Application.ActiveDocument
    
    
    docA.Activate
    
    
    For Each SLST In docA.SelectionSets
    
    
       If SLST.name = "qq" Then SLST.Delete: Exit For
    
    
    Next
    
    
    Set SLST = docA.SelectionSets.add("qq")
    
    
    SLST.SelectOnScreen
    
    
    Dim str(), pntys() As String
    
    
    ReDim str(0 To SLST.count - 1): ReDim pntys(0 To SLST.count - 1)
    
    
    Dim pnty As Variant
    
    
    Dim k As Integer: k = 0
    
    
    'Dim txt As AcadEntity
    
    
    For Each txt In SLST
    
    
     'If txt.EntityName = "AcDbText" Or "AcDbMText" Then
     
       str(k) = txt.TextString
      
       pnty = txt.InsertionPoint
       
       pntys(k) = CStr(pnty(1))
       
       k = k + 1
       
     'End If
     
    Next
    
    
    Call 粘贴(str, pntys)
       
    End Sub
    
    
    
    
    
    
       '定义模块级别变量
    'Public xlApp As Excel.Application 'Excel对象
    'Public xlBook As Excel.Workbook '工作簿
    'Public xlsheet As Excel.Worksheet '工作表
    'Public tmpcol As String
    'Public n As Integer
    
    
    'Sub CommandButton1_Click()
    
    
    'Me.Hide
    
    
    'Dim m, g As Integer: g = 0
    
    
    'Dim singlecol1() As String: Dim singlecol2() As String
    
    
    'm = ThisDrawing.Utility.GetInteger("输入将要选择的列数")
    
    
    '公共变量值。
      
    'tmpcol = Label1.Caption
    
    
    'n = 0
    
    
      '定义过程级别变量。
    'Dim str, pntys As String: str = "": pntys = ""
      
    'Dim docA As AcadDocument
    
    
    'Dim SLST As AcadSelectionSet
    
    
    'Set docA = Application.ActiveDocument
    
    
    'docA.Activate
    
    
    'Dim pnty As Variant
    
    
    'Dim txt As AcadEntity
    
    
      '选择几个列
    'For h = 1 To m
    
    
    'For Each SLST In docA.SelectionSets
    
    
       'If SLST.name = "qq" Then SLST.Delete: Exit For
    
    
    'Next
    
    
    'Set SLST = docA.SelectionSets.add("qq")
    
    
    'SLST.SelectOnScreen
    
    
    'For Each txt In SLST
    
    
       'str = str & "," & txt.TextString
      
       'pnty = txt.InsertionPoint
       
       'pntys = pntys & "," & CStr(pnty(1))
       
    'Next
    
    
       'str = str & "Y"
       
       'pntys = pntys & "Y"
       
       'g = g + SLST.count - 1
       
    'Next
    
    
      '分列
    'singlecol1 = Split(str, "Y")
    
    
    'singlecol2 = Split(pntys, "Y")
    
    
    'For k = 0 To UBound(singlecol1)
    
    
        '分列
        'Dim strarr() As String: Dim pntysarr() As String
       
        'strarr = Split(singlecol1(k), ",")
    
    
        'pntysarr = Split(singlecol2(k), ",")
        
        'Call 粘贴(strarr, pntysarr)
    
    
    'Next
    
    
    'Call 粘贴字符串(str, pntys)
       
    'End Sub
    
    
    
    
    Function 粘贴(ByRef rng1(), ByRef rng2() As String)
    
    
     Set xlApp = CreateObject("Excel.Application")
    
    
     Set xlBook = xlApp.Workbooks.Open("C:\Book1.xls")
     
     'Set xlbook = Excel.Workbooks.Open(Excel.ThisWorkbook.Path & Excel.ThisWorkbook.name)
    
    
     Set xlBook = xlApp.Workbooks.add      '新建EXCEL工件簿文件。
     
     'Set xlbook = Excel.Workbooks         '不用open add的方法。
      
     'Set xlsheet = Excel.Worksheets       '不用open add的方法。
    
    
     xlApp.Visible = True                  '设置EXCEL对象可见(或不可见)。
    
    
     Set xlsheet = xlBook.Sheets("Sheet1") '设置活动工作表。
     
     xlsheet.Activate
     
     xlBook.RunAutoMacros (xlAutoOpen)     '运行EXCEL启动宏。
    
    
     tmpcol = Chr(Asc(tmpcol) + n)
     
     'Label1.Caption = tmpcol
     
     'tmpcol = Chr(Asc(tmpcol) + 1)
    
    
     'MsgBox tmpcol
     
     For k = 0 To UBound(rng1)
    
    
     addr1 = tmpcol & CStr(k + 1)
      
     'MsgBox addr1
      
     xlsheet.Range(addr1) = rng1(k)
     
     xlsheet.Range(addr1).HorizontalAlignment = Excel.xlCenter  '粘到CAD的文字居中。
     
     addr2 = Chr(Asc(tmpcol) + 1) & CStr(k + 1)
    
    
     'MsgBox tmpcol
     
     'MsgBox addr2
     
     xlsheet.Range(addr2) = rng2(k)
     
     xlsheet.Range(addr2).Font.color = vbGreen  '坐标设成绿色。
     
     xlsheet.Range(addr2).Font.Bold = True '坐标设成粗体。
     
     
     Next
     
     xlBook.RunAutoMacros (xlAutoClose)    '运行EXCEL关闭宏。
     
     'xlapp.Run Macro2
     
     'xlapp.Workbooks.Close
    
    
     Set xlApp = Nothing
     
    End Function
    
    
    Function 粘贴字符串(ByVal rng1, ByVal rng2 As String)
    
    
     Set xlApp = CreateObject("Excel.Application")
    
    
     Set xlBook = xlApp.Workbooks.Open("C:\Book1.xls")
     
     'Set xlbook = Excel.Workbooks.Open(Excel.ThisWorkbook.Path & Excel.ThisWorkbook.name)
    
    
     Set xlBook = xlApp.Workbooks.add      '新建EXCEL工件簿文件。
     
     'Set xlbook = Excel.Workbooks         '不用open add的方法。
      
     'Set xlsheet = Excel.Worksheets       '不用open add的方法。
    
    
     xlApp.Visible = True                  '设置EXCEL对象可见(或不可见)。
    
    
     Set xlsheet = xlBook.Sheets("Sheet1") '设置活动工作表。
     
     xlsheet.Activate
     
     xlBook.RunAutoMacros (xlAutoOpen)     '运行EXCEL启动宏。
    
    
     tmpcol = Chr(Asc(tmpcol) + n)
     
     'Label1.Caption = tmpcol
     
     'tmpcol = Chr(Asc(tmpcol) + 1)
    
    
     'MsgBox tmpcol
     
     
    
    
     addr1 = tmpcol & CStr(k + 1)
      
     'MsgBox addr1
      
     xlsheet.Range(addr1) = rng1
     
     xlsheet.Range(addr1).HorizontalAlignment = Excel.xlCenter  '粘到CAD的文字居中。
     
     addr2 = Chr(Asc(tmpcol) + 1) & CStr(k + 1)
    
    
     'MsgBox tmpcol
     
     'MsgBox addr2
     
     xlsheet.Range(addr2) = rng2
     
     xlsheet.Range(addr2).Font.color = vbGreen  '坐标设成绿色。
     
     xlsheet.Range(addr2).Font.Bold = True '坐标设成粗体。
     
     
     
     
     xlBook.RunAutoMacros (xlAutoClose)    '运行EXCEL关闭宏。
     
     'xlapp.Run Macro2
     
     'xlapp.Workbooks.Close
    
    
     Set xlApp = Nothing
     
    End Function
    Attached Images Attached Images
    Last edited by Ed Jobe; 2015-10-15 at 10:38 PM.

  2. #2
    Administrator Ed Jobe's Avatar
    Join Date
    2000-11
    Location
    Turlock, CA
    Posts
    5,656
    Login to Give a bone
    0

    Default Re: today i write code: select one column cad text, then turn to excel

    Did you have a question?
    C:> ED WORKING....

  3. #3
    Member
    Join Date
    2013-02
    Posts
    17
    Login to Give a bone
    0

    Default Re: today i write code: select one column cad text, then turn to excel

    thanks ed版主,程序不适合用于工作,而是通过练习使我熟悉了vba的模块级变量和过程级别变量,public与sub关系,及excel的代码。

  4. #4
    Member
    Join Date
    2013-02
    Posts
    17
    Login to Give a bone
    0

    Default Re: today i write code: select one column cad text, then turn to excel

    my upload gif picture,it can play. why it do not play ?

Similar Threads

  1. Replies: 12
    Last Post: 2014-03-04, 02:21 PM
  2. Replies: 5
    Last Post: 2013-10-16, 05:39 PM
  3. CP13-3: Learn to Write Code Like the Gurus
    By Autodesk University in forum Customization and Programming
    Replies: 0
    Last Post: 2013-04-17, 04:15 AM
  4. write *.ctb to excel spreadsheet
    By Sheri_in_CA in forum AutoCAD Plotting
    Replies: 2
    Last Post: 2011-10-04, 04:47 PM
  5. Replies: 10
    Last Post: 2007-10-09, 01:11 PM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •