AfraLISP - Learn AutoLISP for AutoCAD productivity

VBA and Excel

by Kenny Ramage

VBA and Excel (85 Kb)

This is a sample VBA routine written for AutoCAD Rel 14. The application will demonstrate how to export data to Microsoft Excel, perform calculations on that data and then re-import the results of the calculations back into AutoCAD.

Material List Tutorial

Usage

Unzip the files matlist.dvb, matlist.lsp, matlist.dwg and matlist.xls to your working directory.
Insert the matlist.Dwg. as a block into any drawing.
It should look like this :

Title Block

Type (load "matlist") at the command prompt.
Type "matlist" to run the application.

(If you have problems when writing or running this projects, ensure that the Microsoft Excel 8.0 Object Library is selected in your VBA References.)

After running the application you can inspect the results of the exported data in the file matlist.xls. It should look something like this :

Title Block

The Source Code

Public acad As Object
Public doc As Object
Public ms As Object
Public ss As Object
Public ssnew As Object
Public Theatts As Variant
Public MsgBoxResp As Integer
'declare global variables
 
Private Sub CommandButton1_Click()
    UpdateAttrib 0, UserForm1.txt1.Text
    UpdateAttrib 1, UserForm1.txt2.Text
    UpdateAttrib 2, UserForm1.txt3.Text
    UpdateAttrib 3, UserForm1.txt4.Text
    UpdateAttrib 4, UserForm1.txt5.Text
    UpdateAttrib 5, UserForm1.txt6.Text
    UpdateAttrib 6, UserForm1.txt7.Text
    UpdateAttrib 7, UserForm1.txt8.Text
    UpdateAttrib 8, UserForm1.txt9.Text
    UpdateAttrib 9, UserForm1.txt10.Text
    UpdateAttrib 10, UserForm1.txt11.Text
    UpdateAttrib 11, UserForm1.txt12.Text
    UpdateAttrib 12, UserForm1.txt13.Text
    UpdateAttrib 13, UserForm1.txt14.Text
    UpdateAttrib 14, UserForm1.txt15.Text
    UpdateAttrib 15, UserForm1.txt16.Text
    UpdateAttrib 16, UserForm1.txt17.Text
    UpdateAttrib 17, UserForm1.txt18.Text
    UpdateAttrib 18, UserForm1.txt19.Text
    UpdateAttrib 19, UserForm1.txt20.Text
    UpdateAttrib 20, UserForm1.txt21.Text
    UpdateAttrib 21, UserForm1.txt22.Text
    UpdateAttrib 22, UserForm1.txt23.Text
    UpdateAttrib 23, UserForm1.txt24.Text
    UpdateAttrib 24, UserForm1.txt25.Text
    UpdateAttrib 25, UserForm1.txt26.Text
    UpdateAttrib 26, UserForm1.txt27.Text
    UpdateAttrib 27, UserForm1.txt28.Text
    UpdateAttrib 28, UserForm1.txt29.Text
    UpdateAttrib 29, UserForm1.txt30.Text
    UpdateAttrib 30, UserForm1.txt31.Text
    UpdateAttrib 31, UserForm1.txt32.Text
    UpdateAttrib 32, UserForm1.txt33.Text
    UpdateAttrib 33, UserForm1.txt34.Text
    UpdateAttrib 34, UserForm1.txt35.Text
    UpdateAttrib 35, UserForm1.txt36.Text
    'get the attribute values
    
    ssnew.Item(0).Update
    'update the attribute block
    
    End
End Sub
Sub UpdateAttrib(TagNumber As Integer, BTextString As String)
  'This Sub Procedure tests the attribute data to check
  'that is not a null value
  
  If BTextString = "" Then
  'if the attribute is empty
  
    Theatts(TagNumber).TextString = ""
    'put a '-' place holder
    
   Else
   'if it is not empty
   
    Theatts(TagNumber).TextString = BTextString
    'use the attribute value
    
  End If
  
End Sub
 
 
Private Sub CommandButton2_Click()
End
End Sub
 
Private Sub CommandButton3_Click()
Dim xlapp As Excel.Application
Dim xlbook As Excel.Workbook
Dim xlsheet As Excel.Worksheet
'declare local variables
 
 
Set xlbook = GetObject("matlist.xls")
'set reference to Excel file
 
Set xlapp = xlbook.Parent
'set reference to workbook
 
xlapp.Visible = True
'make Excel visible
 
xlapp.Windows("MATLIST.XLS").Visible = True
'make the workbook visible
'the 2 preceeding lines can be commented out if you
'do not want to see Excel in action
 
 
Set xlsheet = xlbook.Sheets("SHEET1")
'set reference to the worksheet Sheet1
 
xlsheet.Cells(2, 1) = UserForm1.txt1.Text
xlsheet.Cells(3, 1) = UserForm1.txt8.Text
xlsheet.Cells(4, 1) = UserForm1.txt15.Text
xlsheet.Cells(5, 1) = UserForm1.txt22.Text
xlsheet.Cells(6, 1) = UserForm1.txt29.Text
xlsheet.Cells(2, 2) = UserForm1.txt2.Text
xlsheet.Cells(3, 2) = UserForm1.txt9.Text
xlsheet.Cells(4, 2) = UserForm1.txt16.Text
xlsheet.Cells(5, 2) = UserForm1.txt23.Text
xlsheet.Cells(6, 2) = UserForm1.txt30.Text
xlsheet.Cells(2, 3) = UserForm1.txt3.Text
xlsheet.Cells(3, 3) = UserForm1.txt10.Text
xlsheet.Cells(4, 3) = UserForm1.txt17.Text
xlsheet.Cells(5, 3) = UserForm1.txt24.Text
xlsheet.Cells(6, 3) = UserForm1.txt31.Text
xlsheet.Cells(2, 4) = UserForm1.txt4.Text
xlsheet.Cells(3, 4) = UserForm1.txt11.Text
xlsheet.Cells(4, 4) = UserForm1.txt18.Text
xlsheet.Cells(5, 4) = UserForm1.txt25.Text
xlsheet.Cells(6, 4) = UserForm1.txt32.Text
xlsheet.Cells(2, 5) = UserForm1.txt5.Text
xlsheet.Cells(3, 5) = UserForm1.txt12.Text
xlsheet.Cells(4, 5) = UserForm1.txt19.Text
xlsheet.Cells(5, 5) = UserForm1.txt26.Text
xlsheet.Cells(6, 5) = UserForm1.txt33.Text
xlsheet.Cells(2, 7) = UserForm1.txt7.Text
xlsheet.Cells(3, 7) = UserForm1.txt14.Text
xlsheet.Cells(4, 7) = UserForm1.txt21.Text
xlsheet.Cells(5, 7) = UserForm1.txt28.Text
xlsheet.Cells(6, 7) = UserForm1.txt35.Text
'fill the worksheet cells with the attribute values
 
UserForm1.txt6.Text = xlsheet.Cells(2, 6)
UserForm1.txt13.Text = xlsheet.Cells(3, 6)
UserForm1.txt20.Text = xlsheet.Cells(4, 6)
UserForm1.txt27.Text = xlsheet.Cells(5, 6)
UserForm1.txt34.Text = xlsheet.Cells(6, 6)
UserForm1.txt36.Text = xlsheet.Cells(7, 6)
'retrieve the calculated attribute values
 
xlbook.Close savechanges:=True
'save the changes in Excel
 
xlapp.Quit
'quit Excel
 
Set xlsheet = Nothing
Set xlbook = Nothing
Set axlapp = Nothing
'clean up
 
 
End Sub
 
Private Sub UserForm_Initialize()
 Dim BlkG(0) As Integer
  Dim TheBlock(0) As Variant
  Dim Pt1(0 To 2) As Double
  Dim Pt2(0 To 2) As Double
  'declare local variables
  
 
  Set acad = GetObject(, "AutoCAD.Application")
  'set reference to AutoCAD
  
  Set doc = acad.ActiveDocument
  'set reference to the drawing
  
  Set ms = doc.ModelSpace
  'set reference to model space
  
  Set ssnew = doc.SelectionSets.Add("TBLK")
  'create a selection set
  
  Pt1(0) = 0: Pt1(1) = 0: Pt1(2) = 0
  Pt2(0) = 3: Pt2(1) = 3: Pt2(2) = 0
  'set up the array
  
  BlkG(0) = 2
  'group code 2 for block name
  
  TheBlock(0) = "MATLIST"
  'the name of the attribute block
  
  ssnew.Select 5, Pt1, Pt2, BlkG, TheBlock
  'get the block
  
  If ssnew.Count >= 1 Then
  'if the block is found
  
    Theatts = ssnew.Item(0).GetAttributes
    'get the attributes
    
    UserForm1.txt1.Text = UCase(LTrim(Theatts(0).TextString))
    'get the title attribute
    'clear any leading spaces and
    'convert to uppercase
    
    UserForm1.txt2.Text = UCase(LTrim(Theatts(1).TextString))
    UserForm1.txt3.Text = UCase(LTrim(Theatts(2).TextString))
    UserForm1.txt4.Text = UCase(LTrim(Theatts(3).TextString))
    UserForm1.txt5.Text = UCase(LTrim(Theatts(4).TextString))
    UserForm1.txt6.Text = UCase(LTrim(Theatts(5).TextString))
    UserForm1.txt7.Text = UCase(LTrim(Theatts(6).TextString))
    UserForm1.txt8.Text = UCase(LTrim(Theatts(7).TextString))
    UserForm1.txt9.Text = UCase(LTrim(Theatts(8).TextString))
    UserForm1.txt10.Text = UCase(LTrim(Theatts(9).TextString))
    UserForm1.txt11.Text = UCase(LTrim(Theatts(10).TextString))
    UserForm1.txt12.Text = UCase(LTrim(Theatts(11).TextString))
    UserForm1.txt13.Text = UCase(LTrim(Theatts(12).TextString))
    UserForm1.txt14.Text = UCase(LTrim(Theatts(13).TextString))
    UserForm1.txt15.Text = UCase(LTrim(Theatts(14).TextString))
    UserForm1.txt16.Text = UCase(LTrim(Theatts(15).TextString))
    UserForm1.txt17.Text = UCase(LTrim(Theatts(16).TextString))
    UserForm1.txt18.Text = UCase(LTrim(Theatts(17).TextString))
    UserForm1.txt19.Text = UCase(LTrim(Theatts(18).TextString))
    UserForm1.txt20.Text = UCase(LTrim(Theatts(19).TextString))
    UserForm1.txt21.Text = UCase(LTrim(Theatts(20).TextString))
    UserForm1.txt22.Text = UCase(LTrim(Theatts(21).TextString))
    UserForm1.txt23.Text = UCase(LTrim(Theatts(22).TextString))
    UserForm1.txt24.Text = UCase(LTrim(Theatts(23).TextString))
    UserForm1.txt25.Text = UCase(LTrim(Theatts(24).TextString))
    UserForm1.txt26.Text = UCase(LTrim(Theatts(25).TextString))
    UserForm1.txt27.Text = UCase(LTrim(Theatts(26).TextString))
    UserForm1.txt28.Text = UCase(LTrim(Theatts(27).TextString))
    UserForm1.txt29.Text = UCase(LTrim(Theatts(28).TextString))
    UserForm1.txt30.Text = UCase(LTrim(Theatts(29).TextString))
    UserForm1.txt31.Text = UCase(LTrim(Theatts(30).TextString))
    UserForm1.txt32.Text = UCase(LTrim(Theatts(31).TextString))
    UserForm1.txt33.Text = UCase(LTrim(Theatts(32).TextString))
    UserForm1.txt34.Text = UCase(LTrim(Theatts(33).TextString))
    UserForm1.txt35.Text = UCase(LTrim(Theatts(34).TextString))
    UserForm1.txt36.Text = UCase(LTrim(Theatts(35).TextString))
        
    UserForm1.txt1.SetFocus
    UserForm1.txt1.SelStart = 0
    UserForm1.txt1.SelLength = Len(UserForm1.txt1.Text)
    'set the focus to the drawing title and highlight it
    
  Else
  'if no attribute title block is found
  
   MsgBox "Sorry - No Material List Attributes....", vbCritical, _
    "AfraLisp Tutorial"
   'inform the user that there is no attribute title block
   
    ThisDrawing.SelectionSets("TBLK").Delete
 
   End
   'end the application
   
 End If
 
 ThisDrawing.SelectionSets("TBLK").Delete
 
End Sub

Now create a Module named Tblock :

Sub matlist()
 
UserForm1.Show
 
End Sub