SW Custom Property Linking in Excel's VB
SW Custom Property Linking in Excel's VB
(OP)
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(y) = "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(y) = "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






RE: SW Custom Property Linking in Excel's VB
Bradley
SolidWorks Premim 2007 x64 SP4.0
PDM Works, Intel(R) Pentium(R) D CPU
3.00 GHz, 4 GB RAM, Virtual memory 12577 MB, nVidia 3400
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
Matt
CAD Engineer/ECN Analyst
Silicon Valley, CA
sw.fcsuper.com
Co-moderator of Solidworks Yahoo! Group
RE: SW Custom Property Linking in Excel's VB
Matt
CAD Engineer/ECN Analyst
Silicon Valley, CA
sw.fcsuper.com
Co-moderator of Solidworks Yahoo! Group
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
Matt
CAD Engineer/ECN Analyst
Silicon Valley, CA
sw.fcsuper.com
Co-moderator of Solidworks Yahoo! Group
RE: SW Custom Property Linking in Excel's VB
I am so glad we are using PDM. A star for you.
Bradley
SolidWorks Premim 2007 x64 SP4.0
PDM Works, Intel(R) Pentium(R) D CPU
3.00 GHz, 4 GB RAM, Virtual memory 12577 MB, nVidia 3400
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
htt
http
etc..
RE: SW Custom Property Linking in Excel's VB
htt
And there is a download link for DSOfile.dll at:
http://
Eric
RE: SW Custom Property Linking in Excel's VB
If you are only going to be opening this spreadsheet on computers with SolidWorks and you do not want to install DSOfile.dll on them you could use the swDocumentManager.dll that is installed with SolidWorks explorer. See thread559-175535: searching for a configuration specific custom properties in SolidWorks for the chunk of code by handleman. It should be a good starting point. If you are using a version of SolidWorks prior to 2007, you will need to e-mail SolidWorks API tech support to get a key to make it work. As in handleman’s example, you would also have access to configuration specific custom properties.
Personally I would use DSOfile.dll since you do not appear to need the configuration specific properties.
Eric
RE: SW Custom Property Linking in Excel's VB
Sub WORKBOOK_OPEN()
Dim i As Long, z As Long, Rw As Long
Dim ws As Worksheet
Dim y As Variant
Dim fLdr As String
Dim fil As String
Dim DSO As DSOFile.OleDocumentProperties
Dim FPath As String
Set DSO = New DSOFile.OleDocumentProperties
fil = "I HAVE TO PUT AN ABSOLUTE FILE PATH HERE"
DSO.Open SFileName:=fil
Dim Object As String
Set OBJFILE = CreateObject("DSOFile.OleDocumentProperties")
y = "*.*"
If y = False And Not TypeName(y) = "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(, 8) = _
Array(Dir(fil), _
DSO.SummaryProperties.DateLastSaved, _
DSO.CustomProperties.Item("DESCRIPTION").Value, _
DSO.CustomProperties.Item("CUSTOMER").Value, _
DSO.CustomProperties.Item("PROJECT").Value, _
DSO.CustomProperties.Item("USERDEFINED1").Value, _
DSO.CustomProperties.Item("USERDEFINED2").Value, _
DSO.CustomProperties.Item("DRAWNBY").Value)
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:H1]
.Value = [{"FILE NAME (CLICK TO OPEN)","LAST MODIFIED"," FILE DESCRIPTION","CUSTOMER","WORKORDER NO.","COMPUTER ID NO.","CUSTOMER DWG NO.","AUTHOR"}]
.Font.ColorIndex = vbBlack
.Font.Bold = True
.Font.Size = 11
.Cells.Interior.Color = vbGreen
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
End With
.[I1: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
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
DSO.CustomProperties.Item("[name]")
with
iif(not DSO.CustomProperties.Item("[name]") is nothing, DSO.CustomProperties.Item("[name]").Value, "")
That's all one line. It's sort of ugly programming, but it's the simplest way to fit it into your code.
Good luck!
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
Dim i As Long, z As Long, Rw As Long
Dim ws As Worksheet
Dim y As Variant
Dim fLdr As String
Dim fil As String
Dim DSO As DSOFile.OleDocumentProperties
Dim FPath As String
Dim Object As String
Set OBJFILE = CreateObject("DSOFile.OleDocumentProperties")
y = "*.*"
If y = False And Not TypeName(y) = "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)
Set DSO = New DSOFile.OleDocumentProperties
DSO.Open SFileName:=fil
'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(, 8) = _
Array(Dir(fil), _
DSO.SummaryProperties.DateLastSaved, _
IIf(Not DSO.CustomProperties.Item("description") Is Nothing, DSO.CustomProperties.Item("description").Value, ""), _
IIf(Not DSO.CustomProperties.Item("customer") Is Nothing, DSO.CustomProperties.Item("customer").Value, ""), _
IIf(Not DSO.CustomProperties.Item("project") Is Nothing, DSO.CustomProperties.Item("project").Value, ""), _
IIf(Not DSO.CustomProperties.Item("userdefined1") Is Nothing, DSO.CustomProperties.Item("userdefined1").Value, ""), _
IIf(Not DSO.CustomProperties.Item("userdefined2") Is Nothing, DSO.CustomProperties.Item("userdefined2").Value, ""), _
IIf(Not DSO.CustomProperties.Item("drawnby") Is Nothing, DSO.CustomProperties.Item("drawnby").Value, ""))
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:H1]
.Value = [{"FILE NAME (CLICK TO OPEN)","LAST MODIFIED"," FILE DESCRIPTION","CUSTOMER","WORKORDER NO.","COMPUTER ID NO.","CUSTOMER DWG NO.","AUTHOR"}]
.Font.ColorIndex = vbBlack
.Font.Bold = True
.Font.Size = 11
.Cells.Interior.Color = vbGreen
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
End With
.[I1: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
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
IIf(Not DSO.CustomProperties.Item("[name]") Is Nothing, DSO.CustomProperties.Item("[name]").Value, "")
with
IsProp(DSO.CustomProperties, "[name]")
IsProp is a function I wrote that will check for existence of a property by name and return either the value or the words "Property Not Present". You need to copy this function and paste it at the bottom of your code, outside the last "End Sub" statement.
CODE
Dim testProp As Object
On Error Resume Next
Set testProp = myCProps(myMemName)
If testProp Is Nothing Then
IsProp = "Property Not Present"
Else
IsProp = testProp.Value
End If
On Error GoTo 0
End Function
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
ws.EnableAutoFilter = True
but it doesn't seem to do anything. I am just trying to get the autofilter arrows to show up on worksheet open. Just so I dont have to go to Data > Filter > AutoFilter manually each time I open the excel file. Any suggestions?
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
CODE
Eric
RE: SW Custom Property Linking in Excel's VB
Sub WORKBOOK_OPEN()
Dim i As Long, z As Long, Rw As Long
Dim ws As Worksheet
Dim y As Variant
Dim fLdr As String
Dim fil As String
Dim DSO As DSOFile.OleDocumentProperties
Dim FPath As String
Dim Object As String
Set OBJFILE = CreateObject("DSOFile.OleDocumentProperties")
y = "*.*"
If y = False And Not TypeName(y) = "STRING" Then Exit Sub
Application.ScreenUpdating = False
'**********************************************************************
'fLdr = BrowseForFolderShell
fLdr = "P:\DRAWING_VAULT" 'this is the folder where your drawings/files are contained
'**********************************************************************
With Application.FileSearch
.NewSearch
.LookIn = fLdr
.SearchSubFolders = False 'you can search subfolders if you want
.FileName = y
Set ws = ThisWorkbook.Worksheets.Add(Sheets(1))
On Error GoTo 1
2: ws.Name = "TMC DRAWING LIST" 'call your sheet anything you like
ws.EnableAutoFilter = True
On Error GoTo 0
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
fil = .FoundFiles(i)
Set DSO = New DSOFile.OleDocumentProperties
DSO.Open SFileName:=fil
'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(, 8) = _
Array(Dir(fil), _
DSO.SummaryProperties.DateLastSaved, _
IsProp(DSO.CustomProperties, "Description"), _
IsProp(DSO.CustomProperties, "Customer"), _
IsProp(DSO.CustomProperties, "Project"), _
IsProp(DSO.CustomProperties, "UserDefined1"), _
IsProp(DSO.CustomProperties, "UserDefined2"), _
IsProp(DSO.CustomProperties, "DrawnBy"))
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:H1]
.Value = [{"FILE NAME (CLICK TO OPEN)","LAST MODIFIED"," FILE DESCRIPTION","CUSTOMER","WORKORDER NO.","COMPUTER ID NO.","CUSTOMER DWG NO.","AUTHOR"}]
.Font.ColorIndex = vbBlack
.Font.Bold = True
.Font.Size = 11
.Cells.Interior.Color = vbGreen
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
End With
.[I1: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
Function IsProp(myCProps As Object, myMemName As String) As String
Dim testProp As Object
On Error Resume Next
Set testProp = myCProps(myMemName)
If testProp Is Nothing Then
IsProp = "N/A"
Else
IsProp = testProp.Value
End If
On Error GoTo 0
End Function
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
I have one more glich I need to get rid of, hopefully you or someone else can help. When I am opening my spreadsheet, if someone else on the network has one of the files open that would be included in my list of files in my spreadsheet, I get a path/file access error and my spreadsheet doesn't update or display properly. From what I understand, I need to use the dso read only option or something along those lines, I am just unsure of the exact code and placement in my current code for this to work effectively. Any help would be great!! Thanks again!
RE: SW Custom Property Linking in Excel's VB
DSO.Open SFileName:=fil
to
DSO.Open SFileName:=fil, True
and that should do it.
RE: SW Custom Property Linking in Excel's VB
compile error - expected named parameter
(it highlights "true")
RE: SW Custom Property Linking in Excel's VB
DSO.Open SFileName:=fil, ReadOnly:=True
Basically, the lines "DSO.Open fil, True" and "DSO.Open SFileName:=fil, ReadOnly:=True" are exactly the same. The second one just specifies the name of the argument along with its value. The first relies on the order of arguments to determine which is which.
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
DSO.Open SFileName:=fil, ReadOnly:=True, dsofileoptions:=dsoOptionOpenReadOnlyIfNoWriteAccess
and received error 'named argument not found'
RE: SW Custom Property Linking in Excel's VB
DSO.Open SFileName:=fil, ReadOnly:=True, dsoFileOpenOptions:=dsoOptionOpenReadOnlyIfNoWriteAccess
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
DSO.Open SFileName:=fil, ReadOnly:=True, Options:=dsoOptionOpenReadOnlyIfNoWriteAccess
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
I guess what I would really like to happen is to have the file as a viewing file only with the ability to update at timed intervals by a writeable version running in the background or something along those lines. Any ideas?
RE: SW Custom Property Linking in Excel's VB
CODE
MsgBox "Sheet last updated " & ActiveWorkbook.BuiltinDocumentProperties("Last Save Time")
Exit Sub
End If
This will stop the main update code from running if the file was opened read-only. Having the file open read-only will keep the original file available for periodic updating (more on that later). If you want to give users the option of getting the latest data without waiting for the periodic update (or changing the read only status of the master file!), you can use the following block instead. It will ask the user upon opening the document whether or not they want to go retrieve the latest data:
CODE
Dim sMsg As String
sMsg = "Sheet last updated " & ActiveWorkbook.BuiltinDocumentProperties("Last Save Time")
sMsg = sMsg & vbCrLf & vbCrLf & "File is currently open as read-only."
sMsg = sMsg & vbCrLf & "Accept the currently saved values?" & vbCrLf
sMsg = sMsg & "Choosing ""No"" will increase time required to open."
If MsgBox(sMsg, vbYesNo) = vbYes Then
Exit Sub
End If
End If
Now, take the following block of code and paste it into a new text file in Notepad and save it as a ".vbs" (for VBScript) file.
CODE
dim xlApp 'Excel Application Object
dim xlWorkbook 'Excel Workbook object
dim sWkBkPath 'String
dim fso 'File System Object
dim wbFile 'File object
set fso = createobject("Scripting.FileSystemObject")
set wbFile = fso.getfile(WBPATH)
if wbfile.attributes AND 1 then
wbfile.attributes = wbfile.attributes - 1
end if
set xlApp = CreateObject("Excel.Application")
set xlWorkbook = xlApp.Workbooks.Open(WBPATH)
xlApp.Visible = FALSE 'Make true if you want to see the workbook
xlWorkbook.Save
xlWorkbook.Close
xlApp.Quit
set wbFile = fso.getfile(WBPATH)
if not (wbfile.attributes AND 1) then
wbfile.attributes = wbfile.attributes + 1
end if
set xlWorkbook = Nothing
set xlApp = Nothing
set wbFile = Nothing
set fso = Nothing
This little script will set the master file to be non-read-only, open the file (which runs the update macro), save the file, close the file, and set it back to read only. Of course, you'll have to put the path to your Excel file in that WBPATH constant at the very top.
Once you've done that, you can use Windows Task Scheduler to run the script on whatever schedule you want. Just go to Control Panel, choose Scheduled Tasks, and use the "Add Scheduled Task" icon to schedule it. Note that the wizard that starts automatically is really pretty limited. However, if you check the box for "Open Advanced Properties" on the last page of the wizard you can set up whatever kind of schedule you want. Once a day, twice a day, once an hour, every minute, whatever you like.
Hope this helps!
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
CODE
ActiveWorkbook.Saved = True
End Sub
You're basically lying to Excel, telling it that you've not really made any changes since the last save. You can tell Excel this "ActiveWorkbook.Saved = True" lie anywhere in code you want. Excel will believe you until you make another change to the workbook.
RE: SW Custom Property Linking in Excel's VB
run-time error - 2147287039 (80030001)
Method 'open' of object '_oledocumentproperties' failed
I am thinking that some kinda of reference is missing suddenly, or something strange. Let me know if you have any ideas. Thanks.
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
If ActiveWorkbook.ReadOnly Then
Dim sMsg As String
sMsg = "*********************************"
sMsg = sMsg & vbCrLf & "TMC DRAWING DATABASE NOTIFICATION" & vbCrLf
sMsg = sMsg & vbCrLf & "*********************************" & vbCrLf
sMsg = sMsg & vbCrLf & "THIS SHEET WAS LAST UPDATED: " & ActiveWorkbook.BuiltinDocumentProperties("Last Save Time") & vbCrLf
sMsg = sMsg & vbCrLf & vbCrLf & "Select ""YES"" to continue with current data"
sMsg = sMsg & vbCrLf & "Select ""NO"" to update the data" & vbCrLf
sMsg = sMsg & vbCrLf & "***************************************************************" & vbCrLf
sMsg = sMsg & "HINT: CHOOSING ""No"" WILL INCREASE THE TIME TO OPEN THIS SHEET"
If MsgBox(sMsg, vbYesNo) = vbYes Then
Exit Sub
End If
End If
Dim i As Long, z As Long, Rw As Long
Dim ws As Worksheet
Dim y As Variant
Dim fLdr As String
Dim fil As String
Dim DSO As DSOFile.OleDocumentProperties
Dim FPath As String
Dim Object As String
Set OBJFILE = CreateObject("DSOFile.OleDocumentProperties")
y = "*.*"
If y = False And Not TypeName(y) = "STRING" Then Exit Sub
Application.ScreenUpdating = False
'**********************************************************************
'fLdr = BrowseForFolderShell
fLdr = "x:\"
'**********************************************************************
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)
Set DSO = New DSOFile.OleDocumentProperties
crashes here----> DSO.Open SFileName:=fil, ReadOnly:=True, Options:=dsoOptionOpenReadOnlyIfNoWriteAccess
'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(, 8) = _
Array(Dir(fil), _
DSO.SummaryProperties.DateLastSaved, _
IsProp(DSO.CustomProperties, "Description"), _
IsProp(DSO.CustomProperties, "material"), _
IsProp(DSO.CustomProperties, "Customer"), _
IsProp(DSO.CustomProperties, "Project"), _
IsProp(DSO.CustomProperties, "UserDefined1"), _
IsProp(DSO.CustomProperties, "UserDefined2"), _
IsProp(DSO.CustomProperties, "LINE_NO"), _
IsProp(DSO.CustomProperties, "LINE_DESC"), _
IsProp(DSO.CustomProperties, "PRODUCT_DESC"), _
IsProp(DSO.CustomProperties, "PRODUCT_CONF"))
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:L1]
.Value = [{"FILE NAME (CLICK TO OPEN)","LAST MODIFIED"," FILE DESCRIPTION","MATERIAL","CUSTOMER","WORKORDER NO.","COMPUTER ID NO.","CUSTOMER DWG NO.","LINE NO.","LINE DESCRIPTION","PRODUCT DESCRIPTION","PRODUCT CONFIGURATION"}]
.Font.ColorIndex = vbBlack
.Font.Bold = True
.Font.Size = 11
.Cells.Interior.Color = vbGreen
Range("A1").AutoFilter field:=1, Criteria1:="*", VisibleDropDown:=True
.EntireColumn.AutoFit
.HorizontalAlignment = xlLeft
End With
.[M1: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_BeforeClose(Cancel As Boolean)
ActiveWorkbook.Saved = True
End Sub
Function IsProp(myCProps As Object, myMemName As String) As String
Dim testProp As Object
On Error Resume Next
Set testProp = myCProps(myMemName)
If testProp Is Nothing Then
IsProp = "N/A"
Else
IsProp = testProp.Value
End If
On Error GoTo 0
End Function
RE: SW Custom Property Linking in Excel's VB
I thought it may be a missing reference, but its not as far as I know. The strange thing is that it can make it through Solidworks files in the that folder no problem, its other files such as step files or autocad files that it chokes on. Maybe I missing a reference for those? I don't see why it would change though. Oh and just so you know, all that I have done is moved the folder which contained this spreadsheet as well as all of the drawings to a new shared drive on an external hard drive. I am wondering if it is possible if that new drive isn't allowing this function or something along those lines?? My error is;
Run-time error -2147287039 (800300001)
Method 'Open' of object '_OleDocumentProperties' failed
RE: SW Custom Property Linking in Excel's VB
y = "*.*"
to
y = "*.sld*"
and see if the program will run all the way through for you? If so, and if you only want to list SW files, then I guess you're set. Otherwise, we'll have to dig a bit more.
Do you have any details about your "external drive system"? Encryption? Compression? Firewall?
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
y = "*.sld*"
instead of
y = "*.sldprt"
*.sld* should get you all SolidWorks files, and should also help if you're somehow getting into DOS style 8.2 file naming issues.
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
Set OBJFILE = CreateObject("DSOFile.OleDocumentProperties")
To verify that it is at least doing something, you can follow that line with
Debug.Print OBJFILE Is Nothing
If your immediate window shows "True" then you know that the Set statement failed somehow. Next you have the line:
y="*.*"
you can verify that this statement worked correctly by the line
Debug.Print y
You should see *.* in the immediate window. You can do this sort of thing for every line until you find the line that is not behaving in the way you expect.
I used to use MsgBox a lot for this type of debugging. However, if you put a MsgBox inside a looping section of the code you'll have to do a lot of clicking while it goes through the loop. Debug.Print just outputs to the immediate window.
RE: SW Custom Property Linking in Excel's VB
RE: SW Custom Property Linking in Excel's VB
"c:\dsofile\INTEROP.DSOFILE.dll" was loaded, but the dll registry point was not found. This file can not be registered.
RE: SW Custom Property Linking in Excel's VB
Just another update, finally got it fixed enough to be able to use it again. I changed y="*.*" to y="*.sld*" and now it will display all solidworks types only. That is good enough for what we use it for, for now anyways. Thanks for all of your help. Maybe one day I will figure out why it stopped being able to run all file extensions. It is quite strange.
RE: SW Custom Property Linking in Excel's VB
What happens if you use just y="*"
RE: SW Custom Property Linking in Excel's VB
************** Exception Text **************
System.Runtime.InteropServices.COMException (0x80030001): Unable to perform requested operation.
at DSOFile.OleDocumentPropertiesClass.Open(String sFileName, Boolean ReadOnly, dsoFileOpenOptions Options)
at FilePropDemoVB7.FilePropDemo.OpenDocumentProperties() in D:\CDBackup\Projects\dsofile\2.1\Samples\VB7\FilePropDemo.vb:line 524
at FilePropDemoVB7.FilePropDemo.cmdOpen_Click(Object sender, EventArgs e) in D:\CDBackup\Projects\dsofile\2.1\Samples\VB7\FilePropDemo.vb:line 724
at System.Windows.Forms.Control.OnClick(EventArgs e)
at System.Windows.Forms.Button.OnClick(EventArgs e)
at System.Windows.Forms.Button.OnMouseUp(MouseEventArgs mevent)
at System.Windows.Forms.Control.WmMouseUp(Message& m, MouseButtons button, Int32 clicks)
at System.Windows.Forms.Control.WndProc(Message& m)
at System.Windows.Forms.ButtonBase.WndProc(Message& m)
at System.Windows.Forms.Button.WndProc(Message& m)
at System.Windows.Forms.ControlNativeWindow.OnMessage(Message& m)
at System.Windows.Forms.ControlNativeWindow.WndProc(Message& m)
at System.Windows.Forms.NativeWindow.Callback(IntPtr hWnd, Int32 msg, IntPtr wparam, IntPtr lparam)
************** Loaded Assemblies **************
mscorlib
Assembly Version: 1.0.5000.0
Win32 Version: 1.1.4322.2407
CodeBase: file:///c:/windows/microsoft.net/framework/v1.1.4322/mscorlib.dll
----------------------------------------
FilePropDemoVB7
Assembly Version: 1.0.1.0
Win32 Version: 1.0.1.0
CodeBase: file:///C:/DsoFile/Demo/FilePropDemoVB7.exe
----------------------------------------
System.Windows.Forms
Assembly Version: 1.0.5000.0
Win32 Version: 1.1.4322.2032
CodeBase: file:///c:/windows/assembly/gac/system.windows.forms/1.0.5000.0__b77a5c561934e089/system.windows.forms.dll
----------------------------------------
System
Assembly Version: 1.0.5000.0
Win32 Version: 1.1.4322.2407
CodeBase: file:///c:/windows/assembly/gac/system/1.0.5000.0__b77a5c561934e089/system.dll
----------------------------------------
System.Drawing
Assembly Version: 1.0.5000.0
Win32 Version: 1.1.4322.2032
CodeBase: file:///c:/windows/assembly/gac/system.drawing/1.0.5000.0__b03f5f7f11d50a3a/system.drawing.dll
----------------------------------------
Interop.DSOFile
Assembly Version: 2.1.0.0
Win32 Version: 2.1.0.0
CodeBase: file:///C:/DsoFile/Demo/Interop.DSOFile.DLL
----------------------------------------
Microsoft.VisualBasic
Assembly Version: 7.0.5000.0
Win32 Version: 7.10.6001.4
CodeBase: file:///c:/windows/assembly/gac/microsoft.visualbasic/7.0.5000.0__b03f5f7f11d50a3a/microsoft.visualbasic.dll
----------------------------------------
CustomMarshalers
Assembly Version: 1.0.5000.0
Win32 Version: 1.1.4322.573
CodeBase: file:///c:/windows/assembly/gac/custommarshalers/1.0.5000.0__b03f5f7f11d50a3a/custommarshalers.dll
----------------------------------------
************** JIT Debugging **************
To enable just in time (JIT) debugging, the config file for this
application or machine (machine.config) must have the
jitDebugging value set in the system.windows.forms section.
The application must also be compiled with debugging
enabled.
For example:
<configuration>
<system.windows.forms jitDebugging="true" />
</configuration>
When JIT debugging is enabled, any unhandled exception
will be sent to the JIT debugger registered on the machine
rather than being handled by this dialog.
RE: SW Custom Property Linking in Excel's VB
Visual Basic for Applications
Microsoft Excel 11.0 Object Library
OLE Automation
Microsoft Office 11.0 Object Library
DSO OLE Document Properties Reader 2.1
Interop.DSOFile.DLL is not used by anything except the demo program. I can rename that file and the code still runs. Have you tried this on other computers? Have you verified that your DSOFile.DLL is not corrupt?