Solved: Re: VBA Excel error

varga_zsolt · ‎03-27-2014

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.

mrattray · ‎03-27-2014

I didn't analyze your macro, but try adding this line to the end:
Set excel_app = Nothing

Mike (not Matt) Rattray

varga_zsolt · ‎03-27-2014

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

mrattray · ‎03-27-2014

I'm glad you got it figured out!

Mike (not Matt) Rattray

VBA Excel error

VBA Excel error

Forums Links

Post to forums