Reading Properties of Dwg via VB

[Anonymous]

Hello,

i am very new to this site and new wiht autocad. I am using Autocad 2007. I am trying to read the properties of a draing (draing revision, issue date, title1 etc). I got a code which actulay open the dwg file then I need to select the block then it reads the value. What I want to do is wihtoput opening the dwg file i want to read all the properties and display in to a grid.
Could any body help me how to do that. I will be really greatful to all of you.

my emailID is mmhusain@gmail.com. Please give me some example.

Thank you.
Murad

[Anonymous]

Please can any body help me. Its a exiting project, urgently needed the solution

Thanks

[Anonymous]

This will read the drawing properties
in folder you need
Just do not run this code from the
same folder where you'll working


Option Explicit
'' Requires:
'' AutoCAD/ObjectDBX Common 17.0 Type Library (for A2007)
'' Microsoft Scripting Runtime


Public Function BrowseForFolderF(ByVal msg As String) As String
Dim oBrowser, folderObj, folderAcpt As Object
Dim folderStr As String

Set oBrowser = ThisDrawing.Application.GetInterfaceObject("Shell.Application")
Set folderAcpt = oBrowser.BrowseForFolder(vbOKOnly, msg, vbDefaultButton3, 0)

With folderAcpt
Set folderObj = .Self
folderStr = folderObj.Path
End With
Set folderObj = Nothing
Set folderAcpt = Nothing
Set oBrowser = Nothing
BrowseForFolderF = folderStr

End Function

Public Function CheckFolder(ByVal strPath As String) As Variant
Dim objFolder ''As Scripting.Folder
Dim objFile ''As Scripting.File
Dim objSubdirs ''As Scripting.Folders
Dim objLoopFolder ''As Scripting.Folder
Dim varFs() As Variant
Dim m_objFSO, n, m_lngFileCount

Set m_objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = m_objFSO.GetFolder(strPath)
'
' Check files in this directory
'
n = -1
For Each objFile In objFolder.Files
If UCase$(Right$(objFile.ShortPath, 4)) = ".DWG" Then
m_lngFileCount = m_lngFileCount + 1
n = n + 1
ReDim Preserve varFs(n)
varFs(n) = objFile.Path
End If
Next objFile

' Loop through all subdirectories and
' do the same thing.
'
Set objSubdirs = objFolder.SubFolders
For Each objLoopFolder In objSubdirs
CheckFolder objLoopFolder.Path
Next objLoopFolder

Set objSubdirs = Nothing
Set objFolder = Nothing
CheckFolder = varFs
End Function

Private Sub CreateCSVFile(fso As Variant, strFname As String)
Dim tf
If Not fso.FileExists(strFname) Then
Set tf = fso.CreateTextFile(strFname, True)
Set tf = Nothing
End If
End Sub

Private Sub WriteToCSVFile(strFname As String, strData As String)
Open strFname For Append As #1
Write #1, strData
Close #1
End Sub

Sub BatchReadSummInfo()
Dim oblkRef As AcadBlockReference
Dim objFnd As Object
Dim indx As Integer
Dim iFiles() As Variant
Dim m_objFSO
Dim fold, DwgName As String, cnt As Integer, nm As String
MsgBox "Wait, please..."
fold = BrowseForFolderF("Select Folder To Read SummaryInfo")
Set m_objFSO = CreateObject("Scripting.FileSystemObject")

iFiles = CheckFolder(fold)
Dim fPath As String
fPath = ThisDrawing.Path & "\SummInfo.csv"

CreateCSVFile m_objFSO, fPath

Dim oDBX As New AxDbDocument

Set oDBX = GetInterfaceObject("ObjectDBX.AxDbDocument.17") '' or 16 for A2005-6

On Error Resume Next
For indx = LBound(iFiles) To UBound(iFiles)
DwgName = iFiles(indx)
oDBX.Open DwgName
WriteToCSVFile fPath, DwgName
WriteToCSVFile fPath, "_________________________________"
Dim fl As File
Set fl = m_objFSO.GetFile(iFiles(indx))
WriteToCSVFile fPath, "Created: " & Format(fl.DateCreated, "DD/MM/YY")
WriteToCSVFile fPath, "Last Accessed: " & Format(fl.DateLastAccessed, "DD/MM/YY")
WriteToCSVFile fPath, " Modified: " & Format(fl.DateLastModified, "DD/MM/YY")

With oDBX
Dim Author As String
Author = .SummaryInfo.Author
WriteToCSVFile fPath, "Author: " & Author
Dim Comments As String
Comments = .SummaryInfo.Comments
WriteToCSVFile fPath, "Comments: " & Comments
Dim HLB As String
HLB = .SummaryInfo.HyperlinkBase
WriteToCSVFile fPath, "HyperlinkBase: " & HLB
Dim KW As String
KW = .SummaryInfo.Keywords
WriteToCSVFile fPath, "Keywords: " & KW
Dim LSB As String
LSB = .SummaryInfo.LastSavedBy
WriteToCSVFile fPath, "LastSavedBy: " & LSB
Dim RN As String
RN = .SummaryInfo.RevisionNumber
WriteToCSVFile fPath, "RevisionNumber: " & RN
Dim Subject As String
Subject = .SummaryInfo.Subject
WriteToCSVFile fPath, "Subject: " & Subject
Dim Title As String
Title = .SummaryInfo.Title
WriteToCSVFile fPath, "Title: " & Title
End With

WriteToCSVFile fPath, "_________________________________"
Set oDBX = Nothing
Next indx
MsgBox "Done"
End Sub

~'J'~

[Anonymous]

Thanks for helping me. when i try to run the code it gives a error variable not declared for ThisDrawing. Could you please tell me what type of variable will be this one.

[Anonymous]

You need to run this code from AutoCAD drawing only
but not in the folder you want to read info from

~'J'~

[Anonymous]

Hi, Actually I need a code that can read Issue date, created By, Drawing Name etc wihtout opening the Drawing File. the file will be in a different country. We will give the file name and it will read all the information and display all the block properties value such as creted by Me, Revision of the Drawing, Any other link file. when I open the file I can see it visually, I also got a code that reads them but what I have to do is open the file select a block and read all the data and return to my form. But as i said the file will be in a different country its take long time to load the file on the virtual mashine and also take long time open on the clients Pc.

[Anonymous]

I would take the easy way out and cycle through the files with AutoCAD retrieving the info you want. It sounds like you want a combination of file attributes and dwg properites. If you want information that is stored in the drawing such as drawing properties, it can get pretty complicated. I would just write a script that runs a procedure to pull the info from every file and store it in a text file or something.

If you want actual file attributes then use the code here:
http://www.vbaexpress.com/kb/getarticle.php?kb_id=405

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'If you want DWGPROP information,
'that is not custom then use this code:

Sub test_getSummaryInfo()
Dim i As Integer
Dim result As Variant
result = getSummaryInfo(ThisDrawing)
For i = LBound(result) To UBound(result)
Debug.Print result(i)
Next i
End Sub

Function getSummaryInfo(docName As AcadDocument) As Variant
Dim sumInfo(0 To 7) As String
Dim cProps As AcadSummaryInfo
Set cProps = docName.SummaryInfo
sumInfo(0) = cProps.Author
sumInfo(1) = cProps.Comments
sumInfo(2) = cProps.HyperlinkBase
sumInfo(3) = cProps.Keywords
sumInfo(4) = cProps.LastSavedBy
sumInfo(5) = cProps.RevisionNumber
sumInfo(6) = cProps.Subject
sumInfo(7) = cProps.Title
getSummaryInfo = sumInfo
End Function

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'If you want to set custom or retrieve
'DWGPROPs then use this code:

Sub test_DwgProps()
changeCustDwgProp ThisDrawing, "TestMe", "Worked"
Debug.Print getCustDwgProp(ThisDrawing, "TestMe")
End Sub

Private Function changeCustDwgProp(docName As AcadDocument, _
fldName As String, newVal As String)
On Error GoTo createIt
Dim custProps As AcadSummaryInfo
Set custProps = docName.SummaryInfo
custProps.SetCustomByKey fldName, newVal
Set custProps = Nothing
Exit Function
createIt:
custProps.AddCustomInfo fldName, newVal
Set custProps = Nothing
End Function

Private Function getCustDwgProp(docName As AcadDocument, _
fldName As String) As String
'KEY IS CASE SENSITIVE
On Error GoTo notFound
Dim custProps As AcadSummaryInfo
Set custProps = docName.SummaryInfo
custProps.GetCustomByKey fldName, getCustDwgProp
Set custProps = Nothing
Exit Function
notFound:
getCustDwgProp = ""
Set custProps = Nothing
End Function

'''Good luck!