VBA Derive Part function failing to create new part document

[Anonymous]

Hi all, 

I posted a couple weeks ago about something similar to this but didn't get an answer. Since my last post I've changed the way I get the surface body I needed so I don't need help with that anymore. However, I'm having a ton of trouble getting the derive function to work properly.

I've been using posts from mod the machine as a reference, but for some reason the exact same syntax is failing at the "Set newPart = ...." line, throwing an "Invalid procedure call or argument" error.

Every reference I've found uses this exact same syntax, so I don't know what the problem is. If anyone can help me figure this out I would appreciate it.

Dim oDoc As PartDocument
Set oDoc = ThisApplication.ActiveDocument

Dim template As String
Dim folder As String
template = " "
folder = PathName(oDoc.FullFileName)


Dim partColl As ObjectCollection
Set partColl = ThisApplication.TransientObjects.CreateObjectCollection

Dim i As Integer: i = 0

Dim oSB As SurfaceBody
For Each oSB In oDoc.ComponentDefinition.SurfaceBodies
    'set new part throws invalid procedure call or argument
    Dim newPart As PartDocument
    Set newPart = ThisApplication.Documents.Add(kPartDocumentObject, template, True)

    Dim oDerPartComps As DerivedPartComponents
    Set oDerPartComps = newPart.ComponentDefinition.ReferenceComponents.DerivedPartComponents

    Dim oDerPartDef As DerivedPartUniformScaleDef
    Set oDerPartDef = oDerPartComps.CreateUniformScaleDef(oDoc.FullFileName)

' create definition corresponding to desired type of derived part

    oDerPartDef.ScaleFactor = 1

    Call oDerPartDef.ExcludeAll

    Dim oDerPartEnt As DerivedPartEntity
    For Each oDerPartEnt In oDerPartDef.Surfaces
        If oDerPartEnt.Type = kSurfaceBodiesObject Then
            oDerPartEnt.IncludeEntity = True
        End If
    Next
    Call oDerPartComps.Add(oDerPartDef)
    Call partColl.Add(newPart)
    oDerPartDef.DeriveStyle = kDeriveAsWorkSurface

    Dim oDerComp As DerivedPartComponent
    Set oDerComp = oDerPartComps.Add(oDerPartDef)
    
    newPart.PropertySets.Item("Inventor Summary Information").Item("Title").Value = oSB.Name
    
    i = i + 1
    
    ThisApplication.SilentOperation = True
    Call newPart.SaveAs(folder & oSB.Name & "_" & i & ".ipt", False)
    ThisApplication.SilentOperation = False
    
    Next oSB
    
    

End Sub

Function PathName(FullPath As String) As String
 
 ' return all left of last \
 PathName = Left(FullPath, InStrRev(FullPath, "\"))

End Function

[dean.morrison]

Hi,

I tried your code for just the new part line your having trouble with..

I believe its the line 

template = " "

that's causing the problem.

It does however create a new part if you remove or comment out the above line.

Hope that helps..

Dean.

[Anonymous]

That seems to have gotten it past the initial problem but now it gets stuck at the line

'oDerPartDef.DeriveStyle = kDeriveAsWorkSurface', throwing a Run-time error '-2147467259 (80004005)', Automation error, Unspecified error. Did it do the same thing for you or did it run all the way through successfully?

[Anonymous]

Quick addition to this: I tried commenting out the line I just mentioned and it ran all the way through, but my derived part doesn't have anything activated. If I edit the derived part manually I can turn on the surface bodies, which is my desired end result, but I would like to have the derived surface body be active from the get-go as this whole program will be run on assemblies and having to activate each surface body would be somewhat tedious. 

[HideoYamada · Accepted solution]

Hello,

I don't understand what you want to do exactly, but if it is separating the solids in one part file to the part files which containing each solids, this code will work.

Sub test()
    Dim oDoc As PartDocument
    Set oDoc = ThisApplication.ActiveDocument
    
    Dim template As String
    Dim folder As String
    template = ""
    folder = PathName(oDoc.FullFileName)
    
    Dim partColl As ObjectCollection
    Set partColl = ThisApplication.TransientObjects.CreateObjectCollection
    
    Dim i As Integer
    
     For i = 1 To oDoc.ComponentDefinition.SurfaceBodies.Count
        'set new part throws invalid procedure call or argument
        Dim newPart As PartDocument
        Set newPart = ThisApplication.Documents.Add(kPartDocumentObject, template, True)
    
        Dim oDerPartComps As DerivedPartComponents
        Set oDerPartComps = newPart.ComponentDefinition.ReferenceComponents.DerivedPartComponents
    
        Dim oDerPartDef As DerivedPartUniformScaleDef
        Set oDerPartDef = oDerPartComps.CreateUniformScaleDef(oDoc.FullFileName)
    
        ' create definition corresponding to desired type of derived part
    
        oDerPartDef.ScaleFactor = 1
    
        Call oDerPartDef.ExcludeAll
        Dim oDerPartEnt As DerivedPartEntity
        Set oDerPartEnt = oDerPartDef.Solids(i)
        oDerPartEnt.IncludeEntity = True
        
        Dim oSB As SurfaceBody
        Set oSB = oDerPartEnt.ReferencedEntity
    
        Call partColl.Add(newPart)
        oDerPartDef.DeriveStyle = kDeriveAsWorkSurface
    
        Dim oDerComp As DerivedPartComponent
        Set oDerComp = oDerPartComps.Add(oDerPartDef)
        
        newPart.PropertySets.Item("Inventor Summary Information").Item("Title").Value = oSB.Name
        
        ThisApplication.SilentOperation = True
        Call newPart.SaveAs(folder & oSB.Name & "_" & i & ".ipt", False)
        ThisApplication.SilentOperation = False
    Next i
End Sub

Is this code suitable for you?

=====

Freeradical

 Hideo Yamada

[Anonymous]

That was exactly what I needed, thank you! I just needed to make one small change, as I am trying to derive a single surface body, where you had "Set oDerPartEnt = oDerPartDef.Solids(i)" I changed it to "....oDerPartDef.Surfaces(i)" and it works perfectly.

Again, thank you so much!