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

Hi EMVC,

 

If you need Part List on the drawing document, delete all the codes and insert follows :

Option Explicit

Private Const TempWorkBookName = "TempWorkBook.xlsx"
Private oExcelApp As Excel.Application
Private TempWorkbookFullName As String

Public Sub CollectOpenedIdwPartLists()
    ' Init WSH and temp path
    Dim WSH As Variant
    Set WSH = CreateObject("WScript.Shell")
    TempWorkbookFullName = WSH.SpecialFolders("Desktop") & "\" & TempWorkBookName
    
    ' Setup Excel
    Set oExcelApp = CreateObject("Excel.Application")
    oExcelApp.Visible = True
    oExcelApp.DisplayAlerts = False
    Dim oWorkbook As Workbook
    Set oWorkbook = oExcelApp.Workbooks.Add
    
    ' Create DrawingDoc collection
    Dim oDrawingDocs As ObjectCollection
    Set oDrawingDocs = CreateDrawingDocs
    
    ' Collect BOMs into one workbook
    MsgBox "Start Step 1"
    CollectPartListsFromDocs oDrawingDocs, oWorkbook
    
    ' Combine worksheets into one sheet
    MsgBox "Start Step 2"
    CombineWorksheets oWorkbook
    
    ' end
    oExcelApp.DisplayAlerts = True
    Set oExcelApp = Nothing
    MsgBox "End"
End Sub

Private Function CreateDrawingDocs() As ObjectCollection
    Set CreateDrawingDocs = ThisApplication.TransientObjects.CreateObjectCollection
    Dim oDoc As Document
    For Each oDoc In ThisApplication.Documents
        If TypeOf oDoc Is DrawingDocument Then
            Dim oDrawingDoc As DrawingDocument
            Set oDrawingDoc = oDoc
            If oDrawingDoc.ActiveSheet.PartsLists.Count > 0 Then
                CreateDrawingDocs.Add oDrawingDoc
            End If
        End If
    Next oDoc
End Function

Private Sub CollectPartListsFromDocs(oDrawingDocs As ObjectCollection, oWorkbook As Workbook)
    Dim oDrawingDoc As DrawingDocument
    For Each oDrawingDoc In oDrawingDocs
        ExportPartListAsWorkbook oDrawingDoc
        Dim oTempWorkbook As Workbook
        Set oTempWorkbook = oExcelApp.Workbooks.Open(TempWorkbookFullName)
        oTempWorkbook.Sheets(1).Move After:=oWorkbook.Sheets(1)
        Kill TempWorkbookFullName
    Next oDrawingDoc
End Sub

Private Sub CombineWorksheets(oWorkbook As Workbook)
    If oWorkbook.Sheets.Count <= 1 Then
        Exit Sub
    End If
    
    ' Copy title line
    oWorkbook.Sheets(2).Rows(1).Copy oWorkbook.Sheets(1).Rows(1)
    
    ' Copy all sheets into one
    Dim oSheet As WorkSheet
    Dim rowIndex As Integer
    rowIndex = 2
    
    While oWorkbook.Sheets.Count > 1
        Dim r As Range
'        Set r = oWorkbook.Sheets(2).Cells(2, 1)
'        Set r = Range(r, r.End(xlDown)).EntireRow
        Set r = oWorkbook.Sheets(2).Rows("2:" & oWorkbook.Sheets(2).Cells(2, 1).End(xlDown).Row)
        r.Copy oWorkbook.Sheets(1).Cells(rowIndex, 1)
        rowIndex = rowIndex + r.Rows.Count
        oWorkbook.Sheets(2).Delete
    Wend
End Sub

Private Sub ExportPartListAsWorkbook(oDrawingDoc As DrawingDocument)
    oDrawingDoc.ActiveSheet.PartsLists(1).Export TempWorkbookFullName, kMicrosoftExcel, oDrawingDoc.DisplayName
End Sub


And if you don't need to combine lists into one sheet, comment out following codes or simply delete them :

    ' Combine worksheets into one sheet
    MsgBox "Start Step 2"
    CombineWorksheets oWorkbook

 

=====

Freeradical

 Hideo Yamada

 

=====
Freeradical
 Hideo Yamada
https://www.freeradical.jp