VBA help

[Anonymous]

Hi

I found the below code at Mod the Machine , Thanks to Brian Ekins

http://modthemachine.typepad.com/my_weblog/2016/01/open-drawing-from-a-part-or-assembly.html

I do not know any think about VBA ,so help is needed

Because When running a debug it stops at:

Set partDoc = ThisApplication.ActiveDocument 

Can anyone tell me if I am doing some think wrong or what is wrong

I use the VBA Editor in Inventor 2017

""""""""""""""""""""""""""""""""""""""""""""

Public Sub FindDrawingTest()
    Dim partDoc As PartDocument
    Set partDoc = ThisApplication.ActiveDocument 
    
    ' Call the function to get the drawing. 
    Dim drawingFilename As String
    drawingFilename = FindDrawingFile(partDoc)
   
    ' Display the result.
    If drawingFilename <> "" Then
        MsgBox "The drawing for """ & partDoc.fullFilename & """ was found: " & vbCr & drawingFilename
    Else
        MsgBox "No drawing was found for """ & partDoc.fullFilename & """"
    End If
End Sub


' Find the drawing for the specified part of assembly.
Private Function FindDrawingFile(PartOrAssemblyDoc As Document)
    Dim fullFilename As String
    fullFilename = PartOrAssemblyDoc.fullFilename
   
    ' Extract the path from the full filename.
    Dim path As String
    path = Left$(fullFilename, InStrRev(fullFilename, "\"))
   
    ' Extract the filename from the full filename.
    Dim filename As String
    filename = Right$(fullFilename, Len(fullFilename) - InStrRev(fullFilename, "\"))
   
    ' Replace the extension with "dwg"
    filename = Left$(filename, InStrRev(filename, ".")) & "dwg"
   
    ' Find if the drawing exists.
    Dim drawingFilename As String
    drawingFilename = ThisApplication.DesignProjectManager.ResolveFile(path, filename)
   
    ' Check the result.
    If drawingFilename = "" Then
        ' Try again with idw extension.
        filename = Left$(filename, InStrRev(filename, ".")) & "idw"
       
        ' Find if the drawing exists.
        drawingFilename = ThisApplication.DesignProjectManager.ResolveFile(path, filename)
   
        ' Return the result.
        If drawingFilename <> "" Then
            FindDrawingFile = drawingFilename
        Else
            FindDrawingFile = ""
        End If
    Else
        ' Return the result.
        FindDrawingFile = drawingFilename
    End If
End Function

"""""""""""""""""""""""

[tolgay.hickiran]

Dim partDoc As PartDocument
Set partDoc = ThisApplication.ActiveDocument

If a PARTDOCUMENT is open on inventor this will work, you might be on an ASSEMBLYDOCUMENT while you are trying to work the code.

I'd recommend you to use DEBUG MODE, which can be started from F8 key on your keyboard in the VBA Editor.

[MechMachineMan]

As @tolgay.hickiran said...

Public Sub FindDrawingTest()
    Dim Doc As Document
    Set Doc = ThisApplication.ActiveDocument 
    
    ' Call the function to get the drawing. 
    Dim drawingFilename As String
    drawingFilename = FindDrawingFile(Doc)
   
    ' Display the result.
    If drawingFilename <> "" Then
        MsgBox "The drawing for """ & Doc.fullFilename & """ was found: " & vbCr & drawingFilename
    Else
        MsgBox "No drawing was found for """ & Doc.fullFilename & """"
    End If
End Sub


' Find the drawing for the specified part of assembly.
Private Function FindDrawingFile(PartOrAssemblyDoc As Document)
    Dim fullFilename As String
    fullFilename = PartOrAssemblyDoc.fullFilename
   
    ' Extract the path from the full filename.
    Dim path As String
    path = Left$(fullFilename, InStrRev(fullFilename, "\"))
   
    ' Extract the filename from the full filename.
    Dim filename As String
    filename = Right$(fullFilename, Len(fullFilename) - InStrRev(fullFilename, "\"))
   
    ' Replace the extension with "dwg"
    filename = Left$(filename, InStrRev(filename, ".")) & "dwg"
   
    ' Find if the drawing exists.
    Dim drawingFilename As String
    drawingFilename = ThisApplication.DesignProjectManager.ResolveFile(path, filename)
   
    ' Check the result.
    If drawingFilename = "" Then
        ' Try again with idw extension.
        filename = Left$(filename, InStrRev(filename, ".")) & "idw"
       
        ' Find if the drawing exists.
        drawingFilename = ThisApplication.DesignProjectManager.ResolveFile(path, filename)
   
        ' Return the result.
        If drawingFilename <> "" Then
            FindDrawingFile = drawingFilename
        Else
            FindDrawingFile = ""
        End If
    Else
        ' Return the result.
        FindDrawingFile = drawingFilename
    End If
End Function

[Anonymous]

Yes , It works when I have a part open.

But it only looks in the folder as the part , is it possible to make it look in may be two  preset different folders?

[MechMachineMan]

You could try this.

Modify oPathList as required.

Does not handling searching sub-folders; every directory must be listed explicitly.

Public Sub FindDrawingTest()
    Dim Doc As Document
    Set Doc = ThisApplication.ActiveDocument 
    
    Dim drawingFilename As String
    drawingFilename = FindDrawingFile(Doc)
   
    If drawingFilename <> "" Then
        MsgBox "The drawing for """ & Doc.fullFilename & """ was found: " & vbCr & drawingFilename
    Else
        MsgBox "No drawing was found for """ & Doc.fullFilename & """"
    End If
End Sub


Private Function FindDrawingFile(PartOrAssemblyDoc As Document)
    Dim oPathList As String(0 to 1)
    oPathList(0) = "PARENT"
    oPathList(1) = "D:\"
    oPathList(2) = "C:\"

    Dim fullFilename As String
    fullFilename = PartOrAssemblyDoc.fullFilename
   
    Dim opath As String
    opath = Left$(fullFilename, InStrRev(fullFilename, "\"))
   
    Dim filename As String
    filename = Right$(fullFilename, Len(fullFilename) - InStrRev(fullFilename, "\"))
    filename = Left$(filename, InStrRev(filename, ".")) & "dwg"
  
    For j = 0 to UBound(oPathList)

    	Dim drawingFilename As String
	If oPathList(j) = "PARENT"
		path = opath
	else
		path = oPathList(j)
	End if

	drawingFilename = ThisApplication.DesignProjectManager.ResolveFile(path, filename)
	
    	If drawingFilename = "" Then
            	filename = Left$(filename, InStrRev(filename, ".")) & "idw"
            	drawingFilename = ThisApplication.DesignProjectManager.ResolveFile(path, filename)
   
            	If drawingFilename = "" Then
		Else
			FindDrawingFile = drawingFilename
			Exit Function
            	End If
	Else
		FindDrawingFile = drawingFilename
		Exit Function	
   	End If
    Next

    FindDrawingFile = ""
End Function

[Anonymous]

Hi Justin

Thanks for Your reply

When I run your code I get this message

As I said earlier  ,I do not know anything about VBA , so I am lost

[MechMachineMan]

At least TRYING to learn something could get you somewhere... Google is a wonderful resource.

Fixed version included below:

Public Sub FindDrawingTest()
    Dim Doc As Document
    Set Doc = ThisApplication.ActiveDocument
    
    Dim drawingFilename As String
    drawingFilename = FindDrawingFile(Doc)
   
    If drawingFilename <> "" Then
        MsgBox "The drawing for """ & Doc.fullFilename & """ was found: " & vbCr & drawingFilename
        ThisApplication.Documents.Open drawingFilename
    Else
        MsgBox "No drawing was found for """ & Doc.fullFilename & """"
    End If
End Sub


Private Function FindDrawingFile(PartOrAssemblyDoc As Document)
    Dim oPathList(0 To 2) As String
    oPathList(0) = "PARENT"
    oPathList(1) = "D:\"
    oPathList(2) = "C:\"

    Dim fullFilename As String
    fullFilename = PartOrAssemblyDoc.fullFilename
   
    Dim opath As String
    opath = Left$(fullFilename, InStrRev(fullFilename, "\"))
   
    Dim filename As String
    filename = Right$(fullFilename, Len(fullFilename) - InStrRev(fullFilename, "\"))
    filename = Left$(filename, InStrRev(filename, ".")) & "dwg"
  
    For j = 0 To UBound(oPathList)

        Dim drawingFilename As String
        
        If oPathList(j) = "PARENT" Then
            Path = opath
        Else
            Path = oPathList(j)
        End If
    
        drawingFilename = ThisApplication.DesignProjectManager.ResolveFile(Path, filename)
    
        If drawingFilename = "" Then
            filename = Left$(filename, InStrRev(filename, ".")) & "idw"
            drawingFilename = ThisApplication.DesignProjectManager.ResolveFile(Path, filename)
   
            If drawingFilename = "" Then
            Else
                FindDrawingFile = drawingFilename
                Exit Function
            End If
        Else
            FindDrawingFile = drawingFilename
            Exit Function
        End If
    Next

    FindDrawingFile = ""
End Function