Announcements
Attention for Customers without Multi-Factor Authentication or Single Sign-On - OTP Verification rolls out April 2025. Read all about it here.

Test dit eens:

Welke messages krijg je:

 

Imports System.IO
GetInput :

Dim Filename As String = "C:\Autodesk en Templates\PTN_Part_Library\New_PTN_Part_Library.xlsx"



Dim ExcelApp As Object
Dim opened As Boolean
Dim wb As Object
Dim Six_Digit As String

Msgbox ("A")

ExcelApp = GetObject("", "Excel.Application")
opened = False
Msgbox ("B")

For Each wb In ExcelApp.workbooks
	If UCase(wb.fullname) = UCase(Filename) Then
		opened = True
		Msgbox ("C")
		Exit For
	End If
Next

If Not opened Then
	GoExcel.Open("C:\Autodesk en Templates\PTN_Part_Library\New_PTN_Part_Library.xlsx")
	'GoExcel.Open("C:\Users\ef\Desktop\New_PTN_Part_Library.xlsx")

	Msgbox ("D")

Six_Digit = ExcelApp.ActiveCell.Value

Msgbox ("Excel six Digit " & Six_Digit)

If Six_Digit = "" Then
            Return
Else If Len(Six_Digit) <> "6" Then
MessageBox.Show("Input must be 6 digits", "ilogic")
GoTo GetInput

End If



Dim oDoc As Document
Dim sFilename As String

'hard code path
oLibrary_Folder = "C:\Autodesk en Templates\PTN_Part_Library\"


Dim oFilenames() As String
oFilenames = System.IO.Directory.GetFiles(oLibrary_Folder, _
"*.*", SearchOption.AllDirectories)

Msgbox ("E ")
For Each oFilename As String In oFilenames
            Dim oFileNameNoExt As String = System.IO.Path.GetFileNameWithoutExtension(oFilename)
            If oFileNameNoExt.Contains(Six_Digit) AndAlso oFileNameNoExt.Length = 11 Then
                        Dim oOptions As Inventor.NameValueMap
                        oOptions = ThisApplication.TransientObjects.CreateNameValueMap
                        oDoc = ThisApplication.Documents.OpenWithOptions(oFilename, oOptions, False)
                        sFilename = oFilename
                        Exit For
            End If
Next

If sFilename = "" Then
            MessageBox.Show("No matching libary file found.", "iLogic")
            Return
End If

'path from current file
Dim oActiveAssemblyfolder As String = ThisDoc.Path & "\"



Msgbox ("F ")
'find the postion of the last backslash in the path
Dim FNamePos As Integer = InStrRev(sFilename, "\", -1)
'get the file name with the file extension
Dim oName As String = Right(sFilename, Len(sFilename) -FNamePos)
'get the file name (without extension)
Dim ShortName As String = Left(oName, Len(oName) -4)
'get extension
Dim oExt As String = Right(oName, 4)

Msgbox ("G ")
Dim oNewName As String = ShortName & "_" & System.DateTime.Now.ToString("yyyyMdHHmmss")

Dim oPathandName As String = oActiveAssemblyfolder & oNewName & oExt

Msgbox ("H ")

oDoc.PropertySets.Item("Design Tracking Properties").Item("Part Number").Value = ShortName
'save new document
oDoc.SaveAs(oPathandName, True)
oDoc.Close

Msgbox ("I")

'[ Place Component
Dim oAsmCompDef As AssemblyComponentDefinition
oAsmCompDef = ThisApplication.ActiveDocument.ComponentDefinition


Msgbox ("J ")
' Create Matrix
Dim oMatrix As Matrix
oMatrix = ThisApplication.TransientGeometry.CreateMatrix
Call oMatrix.SetTranslation(ThisApplication.TransientGeometry.CreateVector(50, 50, 50), True)


Msgbox ("K ")
'insert new occurence
'Dim oOcc As ComponentOccurrence
'oOcc = oAsmCompDef.Occurrences.Add( _
'oPathandName, oMatrix)
Msgbox ("L ")
ThisApplication.CommandManager.PostPrivateEvent(PrivateEventTypeEnum.kFileNameEvent, oPathandName)
ThisApplication.CommandManager.ControlDefinitions.Item("AssemblyPlaceComponentCmd").Execute
Msgbox ("M ")

Regards,

Arthur Knoors

Autodesk Affiliations:

Autodesk Software:Inventor Professional 2025 | Vault Professional 2024 | Autocad Mechanical 2024
Programming Skills:Vba | Vb.net (Add ins Vault / Inventor, Applications) | I-logic
Programming Examples:Drawing List!|Toggle Drawing Sheet!|Workplane Resize!|Drawing View Locker!|Multi Sheet to Mono Sheet!|Drawing Weld Symbols!|Drawing View Label Align!|Open From Balloon!|Model State Lock!
Posts and Ideas:Dimension Component!|Partlist Export!|Derive I-properties!|Vault Prompts Via API!|Vault Handbook/Manual!|Drawing Toggle Sheets!|Vault Defer Update!


! For administrative reasons, please mark a "Solution as solved" when the issue is solved !