File properties

[aksha]

I know I can get 'Comments' file property of open drawing with ThisDrawing.SummaryInfo.Comments. But what will be the way to get same data for .dwg files other than 'ThisDrawing'? I also tried Microsoft's dsofile.dll, but it did not work. Is there a way around?

[Anonymous]

Give this a shot

~'J'~

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

fold = BrowseForFolderF("Select Folder To Read SummaryInfo")
Set m_objFSO = CreateObject("Scripting.FileSystemObject")

iFiles = CheckFolder(fold)
Dim fPath As String
fPath = ThisDrawing.Path & "\SummInfo.txt"
'//CreateCSVFile m_objFSO, "C:\Temp\SummInfo.txt" '// CHANGE TEXT FILE NAME HERE
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, "_________________________________"
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

End Sub

[aksha]

Thank you.
I guess I will have to wait until my AutoCAD is upgraded to 2007+.

[Anonymous]

What the version you have at the moment?

~'J'~

[aksha]

2005

[Anonymous]

You need change in Tools->Reference to
AutoCAD/ObjectDBX Common 16.0 Type Library
for your version

And change this line:
Set oDbx = GetInterfaceObject("ObjectDBX.AxDbDocument.17")
on this one:
Set oDbx = GetInterfaceObject("ObjectDBX.AxDbDocument.16")

~'J'~

[aksha]

Thanks a lot (I wish I could make out your name) !
It worked. Now I can finish my project.
Thanks again.

[Anonymous]

Glad if that helps
Happy coding
Cheers 🙂

~'J'~