Hello Friends,
I have created a macro to measure mass of each part in an Assembly(CatProduct). thread560-514012
The macro is exporting BOM of complete assembly as excel file and then using that BOM to get mass of each part present in the assembly.
The macro is working fine and giving desired outputs but it is taking too much time.
Can you help me to make the macro faster?
here is my code:
I have created a macro to measure mass of each part in an Assembly(CatProduct). thread560-514012
The macro is exporting BOM of complete assembly as excel file and then using that BOM to get mass of each part present in the assembly.
The macro is working fine and giving desired outputs but it is taking too much time.
Can you help me to make the macro faster?
here is my code:
Code:
Public Template As String
Sub ExportBOMandMeasureWeight()
Call BrowseForFolderDialogBox(Template)
If Template <> "" Then
Template = Template & "\" & Left(CATIA.ActiveDocument.Name, Len(CATIA.ActiveDocument.Name) - 11) & ".xls"
Else
GoTo finish1
End If
Dim productDocument1 As ProductDocument
Set productDocument1 = CATIA.ActiveDocument
Dim product1 As Product
Set product1 = productDocument1.Product
Dim assemblyConvertor1 As AssemblyConvertor
Set assemblyConvertor1 = product1.GetItem("BillOfMaterial")
Dim arrayOfVariantOfBSTR1(3)
arrayOfVariantOfBSTR1(0) = "Quantity"
arrayOfVariantOfBSTR1(1) = "Part Number"
arrayOfVariantOfBSTR1(2) = "Type"
arrayOfVariantOfBSTR1(3) = "PTC_WM_NAME"
Set assemblyConvertor1Variant = assemblyConvertor1
assemblyConvertor1Variant.SetCurrentFormat arrayOfVariantOfBSTR1
Dim arrayOfVariantOfBSTR2(1)
arrayOfVariantOfBSTR2(0) = "Quantity"
arrayOfVariantOfBSTR2(1) = "Part Number"
Set assemblyConvertor1Variant = assemblyConvertor1
assemblyConvertor1Variant.SetSecondaryFormat arrayOfVariantOfBSTR2
assemblyConvertor1.[Print] "HTML", Template, product1
MsgBox "Bom Exported Successfully!" & vbCr & "Now measuring weight and density."
Call Getweight
finish1:
End Sub
Sub Getweight()
Dim BOMExcel As Object
'modify settings to measure only shown elements by default
Call MeasureShownElements
On Error Resume Next
'if Excel is already running, then get the Excel object
Set BOMExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
'If Excel is not already running, then create a new session of Excel
Set BOMExcel = CreateObject("Excel.Application")
BOMExcel.Visible = True
End If
'add a new workbook
BOMExcel.Workbooks.Open (Template)
BOMExcel.Visible = True
Set ws = BOMExcel.ActiveWorkbook.Sheets(1)
ws.Cells(4, 6).Value = "CAD Weight"
ws.Cells(4, 7).Value = "Density"
ws.Cells(4, 8).Value = "Hide/Show Status"
With ws
Set findrow = .Range("A:A").Find(What:="Recapitulation", LookIn:=xlValues)
End With
Findrownumber = findrow.Row
If IsEmpty(Findrownumber) = True Then
MsgBox "Error"
GoTo Finish
End If
For i = 1 To Findrownumber - 1
PNtoSearch = ws.Cells(i, 2).Value
'measure weight
Set productDocument1 = CATIA.ActiveDocument
Set product1 = productDocument1.Product
Dim oSelection As Selection
Set oSelection = CATIA.ActiveDocument.Selection
If ws.Cells(i, 3).Value = "Part" Then
oSelection.Search "CATAsmSearch.Part.PartNumber=" & PNtoSearch & ",all"
Dim showstate As CatVisPropertyShow
Set visProperties1 = oSelection.VisProperties
visProperties1.GetShow showstate
Dim objProd As Product
Set objProd = CATIA.ActiveDocument.Selection.Item2(1).Value
Set objInertia = GetProductInertia(objProd)
If Not (objInertia Is Nothing) Then
'Retrieve the mass just to show it worked
'MsgBox objInertia.Mass
ws.Cells(i, 6).Value = objInertia.Mass * 1000
ws.Cells(i, 7).Value = objInertia.Density / 1000
ws.Cells(i, 8).Value = showstate
Else
MsgBox "The Inertia could not be retrieved!"
End If
End If
If ws.Cells(i, 3).Value = "Assembly" Then
oSelection.Search "CATAsmSearch.Assembly.PartNumber=" & PNtoSearch & ",all"
'Dim showstate As CatVisPropertyShow
Set visProperties1 = oSelection.VisProperties
visProperties1.GetShow showstate
'MsgBox showstate
ws.Cells(i, 8).Value = showstate
End If
Next i
MsgBox "Weight Exported!"
'BOMExcel.ActiveWorkbook.Save
Filename = ActiveWorkbook.FullName
If InStr(Filename, ".") > 0 Then
Filename = Left(Filename, InStr(Filename, ".xls") - 1)
End If
ws.SaveAs Filename:=Filename & "_with Weight.xlsx", FileFormat:=xlWorkbookDefault
Finish:
End Sub
Function GetProductInertia(ByRef iProd As Product) As Inertia
'27DEC modify settings to measure only shown elements by default
'Call MeasureShownElements
'If successful, this function will return an inertia object
'Otherwise, Nothing is returned (you should check the return value)
Dim objInertia As Inertia
On Error Resume Next
Set objInertia = iProd.ReferenceProduct.GetTechnologicalObject("Inertia")
'Set ObjDensity = iProd.ReferenceProduct.GetTechnologicalObject("Density")
If Err.Number = 0 Then
Set GetProductInertia = objInertia
Else
Set GetProductInertia = Nothing
End If
End Function
Sub BrowseForFolderDialogBox(FolderPath As String)
Const WINDOW_HANDLE = 0
Const NO_OPTIONS = &H1
Dim objShellApp
Dim objFolder
Dim objFldrItem
Dim objPath
Set objShellApp = CreateObject("Shell.Application")
Set objFolder = objShellApp.BrowseForFolder(WINDOW_HANDLE, strTitle, NO_OPTIONS)
If Not objFolder Is Nothing Then
Set objFldrItem = objFolder.Self
objPath = objFldrItem.Path
FolderPath = objPath
Else
MsgBox "Selection Cancelled..!"
End If
Set objShellApp = Nothing
Set objFolder = Nothing
Set objFldrItem = Nothing
End Sub
Sub MeasureShownElements()
Dim settingControllers1 As SettingControllers
Set settingControllers1 = CATIA.SettingControllers
Dim measureSettingAtt1 As MeasureSettingAtt
Set measureSettingAtt1 = settingControllers1.Item("CATSPAMeasureSettingCtrl")
Dim boolean1 As Boolean
boolean1 = measureSettingAtt1.PartUpdateStatus
Dim boolean2 As Boolean
boolean2 = measureSettingAtt1.ProductUpdateStatus
Dim boolean3 As Boolean
boolean3 = measureSettingAtt1.TildeDisplay
Dim long1 As Long
Dim long2 As Long
Dim long3 As Long
measureSettingAtt1.GetLabelColor long1, long2, long3
Dim short1 As Integer
short1 = measureSettingAtt1.LineWidth
Dim long4 As Long
Dim long5 As Long
Dim long6 As Long
measureSettingAtt1.GetTextColor long4, long5, long6
Dim boolean4 As Boolean
boolean4 = measureSettingAtt1.BoxDisplay
measureSettingAtt1.Commit
Dim boolean5 As Boolean
boolean5 = measureSettingAtt1.PartUpdateStatus
Dim boolean6 As Boolean
boolean6 = measureSettingAtt1.ProductUpdateStatus
Dim boolean7 As Boolean
boolean7 = measureSettingAtt1.TildeDisplay
Dim long7 As Long
Dim long8 As Long
Dim long9 As Long
measureSettingAtt1.GetLabelColor long7, long8, long9
Dim short2 As Integer
short2 = measureSettingAtt1.LineWidth
Dim long10 As Long
Dim long11 As Long
Dim long12 As Long
measureSettingAtt1.GetTextColor long10, long11, long12
Dim boolean8 As Boolean
boolean8 = measureSettingAtt1.BoxDisplay
measureSettingAtt1.PartUpdateStatus = True
measureSettingAtt1.ProductUpdateStatus = True
measureSettingAtt1.TildeDisplay = True
Dim settingRepository1 As SettingRepository
Set settingRepository1 = settingControllers1.Item("MeasureSettings")
settingRepository1.PutAttr "MeasureOnlyShownElementsStatus", 1
measureSettingAtt1.SaveRepository
measureSettingAtt1.Commit
End Sub