New to VBA - AutoCad-Excel question

[david.hughes]

If I am asking a question already posted, I'd appreciate being pointed in the right direction. I am learning VBA through online examples and tutorials, and have gotten to where I am picking objects in AutoCAD and putting certain of those object's properties into a cell in a new Excel worksheet. My goal is to be able to pick an object in AutoCAD and put a certain property into a cell in an Excel template file. I know I am close, but I need a little nudge.

Regards,

Dave

[rkmcswain]

Not sure what you have looked at so far, but in case you haven't seen the tutorials by dave-espinosa aguilar, parts 1-6 can be found here [ http://usa.autodesk.com/adsk/servlet...112&id=2253435 ] (scroll down about 3/4 of the page)

Also, if you are interested in a finished product, you might take a look at AutoCELL from Dotsoft [ http://www.dotsoft.com/autocell.htm ]

[fixo]

If I am asking a question already posted, I'd appreciate being pointed in the right direction. I am learning VBA through online examples and tutorials, and have gotten to where I am picking objects in AutoCAD and putting certain of those object's properties into a cell in a new Excel worksheet. My goal is to be able to pick an object in AutoCAD and put a certain property into a cell in an Excel template file. I know I am close, but I need a little nudge.

Regards,

Dave

Hi Dave
see this simple example without any comments,
this will get some lightweightpolyline properties

Option Explicit
Public Excel As Object
Public ExcelWorkbook As Object
Public ExcelSheet As Object
'\\' to write LWPOLYLINE properties to Excell
Sub WriteProps2Excel()
Dim plineObj As AcadEntity
Dim basepnt As Variant
Dim oProps As Variant

On Error GoTo WhereIsProblem
ThisDrawing.Utility.GetEntity plineObj, basepnt, vbCr & "Select polyline :"
Dim props As Variant
If TypeOf plineObj Is AcadLWPolyline Then
ReDim oProps(4, 1)
With plineObj
oProps(0, 0) = "Layer": oProps(0, 1) = .Layer
oProps(1, 0) = "Color": oProps(1, 1) = .color
oProps(2, 0) = "Linetype": oProps(2, 1) = .Linetype
oProps(3, 0) = "LinetypeScale": oProps(3, 1) = .LinetypeScale
oProps(4, 0) = "Lineweight": oProps(4, 1) = .Lineweight
'\\' etc...
End With
Else
MsgBox "This is not a polyline"
Exit Sub
End If
    Dim ColNum As Integer
    Dim RowNum As Integer

  On Error Resume Next
  Set Excel = GetObject(, "Excel.Application")
  If Err <> 0 Then
    Err.Clear
    Set Excel = CreateObject("Excel.Application")
    If Err <> 0 Then
      MsgBox "Could not start Excel!", vbCritical
      End
    End If
  End If
  Excel.Visible = True
  Set ExcelWorkbook = Excel.Workbooks.Add
  Set ExcelSheet = ExcelWorkbook.Worksheets(1)
  ExcelSheet.Name = "Lwpolyline Properties"

ColNum = 2
For RowNum = 1 To UBound(oProps, 1) + 1
ExcelSheet.Cells(RowNum, ColNum - 1).Value = CStr(oProps(RowNum - 1, 0))
ExcelSheet.Cells(RowNum, ColNum).Value = CStr(oProps(RowNum - 1, 1))
Next RowNum
WhereIsProblem:
MsgBox Err.Description

End Sub

f.

[david.hughes]

Not sure what you have looked at so far, but in case you haven't seen the tutorials by dave-espinosa aguilar, parts 1-6 can be found here [ http://usa.autodesk.com/adsk/servlet...112&id=2253435 ] (scroll down about 3/4 of the page)

Also, if you are interested in a finished product, you might take a look at AutoCELL from Dotsoft [ http://www.dotsoft.com/autocell.htm ]

I did see those tutorials - thanks - thats what got me started, in fact. The next step for me is to call for a specific excel file (i.e. "example.xlt" ) from the VBA routine, as opposed to just calling for a new file. Any ideas?

[david.hughes]

Thanks for that example. Looks similar to the Espinosa tutorial examples. Which part would I modify to call for a specific excel template file as opposed to just a new worksheet?

Regards,

Dave

[fixo]

Thanks for that example. Looks similar to the Espinosa tutorial examples. Which part would I modify to call for a specific excel template file as opposed to just a new worksheet?

Regards,

Dave

Hi again

Here are 2 examles on this theme:

The first one will open template file to write data
after program would ended you need to save it manually

The fsecond one allows to user automatically save a file
in the same folder where is located current drawing

Hope this helps

f.

Option Explicit

Public Excel As Object
Public ExcelWorkbook As Object
Public ExcelSheet As Object
'\\' to write LWPOLYLINE properties to Excell
Sub WriteProps2Excel2()
Dim plineObj As AcadEntity
Dim basepnt As Variant
Dim oProps As Variant

On Error GoTo WhereIsProblem
ThisDrawing.Utility.GetEntity plineObj, basepnt, vbCr & "Select polyline :"
Dim props As Variant
If TypeOf plineObj Is AcadLWPolyline Then
ReDim oProps(4, 1)
With plineObj
oProps(0, 0) = "Layer": oProps(0, 1) = .Layer
oProps(1, 0) = "Color": oProps(1, 1) = .color
oProps(2, 0) = "Linetype": oProps(2, 1) = .Linetype
oProps(3, 0) = "LinetypeScale": oProps(3, 1) = .LinetypeScale
oProps(4, 0) = "Lineweight": oProps(4, 1) = .Lineweight
'\\' etc...
End With
Else
MsgBox "This is not a polyline"
Exit Sub
End If
    Dim ColNum As Integer
    Dim RowNum As Integer

  On Error Resume Next
  Set Excel = GetObject(, "Excel.Application")
  If Err <> 0 Then
    Err.Clear
    Set Excel = CreateObject("Excel.Application")
    If Err <> 0 Then
      MsgBox "Could not start Excel!", vbCritical
      End
    End If
  End If
  Excel.Visible = True
  Set ExcelWorkbook = Excel.Workbooks.Add
  Set ExcelWorkbook = Excel.Workbooks.Open("C:\Documents and Settings\admin\Application Data\Microsoft\&#216;&#224;&#225;&#235;&#238;&#237;&#251;\Ptable.xlt")
  Set ExcelSheet = ExcelWorkbook.Worksheets(1)
  ExcelSheet.Name = "Lwpolyline Properties"

ColNum = 2
For RowNum = 1 To UBound(oProps, 1) + 1
ExcelSheet.Cells(RowNum, ColNum - 1).Value = CStr(oProps(RowNum - 1, 0))
ExcelSheet.Cells(RowNum, ColNum).Value = CStr(oProps(RowNum - 1, 1))
Next RowNum
WhereIsProblem:
MsgBox Err.Description

End Sub

Option Explicit
Public Excel As Object
Public ExcelWorkbook As Object
Public ExcelSheet As Object
'\\' to write LWPOLYLINE properties to Excell
Sub WriteProps2Excel3()
Dim plineObj As AcadEntity
Dim basepnt As Variant
Dim oProps As Variant

On Error GoTo WhereIsProblem
ThisDrawing.Utility.GetEntity plineObj, basepnt, vbCr & "Select polyline :"
Dim props As Variant
If TypeOf plineObj Is AcadLWPolyline Then
ReDim oProps(4, 1)
With plineObj
oProps(0, 0) = "Layer": oProps(0, 1) = .Layer
oProps(1, 0) = "Color": oProps(1, 1) = .color
oProps(2, 0) = "Linetype": oProps(2, 1) = .Linetype
oProps(3, 0) = "LinetypeScale": oProps(3, 1) = .LinetypeScale
oProps(4, 0) = "Lineweight": oProps(4, 1) = .Lineweight
'\\' etc...
End With
Else
MsgBox "This is not a polyline"
Exit Sub
End If
     Dim fName As String
    Dim ColNum As Integer
    Dim RowNum As Integer

  On Error Resume Next
  Set Excel = GetObject(, "Excel.Application")
  If Err <> 0 Then
    Err.Clear
    Set Excel = CreateObject("Excel.Application")
    If Err <> 0 Then
      MsgBox "Could not start Excel!", vbCritical
      End
    End If
  End If
  Excel.Visible = True
  Set ExcelWorkbook = Excel.Workbooks.Add
  Set ExcelSheet = ExcelWorkbook.Worksheets(1)
  fName = ThisDrawing.GetVariable("DWGPREFIX")
  fName = fName & ThisDrawing.GetVariable("DWGNAME")
  fName = Left$(fName, Len(fName) - 4) & ".xls"
  ExcelWorkbook.SaveAs fName
  ExcelWorkbook.Close
  
  Set ExcelWorkbook = Excel.Workbooks.Open(fName)
  Set ExcelSheet = ExcelWorkbook.Worksheets(1)
  Excel.DisplayAlerts = False
  ExcelSheet.Name = "Lwpolyline Properties"

ColNum = 2
For RowNum = 1 To UBound(oProps, 1) + 1
ExcelSheet.Cells(RowNum, ColNum - 1).Value = CStr(oProps(RowNum - 1, 0))
ExcelSheet.Cells(RowNum, ColNum).Value = CStr(oProps(RowNum - 1, 1))
Next RowNum
Set ExcelSheet = Nothing
ExcelWorkbook.Close SaveChanges:=True
Set ExcelWorkbook = Nothing
Excel.Quit
Set Excel = Nothing

WhereIsProblem:
MsgBox Err.Description

End Sub