Autocad Custom Drawing Properties From Excel

• 
• Forum
• English Forums
• Programming
• VBA/COM Interop
• Drawing Properties

---

Thread: Drawing Properties

1. 2009-01-30,09:50 PM #1

   

   Member

   ---

   Drawing Properties

   Before I start I would just like to say I am completely new to VBA but once you hear about the things you can achieve with it I can't wait to start.

   The outcome of my first vba code is to automatically produce a drawing register within excel.

   Using Autocad VBA I have managed so far to open excel and produce a standard issue sheet in code

   In AutoCAD within our drawing files we use Custom Fields in the Drawing Properties (Custom) ToolBar.

   These custom fields namely:

   PROJECT1
   PROJECT2
   PROJECT3
   JOB NO

   Put simply : what code would I use to simply place PROJECT1 field into excel field B11.

   ---

2. 2009-01-30,11:17 PM #2

   

   Member

   ---

   Re: Drawing Properties

   I am pretty sure its using 'GetCustomByKey' but I do not know how to use this

   Please can someone help

   Steviee

   ---

3. 2009-01-31,12:00 AM #3

   Re: Drawing Properties

   Search this forum and the developer guide for the SummaryInfo object.
   There is a code sample in the "example" link in the help file.

   ---

4. 2009-01-31,03:16 AM #4

   Re: Drawing Properties

   Originally Posted by steviee

   I am pretty sure its using 'GetCustomByKey' but I do not know how to use this

   Please can someone help

   Steviee

   I don't know who is an author of this code
   Give this a try hope this will get you started
   

   Code:

   '' Request reference to Microsoft Excel XX.X Object Library '' based on macros written by Jeff Mishler Option Explicit '' Modified 10/8/03 to remove early binding and '' include late binding. Now should work with '' any version Excel Function IsExcelRunning() As Boolean     Dim objXL As Object     On Error Resume Next     Set objXL = GetObject(, "Excel.Application")     IsExcelRunning = (Err.Number = 0)     Set objXL = Nothing     Err.Clear End Function  'Changed the way Excel is loaded per suggestion by 'Randall Rath - http://www.vbdesign.net/ 'which also added the "Function IsExcelRunning"  Public Sub WriteCustom()     Dim Value As String     Value = GetCustom("D:\TEST.dwg", _                       "PROJECT1") ' change dwg name and key here     Dim sXlFilNam As String     sXlFilNam = "D:\Test.xls" ' change the existing Excel file name here      '***Begin code from Randall Rath******     Dim oXL As Object     Dim blnXLRunning As Boolean     blnXLRunning = IsExcelRunning()     If blnXLRunning Then         Set oXL = GetObject(, "Excel.Application")     Else         Set oXL = CreateObject("Excel.Application")         oXL.Visible = False         oXL.UserControl = False         oXL.DisplayAlerts = False     End If     '***End code from Randall Rath******     Dim oWb As Object     Dim oWs As Object      Set oWb = oXL.Workbooks.Open(sXlFilNam)      If oWb Is Nothing Then         MsgBox "The Excel file " & sXlFilNam & " not found" & _                "Try again."         GoTo Exit_Here     End If      Set oWs = oWb.Worksheets(1)     oWs.Activate      oWs.Cells(11, 2) = Value     'Or:     ' oWs.Range("B11").Value2 = Value  Exit_Here:     Set oWs = Nothing      oWb.Save: oWb.Close     Set oWb = Nothing      oXL.Quit     Set oXL = Nothing  End Sub  Private Function GetCustom(fileName As String, Key As String) As String     Dim Value As String     Dim doc As AcadDocument     Set doc = ThisDrawing.Application.Documents.Open(fileName)     doc.SummaryInfo.GetCustomByKey Key, Value     doc.Close     Set doc = Nothing     GetCustom = Value End Function

   ~'J'~

   ---

5. 2009-01-31,06:18 PM #5

   

   Member

   ---

   Re: Drawing Properties

   Thank you for your reply, have not manged to implement code into mine.

   All our drawings already have these custom properties already saved. (The last five years worth)

   I have used the code shown below and this scrolls through each custom property and lists them as key & value.

   Code:

   For Index = 0 To ThisDrawing.SummaryInfo.NumCustomInfo - 1 ThisDrawing.SummaryInfo.GetCustomByIndex Index, CustomKey, CustomValue MsgBox "Key = " & CustomKey & vbCrLf & _ "Value = " & CustomValue Next Index

   (Sorry don't know how to wrap code)
   My question is how do I use these values later on.
   ie a= Key Value1
   b=Key Value2

   Hope someone can help

   Last edited by RobertB; 2009-02-02 at 04:56 PM. Reason: Added code tags

   ---

6. 2009-01-31,08:51 PM #6

   Re: Drawing Properties

   You can to store this data in the array
   Try this one instead
   

   Code:

   '' based on macros written by Jeff Mishler Option Explicit '' Modified 10/8/03 to remove early binding and '' include late binding. Now should work with '' any version Excel   Function IsExcelRunning() As Boolean     Dim objXL As Object     On Error Resume Next     Set objXL = GetObject(, "Excel.Application")     IsExcelRunning = (Err.Number = 0)     Set objXL = Nothing     Err.Clear End Function  'Changed the way Excel is loaded per suggestion by 'Randall Rath - http://www.vbdesign.net/ 'which also added the "Function IsExcelRunning"  Public Sub WriteCustoms()     Dim Cust() As String     Dim col As Long     Dim row As Long     Cust = GetCustoms("D:\TEST.dwg")     Dim sXlFilNam As String     sXlFilNam = "D:\TEST.xls"      '***Begin code from Randall Rath******     Dim oXL As Object     Dim blnXLRunning As Boolean     blnXLRunning = IsExcelRunning()     If blnXLRunning Then         Set oXL = GetObject(, "Excel.Application")     Else         Set oXL = CreateObject("Excel.Application")         oXL.Visible = False         oXL.UserControl = False         oXL.DisplayAlerts = False     End If     '***End code from Randall Rath******     Dim oWb As Object     Dim oWs As Object      Set oWb = oXL.Workbooks.Open(sXlFilNam)      If oWb Is Nothing Then         MsgBox "The Excel file " & sXlFilNam & " not found" & _                "Try again."         GoTo Exit_Here     End If      Set oWs = oWb.Worksheets(1)     oWs.Activate     ' write data to Excel     ' headers:     oWs.Cells(row + 1, 1) = "NAME"     oWs.Cells(row + 1, 2) = "VALUE"     For row = 0 To UBound(Cust, 1)         oWs.Cells(row + 2, 1) = Cust(row, 0)         oWs.Cells(row + 2, 2) = Cust(row, 1)     Next          oWs.Columns.autofit  Exit_Here:      Set oWs = Nothing      oWb.Save: oWb.Close     Set oWb = Nothing      oXL.Quit     Set oXL = Nothing      MsgBox "Done"      End Sub   Function GetCustoms(fileName As String) As Variant     Dim Value As String     Dim Cnt As Long     Dim Num As Long     Dim Index As Long     Dim CustomKey As String     Dim CustomValue As String     Dim doc As AcadDocument     Dim Sum As AcadSummaryInfo     Set doc = ThisDrawing.Application.Documents.Open(fileName)     Set Sum = doc.SummaryInfo      Num = Sum.NumCustomInfo     ReDim Cust(0 To Num - 1, 0 To 1) As String     For Index = 0 To Num - 1         Sum.GetCustomByIndex Index, CustomKey, CustomValue         Cust(Cnt, 0) = CustomKey         Cust(Cnt, 1) = CustomValue         Cnt = Cnt + 1     Next Index     doc.Close     Set Sum = Nothing     Set doc = Nothing     GetCustoms = Cust End Function

   ~'J'~

   ---

7. 2009-02-01,07:14 PM #7

   

   Member

   ---

   Re: Drawing Properties

   Thanks again for your reply.

   My lack of VBA knowledge is causing me problems trying to use your code.

   I have attached a *.dwg which has the custom drawing properties I wish to use together with the code I have started.

   The code will start with opening excel and producing a issue sheet but i cannot get the information onto the sheet.

   I would always like this code to reference the current open drawing not any saved drawing.

   Any help would be greatly appreciated.

   Regards
   Steve

   ---

8. 2009-02-01,07:54 PM #8

   Re: Drawing Properties

   If you want to run this code from current drawing
   just change the lower level function:
   

   Code:

   Function GetCurrentCustoms() As Variant     Dim Value As String     Dim Cnt As Long     Dim Num As Long     Dim Index As Long     Dim CustomKey As String     Dim CustomValue As String     Dim Sum As AcadSummaryInfo     Set Sum = ThisDrawing.SummaryInfo      Num = Sum.NumCustomInfo     ReDim Cust(0 To Num - 1, 0 To 1) As String     For Index = 0 To Num - 1         Sum.GetCustomByIndex Index, CustomKey, CustomValue         Cust(Cnt, 0) = CustomKey         Cust(Cnt, 1) = CustomValue         Cnt = Cnt + 1     Next Index      Set Sum = Nothing     GetCustoms = Cust End Function

   And also change these lines in the main procedure:
   

   Code:

   Public Sub WriteCustoms()     Dim Cust() As String     Dim col As Long     Dim row As Long     Cust = GetCustoms("D:\TEST.dwg")

   on the following one:
   

   Code:

   Public Sub WriteCustoms()     Dim Cust() As String     Dim col As Long     Dim row As Long     Cust = GetCurrentCustoms() '..the rest code still the same

   Let me know if I don't understand your question

   ~'J'~

   ---

9. 2009-02-01,08:28 PM #9

   

   Member

   ---

   Re: Drawing Properties

   Thanks very much for your help - Got it to work perfectly.

   Stevie

   ---

10. 2009-02-01,09:01 PM #10

    Re: Drawing Properties

    Glad if that helps
    Happy computing
    Cheers

    ~'J'~

    ---

• 
• Forum
• English Forums
• Programming
• VBA/COM Interop
• Drawing Properties

---

Similar Threads

1. Replies: 2

   Last Post: 2008-06-10, 01:28 PM

2. Replies: 3

   Last Post: 2008-05-30, 06:32 PM

3. Replies: 2

   Last Post: 2008-04-24, 11:38 AM

4. Replies: 2

   Last Post: 2007-10-11, 07:12 PM

5. Replies: 8

   Last Post: 2006-12-12, 12:20 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

• BB code is On
• Smilies are On
• [IMG] code is On
• [VIDEO] code is On
• HTML code is Off

Forum Rules

byrdshenctuders.blogspot.com

Source: https://forums.augi.com/showthread.php?94942-Drawing-Properties

Share this post