I am not a programmer at all, however I have managed to create myself and my company a quick and easy way of tracking our drawings. I simply created a spreadsheet in Excel that automatically updates on open & lists all files in our drawing vault folder by their filename and adds a hyperlink to each of these files. I now want to add the corresponding description, customer name & project # from the custom properties of each of the solidworks files so that they will display in the spreadsheet also, therefore giving us a means of finding our documents without knowing the exact part number. Right now, I have the spreadsheet working so that column A lists the files and hyperlinks them, column B lists the Last Modified Date & column C shows the file path. Column D heading shows Description, Column E heading shows Customer & Column F shows Project, just like they should. However I do not understand how I can retrieve the custom property values and have them added into my spreadsheet. If anybody could help, that would be awesome. Here is my code so far:
Private Sub WORKBOOK_OPEN()
' Searches the selected folders and sub folders for files with the specified
'extension. .xls, .doc, .ppt, etc.
'A new worksheet is produced called "File Search Results". You can click on the link and go directly
'to the file you need.
Dim i As Long, z As Long, Rw As Long
Dim ws As Worksheet
Dim y As Variant
Dim fLdr As String, Fil As String, FPath As String
y = "*.*"
If y = False And Not TypeName
= "STRING" Then Exit Sub
Application.ScreenUpdating = False
'**********************************************************************
'fLdr = BrowseForFolderShell
fLdr = "P:\DRAWING_VAULT"
'**********************************************************************
With Application.FileSearch
.NewSearch
.LookIn = fLdr
.SearchSubFolders = False
.Filename = y
Set ws = ThisWorkbook.Worksheets.Add(Sheets(1))
On Error GoTo 1
2: ws.Name = "TMC_DRAWING_LIST"
On Error GoTo 0
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Fil = .FoundFiles(i)
'Get file path from file name
FPath = Left(Fil, Len(Fil) - Len(Split(Fil, "\")(UBound(Split(Fil, "\")))) - 1)
If Left$(Fil, 1) = Left$(fLdr, 1) Then
If CBool(Len(Dir(Fil))) Then
z = z + 1
ws.Cells(z + 1, 1).Resize(, 6) = _
Array(Dir(Fil), _
FileDateTime(Fil), _
FPath, _
'***this is where I would assume I need to add the callouts for description, customer & project**
)
ws.Hyperlinks.Add Anchor:=Cells(z + 1, 1), _
Address:=.FoundFiles(i)
End If
End If
Next i
End If
End With
ActiveWindow.DisplayHeadings = False
With ws
Rw = .Cells.Rows.Count
With .[A1:F1]
.Value = [{"FILE NAME (CLICK TO OPEN)","LAST MODIFIED", "PATH"," FILE DESCRIPTION","CUSTOMER","PROJECT/WORKORDER NO."}]
.Font.ColorIndex = vbBlack
.Font.Bold = True
.Font.Size = 11
.Cells.Interior.Color = vbGreen
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
End With
.[G1:IV1 ].EntireColumn.Hidden = True
On Error Resume Next
Range(Cells(Rw, "A").End(3)(2), Cells(Rw, "A")).EntireRow.Hidden = True
Range(.[A2 ], Cells(Rw, "C")).Sort [A2 ], xlAscending, Header:=xlNo
End With
Application.ScreenUpdating = True
Exit Sub
1: Application.DisplayAlerts = False
Worksheets("TMC_DRAWING_LIST").Delete
Application.DisplayAlerts = True
GoTo 2
End Sub
Private Sub WORKBOOK_OPEN()
' Searches the selected folders and sub folders for files with the specified
'extension. .xls, .doc, .ppt, etc.
'A new worksheet is produced called "File Search Results". You can click on the link and go directly
'to the file you need.
Dim i As Long, z As Long, Rw As Long
Dim ws As Worksheet
Dim y As Variant
Dim fLdr As String, Fil As String, FPath As String
y = "*.*"
If y = False And Not TypeName
= "STRING" Then Exit SubApplication.ScreenUpdating = False
'**********************************************************************
'fLdr = BrowseForFolderShell
fLdr = "P:\DRAWING_VAULT"
'**********************************************************************
With Application.FileSearch
.NewSearch
.LookIn = fLdr
.SearchSubFolders = False
.Filename = y
Set ws = ThisWorkbook.Worksheets.Add(Sheets(1))
On Error GoTo 1
2: ws.Name = "TMC_DRAWING_LIST"
On Error GoTo 0
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Fil = .FoundFiles(i)
'Get file path from file name
FPath = Left(Fil, Len(Fil) - Len(Split(Fil, "\")(UBound(Split(Fil, "\")))) - 1)
If Left$(Fil, 1) = Left$(fLdr, 1) Then
If CBool(Len(Dir(Fil))) Then
z = z + 1
ws.Cells(z + 1, 1).Resize(, 6) = _
Array(Dir(Fil), _
FileDateTime(Fil), _
FPath, _
'***this is where I would assume I need to add the callouts for description, customer & project**
)
ws.Hyperlinks.Add Anchor:=Cells(z + 1, 1), _
Address:=.FoundFiles(i)
End If
End If
Next i
End If
End With
ActiveWindow.DisplayHeadings = False
With ws
Rw = .Cells.Rows.Count
With .[A1:F1]
.Value = [{"FILE NAME (CLICK TO OPEN)","LAST MODIFIED", "PATH"," FILE DESCRIPTION","CUSTOMER","PROJECT/WORKORDER NO."}]
.Font.ColorIndex = vbBlack
.Font.Bold = True
.Font.Size = 11
.Cells.Interior.Color = vbGreen
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
End With
.[G1:IV1 ].EntireColumn.Hidden = True
On Error Resume Next
Range(Cells(Rw, "A").End(3)(2), Cells(Rw, "A")).EntireRow.Hidden = True
Range(.[A2 ], Cells(Rw, "C")).Sort [A2 ], xlAscending, Header:=xlNo
End With
Application.ScreenUpdating = True
Exit Sub
1: Application.DisplayAlerts = False
Worksheets("TMC_DRAWING_LIST").Delete
Application.DisplayAlerts = True
GoTo 2
End Sub
![[cheers]](/data/assets/smilies/cheers.gif "[cheers] [cheers]")
penDocumentProperties() in D:\CDBackup\Projects\dsofile\2.1\Samples\VB7\FilePropDemo.vb:line 524