Community
Hi all,
i have made this macro, it works fine but it have one problem. When i lunch it the first time it do all fine, but in the task manager the excel procces remain active. When I relunch it it give mi the error, and don't work.
This is tbe vba code:
Sub BOM_Export() 'Esportazione DB completo e funzionante Dim oApp As Application Set oApp = ThisApplication Dim invDoc As Document Set invDoc = ThisApplication.ActiveDocument Dim oDocument As Inventor.Document Set oDocument = ThisApplication.ActiveDocument Dim invDesignInfo As PropertySet Set invDesignInfo = invDoc.PropertySets.Item("Design Tracking Properties") Dim invPartNumberProperty As Property Set invPartNumberProperty = invDesignInfo.Item("Part Number") NumeroParte = invPartNumberProperty.Value Estensione = (".csv") Patch = GetFilePatch(oDocument.FullFileName) PercaorsoNomeEst = (Patch & NumeroParte & Estensione) 'Data Dim DataCmp As String 'DataCmp = (Day(Date) & "/" & Month(Date) & "/" & Year(Date)) DataCmp = Date$ 'DataCmp = (Month(Date) & "/" & Day(Date) & "/" & Year(Date)) Dim oDoc As AssemblyDocument Set oDoc = ThisApplication.ActiveDocument Dim oBOM As BOM Set oBOM = oDoc.ComponentDefinition.BOM ' Imposta corrente il livello Principale Dim oAsmDef As AssemblyComponentDefinition Set oAsmDef = ThisApplication.ActiveDocument.ComponentDefinition oAsmDef.RepresentationsManager.LevelOfDetailRepresentations.Item("Principale").Activate If oApp.ActiveDocument.DocumentType = kAssemblyDocumentObject Then Dim oAssyDoc As AssemblyDocument Set oAssyDoc = oApp.ActiveDocument Dim oAssyCompDef As AssemblyComponentDefinition Set oAssyCompDef = oAssyDoc.ComponentDefinition Dim excel_app As Excel.Application ' Setta la proprietà della vista strutturale al solo di primo livello oBOM.StructuredViewFirstLevelOnly = True ' Attiva la vista strutturata della distinata componenti oBOM.StructuredViewEnabled = True ' Crea l'applicazione Excel Set excel_app = CreateObject("Excel.Application") ' Commenta questa linea se vuoi excel invisibile excel_app.Visible = False 'Crea il foglio di lavoro Call excel_app.Workbooks.Add Dim oBomR As BOMRow Dim oBOMPartNo As String With excel_app .Range("A1").Select .ActiveCell.Value = "Quantity" .Range("B1").Select .ActiveCell.Value = "Part Number" .Range("R1").Select .ActiveCell.Value = "Inizio Validità" 'Iterate through parts only BOM View Dim i As Integer For i = 1 To oAssyCompDef.BOM.BOMViews(2).BOMRows.Count 'Set oBomR to current BOM Row Set oBomR = oAssyCompDef.BOM.BOMViews(2).BOMRows(i) 'Get Current Row part number from part oBOMPartNo = oBomR.ComponentDefinitions(1).Document.PropertySets(3).ItemByPropId(5).Value 'Write values to spreadsheet .Range("A" & i + 1).Select .ActiveCell.Value = oBomR.TotalQuantity 'Quantity value .Range("B" & i + 1).Select .ActiveCell.Value = oBOMPartNo .Range("R" & i + 1).Select .ActiveCell.Value = DataCmp Next i End With Else Exit Sub End If 'Ordina le righe per ordine alfabetico secondo il codice 'Sheets("Foglio1").Select ActiveSheet.Select Columns("A:R").Select Range("A21").Activate ActiveWorkbook.Worksheets("Foglio1").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Foglio1").Sort.SortFields.Add Key:=Range("B2:B200") _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Foglio1").Sort .SetRange Range("A1:R200") .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Range("A1").Select ActiveWorkbook.SaveAs filename:=(PercaorsoNomeEst), FileFormat:=xlCSVWindows, CreateBackup:=False, Local:=True Application.DisplayAlerts = False 'ActiveWorkbook.Close Workbooks(NumeroParte & ".csv").Close SaveChanges:=True excel_app.Quit 'Chiude definitivamente l'applicazione excel Set excel_app = Nothing Set oApp = Nothing Set invDoc = Nothing Set oDocument = Nothing Set invDesignInfo = Nothing Set invPartNumberProperty = Nothing Set oDoc = Nothing Set oBOM = Nothing Set oAsmDef = Nothing Set oAssyDoc = Nothing Set oAssyCompDef = Nothing Set oBomR = Nothing Shell "taskkill /f /im excel.exe" MsgBox "La distinta è stata esportata correttamente!" End Sub 'Funzione che estrae il percorso completo nel quale si trova il file attualmente in uso Private Function GetFilePatch(ByVal sFullFileName As String) As String Dim sFilePatch As String Dim nPos1 As Integer Dim nPosf1 As Integer Dim nPos2 As Integer sFilePatch = sFullFileName nPos1 = InStrRev(sFullFileName, "\") nPos2 = InStrRev(sFullFileName, ".") If nPos1 > 0 Then sFilePacth = Mid$(sFullFileName, nPos1 + 1) End If nPosf1 = InStr(sFullFileName, ".") If nPos1 > 0 Then sFilePatch = Left$(sFilePatch, nPosf1 - (nPos2 - nPos1)) End If GetFilePatch = sFilePatch End Function
I enclose the screen of the error who gives me in the second esecution.
Solved! Go to Solution.
Azzz... I have find the error... In the code is missing one End!!!
Sub BOM_Export() 'Esportazione DB completo e funzionante Dim oApp As Application Set oApp = ThisApplication Dim invDoc As Document Set invDoc = ThisApplication.ActiveDocument Dim oDocument As Inventor.Document Set oDocument = ThisApplication.ActiveDocument Dim invDesignInfo As PropertySet Set invDesignInfo = invDoc.PropertySets.Item("Design Tracking Properties") Dim invPartNumberProperty As Property Set invPartNumberProperty = invDesignInfo.Item("Part Number") NumeroParte = invPartNumberProperty.Value Estensione = (".csv") Patch = GetFilePatch(oDocument.FullFileName) PercaorsoNomeEst = (Patch & NumeroParte & Estensione) 'Data Dim DataCmp As String 'DataCmp = (Day(Date) & "/" & Month(Date) & "/" & Year(Date)) DataCmp = Date$ 'DataCmp = (Month(Date) & "/" & Day(Date) & "/" & Year(Date)) Dim oDoc As AssemblyDocument Set oDoc = ThisApplication.ActiveDocument Dim oBOM As BOM Set oBOM = oDoc.ComponentDefinition.BOM ' Imposta corrente il livello Principale Dim oAsmDef As AssemblyComponentDefinition Set oAsmDef = ThisApplication.ActiveDocument.ComponentDefinition oAsmDef.RepresentationsManager.LevelOfDetailRepresentations.Item("Principale").Activate If oApp.ActiveDocument.DocumentType = kAssemblyDocumentObject Then Dim oAssyDoc As AssemblyDocument Set oAssyDoc = oApp.ActiveDocument Dim oAssyCompDef As AssemblyComponentDefinition Set oAssyCompDef = oAssyDoc.ComponentDefinition Dim excel_app As Excel.Application ' Setta la proprietà della vista strutturale al solo di primo livello oBOM.StructuredViewFirstLevelOnly = True ' Attiva la vista strutturata della distinata componenti oBOM.StructuredViewEnabled = True ' Crea l'applicazione Excel Set excel_app = CreateObject("Excel.Application") ' Commenta questa linea se vuoi excel invisibile excel_app.Visible = False 'Crea il foglio di lavoro Call excel_app.Workbooks.Add Dim oBomR As BOMRow Dim oBOMPartNo As String With excel_app .Range("A1").Select .ActiveCell.Value = "Quantity" .Range("B1").Select .ActiveCell.Value = "Part Number" '.Range("R1").Select '.ActiveCell.Value = "Inizio Validità" 'Iterate through parts only BOM View Dim i As Integer For i = 1 To oAssyCompDef.BOM.BOMViews(2).BOMRows.Count 'Set oBomR to current BOM Row Set oBomR = oAssyCompDef.BOM.BOMViews(2).BOMRows(i) 'Get Current Row part number from part oBOMPartNo = oBomR.ComponentDefinitions(1).Document.PropertySets(3).ItemByPropId(5).Value 'Write values to spreadsheet .Range("A" & i + 1).Select .ActiveCell.Value = oBomR.TotalQuantity 'Quantity value .Range("B" & i + 1).Select .ActiveCell.Value = oBOMPartNo '.Range("R" & i + 1).Select '.ActiveCell.Value = DataCmp Next i End With Else Exit Sub End If 'Ordina le righe per ordine alfabetico secondo il codice 'Sheets("Foglio1").Select ActiveSheet.Select Columns("A:R").Select Range("A21").Activate ActiveWorkbook.Worksheets("Foglio1").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Foglio1").Sort.SortFields.Add Key:=Range("B2:B200") _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Foglio1").Sort .SetRange Range("A1:R200") .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With ActiveWorkbook.SaveAs filename:=(PercaorsoNomeEst), FileFormat:=xlCSVWindows, CreateBackup:=False, Local:=True Application.DisplayAlerts = False ActiveWorkbook.Close excel_app.Quit 'Chiude definitivamente l'applicazione excel MsgBox "La distinta è stata esportata correttamente!" End ' <== THIS IS THE MISSING END End Sub 'Funzione che estrae il percorso completo nel quale si trova il file attualmente in uso Private Function GetFilePatch(ByVal sFullFileName As String) As String Dim sFilePatch As String Dim nPos1 As Integer Dim nPosf1 As Integer Dim nPos2 As Integer sFilePatch = sFullFileName nPos1 = InStrRev(sFullFileName, "\") nPos2 = InStrRev(sFullFileName, ".") If nPos1 > 0 Then sFilePacth = Mid$(sFullFileName, nPos1 + 1) End If nPosf1 = InStr(sFullFileName, ".") If nPos1 > 0 Then sFilePatch = Left$(sFilePatch, nPosf1 - (nPos2 - nPos1)) End If GetFilePatch = sFilePatch End Function