load & activate a model from VB (2)
load & activate a model from VB (2)
(OP)
Andrew:
Here is the updated sample. If the referenced model is already open, it will remain open. The model will only be closed if the program had to open it.
Option Explicit
'<><><><><><><><><><><><><><>
' Transfer Custom Properties
'<><><><><><><><><><><><><><>
Dim swApp As Object
Dim Dwg As Object
Dim View As Object
Dim Model As Object
Const swDocDRAWING = 3
Dim sModelName As String
Dim sPartName As String
Dim sDwgName As String
Sub Main()
Dim swError As Long, iPos As Long, bClose As Boolean
Dim sTitle As String
Set swApp = CreateObject("SldWorks.Application")
Set Dwg = swApp.ActiveDoc
'Verify a Drawing is Open
If (Dwg Is Nothing) Or (Dwg.GetType <> swDocDRAWING) Then
swApp.SendMsgToUser "You Must Have a Drawing Opened"
Exit Sub
End If
sDwgName = Dwg.GetTitle
'Get Reference Model
Set View = Dwg.GetFirstView 'drawing template
Set View = View.GetNextView 'first drawing view
sModelName = View.GetReferencedModelName()
'Open the Reference Model, read the custom properties, save and close the model
'Switch to the model if it is already opened
sPartName = sModelName
iPos = InStr(1, sPartName, "\")
Do While iPos > 0
sPartName = Right(sPartName, Len(sPartName) - iPos)
iPos = InStr(1, sPartName, "\")
Loop
On Error Resume Next
Set Model = swApp.ActivateDoc(sPartName)
If Err.Number <> 0 Then 'file is not currently opened
Err.Clear
bClose = True
Else
bClose = False
End If
Set Model = swApp.ActivateDoc2(sModelName, True, swError)
swApp.SendMsgToUser "Get the Custom Properties"
Model.Save2 True
If bClose = True Then 'only close if we had to open it
swApp.CloseDoc sModelName
End If
Set Dwg = swApp.ActivateDoc(sDwgName)
'Rebuild the drawing
swApp.SendMsgToUser "Write the Custom Properties to the Drawing"
Dwg.EditRebuild
'Clean Up
Set Model = Nothing
Set View = Nothing
Set Dwg = Nothing
Set swApp = Nothing
End Sub
Hope this helps!
Here is the updated sample. If the referenced model is already open, it will remain open. The model will only be closed if the program had to open it.
Option Explicit
'<><><><><><><><><><><><><><>
' Transfer Custom Properties
'<><><><><><><><><><><><><><>
Dim swApp As Object
Dim Dwg As Object
Dim View As Object
Dim Model As Object
Const swDocDRAWING = 3
Dim sModelName As String
Dim sPartName As String
Dim sDwgName As String
Sub Main()
Dim swError As Long, iPos As Long, bClose As Boolean
Dim sTitle As String
Set swApp = CreateObject("SldWorks.Application")
Set Dwg = swApp.ActiveDoc
'Verify a Drawing is Open
If (Dwg Is Nothing) Or (Dwg.GetType <> swDocDRAWING) Then
swApp.SendMsgToUser "You Must Have a Drawing Opened"
Exit Sub
End If
sDwgName = Dwg.GetTitle
'Get Reference Model
Set View = Dwg.GetFirstView 'drawing template
Set View = View.GetNextView 'first drawing view
sModelName = View.GetReferencedModelName()
'Open the Reference Model, read the custom properties, save and close the model
'Switch to the model if it is already opened
sPartName = sModelName
iPos = InStr(1, sPartName, "\")
Do While iPos > 0
sPartName = Right(sPartName, Len(sPartName) - iPos)
iPos = InStr(1, sPartName, "\")
Loop
On Error Resume Next
Set Model = swApp.ActivateDoc(sPartName)
If Err.Number <> 0 Then 'file is not currently opened
Err.Clear
bClose = True
Else
bClose = False
End If
Set Model = swApp.ActivateDoc2(sModelName, True, swError)
swApp.SendMsgToUser "Get the Custom Properties"
Model.Save2 True
If bClose = True Then 'only close if we had to open it
swApp.CloseDoc sModelName
End If
Set Dwg = swApp.ActivateDoc(sDwgName)
'Rebuild the drawing
swApp.SendMsgToUser "Write the Custom Properties to the Drawing"
Dwg.EditRebuild
'Clean Up
Set Model = Nothing
Set View = Nothing
Set Dwg = Nothing
Set swApp = Nothing
End Sub
Hope this helps!
DimensionalSolutions@Core.com
While I welcome e-mail messages, please post all thread activity in these forums for the benefit of all members.






RE: load & activate a model from VB (2)
One little problem. bClose never becomes True so the solid model would stay open even if was closed before.
What sets Err.Number be <> 0?
Andrew
RE: load & activate a model from VB (2)
You are correct. I was expecting ActivateDoc to error if the file was not already opened.
Remove this code:
On Error Resume Next
Set Model = swApp.ActivateDoc(sPartName)
If Err.Number <> 0 Then 'file is not currently opened
Err.Clear
bClose = True
Else
bClose = False
End If
Add this code:
Dim sTmp As String, nextDoc As Object
On Error Resume Next
Set nextDoc = swApp.GetFirstDocument
sTmp = nextDoc.GetTitle
bClose = True 'assume file is not open
Do While sTmp <> ""
If InStr(1, sTmp, sPartName) > 0 Then
If nextDoc.Visible = True Then
bClose = False 'document is already opened
Else
bClose = True 'document is not open yet
End If
Exit Do
End If
Set nextDoc = nextDoc.GetNext
sTmp = nextDoc.GetTitle
If Err.Number <> 0 Then Exit Do
Loop
DimensionalSolutions@Core.com
While I welcome e-mail messages, please post all thread activity in these forums for the benefit of all members.