Autor
|
Thema: ProductToPart für Arme (5083 mal gelesen)
|
joehz Moderator Freiberuflicher Konstrukteur
Beiträge: 1057 Registriert: 25.11.2006 Win7 Pro 64 + Ubuntu + Irix6.5.20 Dell Precision M6600 i7-2960XM 2.7GHz 16GB NVidia Quadro M5010 Catia V5R19 VB6Pro.SP6/VBA 6.5.1053
|
erstellt am: 27. Feb. 2015 14:40 <-- editieren / zitieren --> Unities abgeben:
Hallo Leut', ich wollte kurz mein Macro 'Poor Man's Product To Part' vorstellen. Falls nur Solids kopiert werden müssen, reicht's schon aus. Wer geschlossene Flächen, Achsensysteme etc. braucht, muss noch warten. Lauffähig/entwickelt im VBA-Editor. Enjoy, Joe Code:
Option Explicit Const strVersion As String = "V1.0" Const strMacroName As String = "Poor Man's ProductToPart"Public iBodyCount As Integer 'counter for stats Public oRefAx As AxisSystem 'Part Ref axis system,1/1/1;0/0/0 Public oDestDoc As PartDocument 'destinaton for allcatpart Sub CatMain() Dim oRootProd As Product Dim oSourceWindow As Window Dim arrRootPos(11) Dim tmStart As Date Dim tmEnd As Date tmStart = Time$ iBodyCount = 0 Set oSourceWindow = CATIA.ActiveWindow Set oRootProd = GetRootProd If oRootProd Is Nothing Then End Set oDestDoc = CreateNewPart(oRootProd.Name & "_AllCatPart", "AllCatPart aus " & oRootProd.Name) 'create destination part Set oRefAx = CreateNewAxisSp(oDestDoc.Part, "RefAxis") oSourceWindow.Activate arrRootPos(0) = 1 'reset axis cooords to arrRootPos(1) = 0 'standard r/h system arrRootPos(2) = 0 arrRootPos(3) = 0 arrRootPos(4) = 1 arrRootPos(5) = 0 arrRootPos(6) = 0 arrRootPos(7) = 0 arrRootPos(8) = 1 arrRootPos(9) = 0 arrRootPos(10) = 0 arrRootPos(11) = 0 CATIA.RefreshDisplay = False CATIA.DisplayFileAlerts = False CATIA.HSOSynchronized = False RunTree oRootProd, arrRootPos() oDestDoc.Part.Update CATIA.HSOSynchronized = True CATIA.DisplayFileAlerts = True CATIA.RefreshDisplay = True CATIA.StatusBar = "Macro finished. " tmEnd = Time$ MsgBox "Start: " & tmStart & vbCrLf _ & "Ende: " & tmEnd & vbCrLf _ & iBodyCount & " Bodies copied.", _ vbOKOnly Or vbInformation, strMacroName & "/" & strVersion End Sub Function GetRootProd() As Product Dim oSel As Selection Set oSel = CATIA.ActiveDocument.Selection If oSel.Count2 = 1 Then If oSel.Item(1).Type = "Product" Then Set GetRootProd = oSel.Item2(1).Value Else MsgBox "This macro needs a product to work!" & vbCr & "Exiting macro ...", vbOKOnly Or vbCritical, "GetRootProd - " & strMacroName & "/" & strVersion End If Else MsgBox "Select a product first!" & vbCr & "Exiting macro ...", vbOKOnly Or vbCritical, "GetRootProd - " & strMacroName & "/" & strVersion End End If End Function Sub RunTree(oRoot As Product, arrRootProd()) Dim i As Integer Dim n As Integer Dim arrInv(11) 'inverse pos Dim arrPos(11) 'part pos Dim arrProdPos(11) 'prod pos Dim arrResPos(11) 'result from part matrix multiply Dim arrResProdPos(11) 'result from product matrix multiply Dim oProdItem As Object 'Product Dim strCoord As String Dim oP As Part Dim oSel As Selection 'source selection Dim oDestSel As Selection 'destination selection Dim showstate As CatVisPropertyShow Dim strNewBody As String 'name of created body Dim oTransAx As Object 'AxisSystem 'Dest Ax Sys for catpart Ax2Ax translation Dim arrOrg(2) 'PutOrigin - array Dim arrVX(2) 'PutXAxis - array Dim arrVY(2) 'PutYAxis - array Dim arrVZ(2) 'PutZAxis - array Dim oRefRefAx As Reference 'Ref element source Dim oRefTransAx As Reference 'Ref element dest Dim oAxisToAxis As ShapeFactory 'translate op '--------------------------------------------------------------------------------------------------- ' TODO: ' - rearrange code within loops/If-Else-cases ' - shapes.count reicht nicht aus; bodies mit aufgeboolten leeren bodies werden nicht ausgeschlossen! ' - body-bezeichnungen ändern -> (Product.Instance)/(Product.Instance)/PartNumber.Instance/BodyName '(- alle bodies aus allcatpart in neues catpart kopieren; -> die achsen und translates verschwinden;) ' - arrays umbenennen ' - untersuchen, ob instanzen komplett kopiert werden können (Strategie?) ' - body-translation als datum/blitz? ' - closed shells berücksichtigen! (-> geosets checken) ' - achsensysteme kopieren '--------------------------------------------------------------------------------------------------- Set oSel = CATIA.ActiveDocument.Selection For i = 1 To oRoot.Products.Count ' MsgBox oRoot.Products.Item(i).Name Set oProdItem = oRoot.Products.Item(i) oSel.Clear oSel.Add oProdItem 'check if noshow oSel.VisProperties.GetShow showstate 'is the part visible, go on oSel.Clear If showstate = catVisPropertyShowAttr Then 'if noshow, skip oProdItem.ApplyWorkMode (DEFAULT_MODE) 'set work mode to default If TypeName(oProdItem.ReferenceProduct.Parent) = "ProductDocument" Then oProdItem.position.GetComponents arrProdPos 'get zb axis coords if in zb 'multiply new array with old array; FIRST arg must be NEW array! MatrixProduct arrProdPos, arrRootProd, arrResProdPos 'build array product RunTree oProdItem, arrResProdPos 'reenter one level down ElseIf TypeName(oProdItem.ReferenceProduct.Parent) = "PartDocument" Then oProdItem.position.GetComponents arrPos 'combine axis position arrays MatrixProduct arrPos, arrRootProd, arrResPos 'build resulting array (NEW,OLD,RESULT)! Set oTransAx = CreateNewAxisSp(oDestDoc.Part, "TransAxis" & oRoot.Products.Item(i).Name, False) oSel.Add oTransAx oSel.VisProperties.SetShow catVisPropertyNoShowAttr 'set noshow oSel.Clear arrOrg(0) = arrResPos(9) arrOrg(1) = arrResPos(10) arrOrg(2) = arrResPos(11) oTransAx.PutOrigin arrOrg arrVX(0) = arrResPos(0) arrVX(1) = arrResPos(1) arrVX(2) = arrResPos(2) oTransAx.PutXAxis arrVX arrVY(0) = arrResPos(3) arrVY(1) = arrResPos(4) arrVY(2) = arrResPos(5) oTransAx.PutYAxis arrVY arrVZ(0) = arrResPos(6) arrVZ(1) = arrResPos(7) arrVZ(2) = arrResPos(8) oTransAx.PutZAxis arrVZ Set oRefRefAx = oDestDoc.Part.CreateReferenceFromObject(oRefAx) Set oRefTransAx = oDestDoc.Part.CreateReferenceFromObject(oTransAx) Set oP = oProdItem.ReferenceProduct.Parent.Part For n = 1 To oP.Bodies.Count If oP.Bodies.Item(n).InBooleanOperation = False Then 'if not root body, skip If oP.Bodies.Item(n).Shapes.Count <> 0 Then 'if bodies are empty, skip If oP.IsUpToDate(oP.Bodies.Item(n)) = False Then 'if not up-to-date oP.UpdateObject oP.Bodies.Item(n) 'update the body DoEvents 'just in case End If oSel.Add oP.Bodies.Item(n) oSel.Copy oSel.Clear Set oDestSel = oDestDoc.Selection oDestSel.Clear oDestSel.Add oDestDoc.Part oDestSel.PasteSpecial "CATPrtResultWithOutLink" DoEvents oDestSel.Clear strNewBody = oRoot.Products.Item(i).Name & "/" & oP.Bodies.Item(n).Name ' & "//" & strCoord oDestDoc.Part.Bodies.Item(oDestDoc.Part.Bodies.Count).Name = strNewBody ' Debug.Print oProdItem.Name, oP.Bodies.Item(n).Name, oP.IsUpToDate(oP.Bodies.Item(n)), showstate Set oAxisToAxis = oDestDoc.Part.ShapeFactory.AddNewAxisToAxis2(oRefRefAx, oRefTransAx) iBodyCount = iBodyCount + 1 End If End If Next '--------------------------------------------------------------------------------------------------- Else 'other End If End If Next End Sub Function CreateNewPart(strPNumber As String, strDescriptor As String) As PartDocument Dim oADPDoc As PartDocument Dim oADProd As Product Set oADPDoc = CATIA.Documents.Add("Part") 'create new part Set oADProd = CATIA.ActiveDocument.Product oADProd.PartNumber = strPNumber 'change partnumber oADProd.DescriptionRef = strDescriptor 'add descriptor CATIA.ActiveDocument.Part.Update 'update CATIA.StatusBar = "Creating New Part!" Set CreateNewPart = oADPDoc End Function Function CreateNewAxisSp(oParent As Part, strAxisName As String, Optional iCurr As Boolean = True, Optional iAxType As CATAxisSystemMainType = catAxisSystemStandard) As AxisSystem 'ToDo 'Fehler abfangen: bei bereits vorhandenem Part gleichen namens in der session Dim oAxSyst As AxisSystem Set oAxSyst = oParent.AxisSystems.Add() oParent.UpdateObject oAxSyst oAxSyst.Type = iAxType oAxSyst.IsCurrent = iCurr oAxSyst.Name = strAxisName oParent.Update Set CreateNewAxisSp = oAxSyst End Function ' *********************************************************************** ' ' Purpose: Define the product of two matrix. ' ' Inputs : matrix1 Array array corresponding to the first matrix ' matrix2 Array array corresponding to the second matrix ' ' Outputs: res Array array corresponding to the product ' ' *********************************************************************** ' Borrowed from Dassault macro Public Sub MatrixProduct(ByVal matrix1, ByVal matrix2, ByRef res) Dim a(11) Dim b(11) Dim i As Integer For i = 0 To 11 a(i) = matrix1(i) b(i) = matrix2(i) Next res(0) = a(0) * b(0) + a(1) * b(3) + a(2) * b(6) res(3) = a(3) * b(0) + a(4) * b(3) + a(5) * b(6) res(6) = a(6) * b(0) + a(7) * b(3) + a(8) * b(6) res(1) = a(0) * b(1) + a(1) * b(4) + a(2) * b(7) res(4) = a(3) * b(1) + a(4) * b(4) + a(5) * b(7) res(7) = a(6) * b(1) + a(7) * b(4) + a(8) * b(7) res(2) = a(0) * b(2) + a(1) * b(5) + a(2) * b(8) res(5) = a(3) * b(2) + a(4) * b(5) + a(5) * b(8) res(8) = a(6) * b(2) + a(7) * b(5) + a(8) * b(8) res(9) = a(9) * b(0) + a(10) * b(3) + a(11) * b(6) + b(9) res(10) = a(9) * b(1) + a(10) * b(4) + a(11) * b(7) + b(10) res(11) = a(9) * b(2) + a(10) * b(5) + a(11) * b(8) + b(11) End Sub
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
gunngir Mitglied Technischer Produktdesigner
Beiträge: 17 Registriert: 17.06.2014 Catia V5R19 SP9 64Bit
|
erstellt am: 02. Mrz. 2015 08:25 <-- editieren / zitieren --> Unities abgeben: Nur für joehz
Wow danke, genau das wonach ich gesucht habe Das Makro funktioniert, auch bei großen Baugruppen. Danke dafür! (auch wenn ich die Logik des Makros noch nicht 100%ig verstanden habe, da Bool'sche Operationen und eine Matrix noch Neuland sind.) aber vielleicht kommt das noch *hust* Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
joehz Moderator Freiberuflicher Konstrukteur
Beiträge: 1057 Registriert: 25.11.2006 Win7 Pro 64 + Ubuntu + Irix6.5.20 Dell Precision M6600 i7-2960XM 2.7GHz 16GB NVidia Quadro M5010 Catia V5R19 VB6Pro.SP6/VBA 6.5.1053
|
erstellt am: 02. Mrz. 2015 11:44 <-- editieren / zitieren --> Unities abgeben:
Hallo gunngir, ich hab noch zwei Änderungen vorgenommen,die ich Dir nicht vorenthalten möchte. Im Wesentlichen betrifft es die Benamsung der Bodies und die Fehlermeldung, die dann auftritt, falls das AllCatPart schon existiert. Ansonsten: - Bool'sche Ops kommen nicht vor. Es wird nur abgefragt, ob der fragliche Body eventuell z.B. ein Abzugskörper ist. - Die Matritzen-Routine hab ich von Dassault gekupfert. Die Vorgehensweise ist im Dassault-Macro 'DMUPstCopyPasteKeepAbsolutePositionSource' beschrieben. - Das eigentlich tückische ist die Rekursion von RunTree. - Gelegentlich fliegt das Macro aus der Kurve. Offenbar mag Catia wiederholte gleiche Workmode-Änweisungen nicht. Abhilfe: Händisch Product auf 'RB-Click/Representations/Visualization Mode' setzen. Dann sollt's wieder klappen. Enjoy, Joe
Code:
Option Explicit Const strVersion As String = "V1.1" Const strMacroName As String = "Poor Man's ProductToPart"Public iBodyCount As Integer 'counter for stats Public oRefAx As AxisSystem 'Part Ref axis system,1/1/1;0/0/0 Public oDestDoc As PartDocument 'destinaton for allcatpart Sub CatMain() Dim oRootProd As Product Dim oSourceWindow As Window Dim oDestWindow As Window Dim arrRootPos(11) Dim tmStart As Date Dim tmEnd As Date tmStart = Time$ iBodyCount = 0 Set oSourceWindow = CATIA.ActiveWindow Set oRootProd = GetRootProd If oRootProd Is Nothing Then End Set oDestDoc = CreateNewPart(oRootProd.Name & "_AllCatPart", "AllCatPart aus " & oRootProd.Name) 'create destination part Set oDestWindow = CATIA.Windows.Item(CATIA.Windows.Count) Set oRefAx = CreateNewAxisSp(oDestDoc.Part, "RefAxis") oSourceWindow.Activate arrRootPos(0) = 1 'reset axis cooords to arrRootPos(1) = 0 'standard r/h system arrRootPos(2) = 0 arrRootPos(3) = 0 arrRootPos(4) = 1 arrRootPos(5) = 0 arrRootPos(6) = 0 arrRootPos(7) = 0 arrRootPos(8) = 1 arrRootPos(9) = 0 arrRootPos(10) = 0 arrRootPos(11) = 0 CATIA.RefreshDisplay = False CATIA.DisplayFileAlerts = False CATIA.HSOSynchronized = False RunTree oRootProd, arrRootPos(), "" oDestDoc.Part.Update CATIA.HSOSynchronized = True CATIA.DisplayFileAlerts = True oDestWindow.Activate CATIA.StartCommand "Fit All In" DoEvents CATIA.RefreshDisplay = True CATIA.StatusBar = "Macro finished. " tmEnd = Time$ MsgBox "Start: " & tmStart & vbCrLf _ & "Ende: " & tmEnd & vbCrLf _ & iBodyCount & " Bodies copied.", _ vbOKOnly Or vbInformation, strMacroName & "/" & strVersion End Sub Function GetRootProd() As Product Dim oSel As Selection Set oSel = CATIA.ActiveDocument.Selection If oSel.Count2 = 1 Then If oSel.Item(1).Type = "Product" Then Set GetRootProd = oSel.Item2(1).Value Else MsgBox "This macro needs a product to work!" & vbCr & "Exiting macro ...", vbOKOnly Or vbCritical, "GetRootProd - " & strMacroName & "/" & strVersion End If Else MsgBox "Select a product first!" & vbCr & "Exiting macro ...", vbOKOnly Or vbCritical, "GetRootProd - " & strMacroName & "/" & strVersion End End If End Function '--------------------------------------------------------------------------------------- ' Procedure : RunTree ' Author : jherzog ' Date : 27.02.2015 ' Time : 18:49 ' Languages : VBA 6.5 ' V5-Release: V5R19/21 ' Purpose : ' Parms : oRoot: the root product from where the search begins ' : arrRootProd(): array holding axis coordinates ' Ret. Value: - ' ' Syntax : RunTree oRootProd, arrRootPos() ' ' Prereqs : ' Remarks : '--------------------------------------------------------------------------------------- ' ChangeLog : 28.02.2015 : body names changed ' ' ' ' ' ' ' '--------------------------------------------------------------------------------------- Sub RunTree(oRoot As Product, arrRootProd(), strNewBodyPath As String) Dim i As Integer Dim n As Integer Dim arrInv(11) 'inverse pos Dim arrPos(11) 'part pos Dim arrProdPos(11) 'prod pos Dim arrResPos(11) 'result from part matrix multiply Dim arrResProdPos(11) 'result from product matrix multiply Dim oProdItem As Object 'Product Dim strCoord As String Dim oP As Part Dim oSel As Selection 'source selection Dim oDestSel As Selection 'destination selection Dim showstate As CatVisPropertyShow Dim strNewBody As String 'name of created body Dim oTransAx As Object 'AxisSystem 'Dest Ax Sys for catpart Ax2Ax translation Dim arrOrg(2) 'PutOrigin - array Dim arrVX(2) 'PutXAxis - array Dim arrVY(2) 'PutYAxis - array Dim arrVZ(2) 'PutZAxis - array Dim oRefRefAx As Reference 'Ref element source Dim oRefTransAx As Reference 'Ref element dest Dim oAxisToAxis As ShapeFactory 'translate op '--------------------------------------------------------------------------------------------------- ' TODO: ' - rearrange code within loops/If-Else-cases ' - shapes.count reicht nicht aus; bodies mit aufgeboolten leeren bodies werden nicht ausgeschlossen! '(- alle bodies aus allcatpart in neues catpart kopieren; -> die achsen und translates verschwinden;) ' - arrays umbenennen ' - untersuchen, ob instanzen komplett kopiert werden können (Strategie?) ' - body-translation als datum/blitz? ' - closed shells berücksichtigen! (-> geosets checken) ' - achsensysteme kopieren '--------------------------------------------------------------------------------------------------- Set oSel = CATIA.ActiveDocument.Selection Set oDestSel = oDestDoc.Selection For i = 1 To oRoot.Products.Count ' MsgBox oRoot.Products.Item(i).Name Set oProdItem = oRoot.Products.Item(i) oSel.Clear oSel.Add oProdItem 'check if noshow oSel.VisProperties.GetShow showstate 'is the part visible, go on oSel.Clear If showstate = catVisPropertyShowAttr Then 'if noshow, skip oProdItem.ApplyWorkMode (DEFAULT_MODE) 'set work mode to default 'PRODUCT LEVEL If TypeName(oProdItem.ReferenceProduct.Parent) = "ProductDocument" Then oProdItem.position.GetComponents arrProdPos 'get zb axis coords if in zb 'multiply new array with old array; FIRST arg must be NEW array! MatrixProduct arrProdPos, arrRootProd, arrResProdPos 'build array product RunTree oProdItem, arrResProdPos, strNewBodyPath 'reenter one level down 'PART LEVEL ElseIf TypeName(oProdItem.ReferenceProduct.Parent) = "PartDocument" Then 'calc displacement oProdItem.position.GetComponents arrPos 'combine axis position arrays MatrixProduct arrPos, arrRootProd, arrResPos 'build resulting array (NEW,OLD,RESULT)! 'create axis according to position array; this defines the translation for the current part Set oTransAx = CreateNewAxisSp(oDestDoc.Part, "TransAxis" & oRoot.Products.Item(i).Name, False) oSel.Add oTransAx oSel.VisProperties.SetShow catVisPropertyNoShowAttr 'set noshow oSel.Clear arrOrg(0) = arrResPos(9) arrOrg(1) = arrResPos(10) arrOrg(2) = arrResPos(11) oTransAx.PutOrigin arrOrg arrVX(0) = arrResPos(0) arrVX(1) = arrResPos(1) arrVX(2) = arrResPos(2) oTransAx.PutXAxis arrVX arrVY(0) = arrResPos(3) arrVY(1) = arrResPos(4) arrVY(2) = arrResPos(5) oTransAx.PutYAxis arrVY arrVZ(0) = arrResPos(6) arrVZ(1) = arrResPos(7) arrVZ(2) = arrResPos(8) oTransAx.PutZAxis arrVZ 'create references for axistoaxis Set oRefRefAx = oDestDoc.Part.CreateReferenceFromObject(oRefAx) Set oRefTransAx = oDestDoc.Part.CreateReferenceFromObject(oTransAx) 'body handler Set oP = oProdItem.ReferenceProduct.Parent.Part For n = 1 To oP.Bodies.Count If oP.Bodies.Item(n).InBooleanOperation = False Then 'if not root body, skip If oP.Bodies.Item(n).Shapes.Count <> 0 Then 'if bodies are empty, skip If oP.IsUpToDate(oP.Bodies.Item(n)) = False Then 'if not up-to-date oP.UpdateObject oP.Bodies.Item(n) 'update the body DoEvents 'just in case End If oSel.Add oP.Bodies.Item(n) oSel.Copy oSel.Clear Set oDestSel = oDestDoc.Selection oDestSel.Clear oDestSel.Add oDestDoc.Part oDestSel.PasteSpecial "CATPrtResultWithOutLink" DoEvents oDestSel.Clear strNewBody = oProdItem.Name & "/" & oP.Bodies.Item(n).Name oDestDoc.Part.Bodies.Item(oDestDoc.Part.Bodies.Count).Name = strNewBodyPath & strNewBody ' Debug.Print oProdItem.Name, oP.Bodies.Item(n).Name, oP.IsUpToDate(oP.Bodies.Item(n)), showstate Set oAxisToAxis = oDestDoc.Part.ShapeFactory.AddNewAxisToAxis2(oRefRefAx, oRefTransAx) iBodyCount = iBodyCount + 1 End If End If Next '--------------------------------------------------------------------------------------------------- Else 'other End If End If Next 'shorten path on level exit On Error Resume Next 'first root causes error, since not in path strNewBodyPath = Left$(strNewBodyPath, Len(strNewBodyPath) - Len(oRoot.Name) - 1) On Error GoTo 0 End Sub '--------------------------------------------------------------------------------------- ' Procedure : CreateNewPart ' Author : jherzog ' Date : 27.02.2015 ' Time : 18:33 ' Languages : VBA 6.5 ' V5-Release: V5R19/21 ' Purpose : Create a new CATPart ' Parms : strPNummber : CatPart name ' : strDescriptor : Text entered in Properties/Description ' Ret. Value: the new partdoc object ' ' Syntax : set oPartNew = CreateNewPart("TestPart","New test part") ' ' Prereqs : ' Remarks : Error 'Unable to change Part number' is none critical '--------------------------------------------------------------------------------------- ' ChangeLog : 28.02.2015 : error handling added ' '--------------------------------------------------------------------------------------- Function CreateNewPart(strPNumber As String, strDescriptor As String) As PartDocument Dim oADPDoc As PartDocument Dim oADProd As Product On Error GoTo CreateNewPart_Error Set oADPDoc = CATIA.Documents.Add("Part") 'create new part Set oADProd = CATIA.ActiveDocument.Product oADProd.PartNumber = strPNumber 'change partnumber oADProd.DescriptionRef = strDescriptor 'add descriptor CATIA.ActiveDocument.Part.Update 'update CATIA.StatusBar = "Creating New Part!" Set CreateNewPart = oADPDoc Exit Function '--------------------------------------------------------------------------------------- CreateNewPart_Error: Dim errMsg As String Dim errRet As VbMsgBoxResult Select Case Err.Number ' Case 438 Case -2147467259 'part already exists in session MsgBox "Unable to set PartNumber!" & vbCrLf & "Rename when saving!", _ vbOKOnly Or vbInformation, "CreateNewPart" Resume Next Case Else errMsg = Err.Number & ": " & Err.Description & " in CreateNewPart" errRet = MsgBox(errMsg, vbOKOnly, "CreateNewPart") End Select 'Resume Next 'fall thru to quit sub '--------------------------------------------------------------------------------------- End Function Function CreateNewAxisSp(oParent As Part, strAxisName As String, Optional iCurr As Boolean = True, Optional iAxType As CATAxisSystemMainType = catAxisSystemStandard) As AxisSystem Dim oAxSyst As AxisSystem Set oAxSyst = oParent.AxisSystems.Add() oParent.UpdateObject oAxSyst oAxSyst.Type = iAxType oAxSyst.IsCurrent = iCurr oAxSyst.Name = strAxisName oParent.Update Set CreateNewAxisSp = oAxSyst End Function ' *********************************************************************** ' ' Purpose: Define the product of two matrix. ' ' Inputs : matrix1 Array array corresponding to the first matrix ' matrix2 Array array corresponding to the second matrix ' ' Outputs: res Array array corresponding to the product ' ' *********************************************************************** ' Borrowed from Dassault macro Public Sub MatrixProduct(ByVal matrix1, ByVal matrix2, ByRef res) Dim a(11) Dim b(11) Dim i As Integer For i = 0 To 11 a(i) = matrix1(i) b(i) = matrix2(i) Next res(0) = a(0) * b(0) + a(1) * b(3) + a(2) * b(6) res(3) = a(3) * b(0) + a(4) * b(3) + a(5) * b(6) res(6) = a(6) * b(0) + a(7) * b(3) + a(8) * b(6) res(1) = a(0) * b(1) + a(1) * b(4) + a(2) * b(7) res(4) = a(3) * b(1) + a(4) * b(4) + a(5) * b(7) res(7) = a(6) * b(1) + a(7) * b(4) + a(8) * b(7) res(2) = a(0) * b(2) + a(1) * b(5) + a(2) * b(8) res(5) = a(3) * b(2) + a(4) * b(5) + a(5) * b(8) res(8) = a(6) * b(2) + a(7) * b(5) + a(8) * b(8) res(9) = a(9) * b(0) + a(10) * b(3) + a(11) * b(6) + b(9) res(10) = a(9) * b(1) + a(10) * b(4) + a(11) * b(7) + b(10) res(11) = a(9) * b(2) + a(10) * b(5) + a(11) * b(8) + b(11) End Sub
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
joehz Moderator Freiberuflicher Konstrukteur
Beiträge: 1057 Registriert: 25.11.2006 Win7 Pro 64 + Ubuntu + Irix6.5.20 Dell Precision M6600 i7-2960XM 2.7GHz 16GB NVidia Quadro M5010 Catia V5R19 VB6Pro.SP6/VBA 6.5.1053
|
erstellt am: 12. Mrz. 2015 18:59 <-- editieren / zitieren --> Unities abgeben:
Nachfolgend die letzte Version. Hinzugekommen ist die Behandlung von Wireframe-Elementen(HybridBodies/Hybridshapes), sowie von Achsensystemen. Meine Versuche, die AxisToAxis-Ops durch nochmaliges kopieren in ein neues CatPart zu eliminieren, waren nicht erfolgreich. Händisch möglich, aber makro-technisch? Enjoy, Joe Code:
Option Explicit Const strVersion As String = "V1.3" Const strMacroName As String = "Poor Man's ProductToPart"Public iBodyCount As Integer 'counter for stats Public oRefAx As AxisSystem 'Part Ref axis system,1/1/1;0/0/0 Public oTempDoc As PartDocument 'intermediate destinaton for allcatpart '--------------------------------------------------------------------------------------- ' Procedure : CatMain ' Author : jherzog ' Date : 01.03.2015 ' Time : 14:48 ' Languages : VBA 6.5 ' V5-Release: V5R19/21 ' Purpose : Create Part From Product(s) ' Parms : - ' Ret. Value: - ' ' Syntax : CatMain ' ' Prereqs : Loaded, selected product containing geometry ' Remarks : '--------------------------------------------------------------------------------------- Sub CATMain() '--------------------------------------------------------------------------------------- ' ToDo: ' - Sort bodies(StartCommand: Reorder Children; sort similar to product sort ' - sortierung: array aus bodies + geosets erstellen, sortieren und in der reihenfolge ' in ein neues part kopieren; dadurch sortierung und keine transformationen mehr; ' - im neuen part überflüssige Elemente im NoShow löschen ' ' '--------------------------------------------------------------------------------------- Dim oRootProd As Product Dim oSourceWindow As Window Dim oTempWindow As Window Dim arrRootPos(11) Dim tmStart As Date Dim tmEnd As Date Dim oSel As Selection Dim n As Integer tmStart = Time$ iBodyCount = 0 Set oSourceWindow = CATIA.ActiveWindow Set oRootProd = GetRootProd If oRootProd Is Nothing Then End 'create temp part Set oTempDoc = CreateNewPart(oRootProd.Name & "_TempAllCatPart", _ "AllCatPart aus " & oRootProd.Name, True, True) Set oTempWindow = CATIA.Windows.Item(CATIA.Windows.Count) Set oRefAx = CreateNewAxisSp(oTempDoc.Part, "RefAxis") oSourceWindow.Activate DoEvents InitArray arrRootPos() CATIA.RefreshDisplay = False CATIA.DisplayFileAlerts = False CATIA.HSOSynchronized = False RunTree oRootProd, arrRootPos(), "" ' CleanUp oTempDoc.Part.Update CATIA.RefreshDisplay = True CATIA.HSOSynchronized = True CATIA.DisplayFileAlerts = True oTempWindow.Activate CATIA.StartCommand "Fit All In" DoEvents CATIA.StartCommand "Collapse All" DoEvents CATIA.RefreshDisplay = True DoEvents CATIA.StatusBar = "Macro finished. " tmEnd = Time$ MsgBox "Start: " & tmStart & vbCrLf _ & "Ende: " & tmEnd & vbCrLf _ & iBodyCount & " Bodies copied.", _ vbOKOnly Or vbInformation, strMacroName & "/" & strVersion End Sub Function GetRootProd() As Product Dim oSel As Selection Set oSel = CATIA.ActiveDocument.Selection If oSel.Count2 = 1 Then If oSel.Item(1).Type = "Product" Then Set GetRootProd = oSel.Item2(1).Value Else MsgBox "This macro needs a product to work!" & vbCr & "Exiting macro ...", _ vbOKOnly Or vbCritical, "GetRootProd - " & strMacroName & "/" & strVersion End If Else MsgBox "Select a product first!" & vbCr & "Exiting macro ...", _ vbOKOnly Or vbCritical, "GetRootProd - " & strMacroName & "/" & strVersion End End If End Function '--------------------------------------------------------------------------------------- ' Procedure : RunTree ' Author : jherzog ' Date : 27.02.2015 ' Time : 18:49 ' Languages : VB6 Pro SP6 ' V5-Release: V5R19/21 ' Purpose : ' Parms : oRoot: the root product from where the search begins ' : arrRootProd(): array holding axis coordinates ' Ret. Value: - ' ' Syntax : RunTree oRootProd, arrRootPos() ' ' Prereqs : ' Remarks : '--------------------------------------------------------------------------------------- ' ChangeLog : 28.02.2015 : body names changed ' : 02.03.2015 : added GeoSets handler for Surfs, Crvs, Pts etc. ' : 03.03.2015 : added Axis handler ' : 08.03.2015 : SetAxisComp, SetHide, DoPasteSpecial, DoCopy, DelObject, ' : : AreShapesInActive, IsShow, GetBodySetsArray added ' : 09.03.2015 : Debugging; CleanUp added; added Bodies/IsShow ' ' '--------------------------------------------------------------------------------------- Sub RunTree(oRoot As Product, arrRootProd(), strNewBodyPath As String) Dim i As Integer Dim n As Integer Dim m As Integer Dim arrInv(11) 'inverse pos Dim arrPos(11) 'part pos Dim arrProdPos(11) 'prod pos Dim arrResPos(11) 'result from part matrix multiply Dim arrResProdPos(11) 'result from product matrix multiply Dim oProdItem As Object 'Product Dim strCoord As String Dim oP As Part Dim oHSs As HybridShapes Dim oDestSet As HybridBody 'Dest Geoset Dim oSel As Selection 'source selection Dim strNewBody As String 'name of created body Dim oTransAx As Object 'AxisSystem 'Dest Ax Sys for catpart Ax2Ax translation Dim oRefRefAx As Reference 'Ref element source Dim oRefTransAx As Reference 'Ref element dest Dim oRefHBody As Reference 'Ref of hybrid body Dim oAxisToAxis As ShapeFactory 'translate op bodies Dim oHSAxisToAxis As HybridShapeAxisToAxis 'translate op hybridbodies Dim bAtLeastOne As Boolean 'flag for erasing set '--------------------------------------------------------------------------------------- ' TODO: ' - rearrange code within loops/If-Else-cases ' - arrays umbenennen ' - untersuchen, ob instanzen komplett kopiert werden können (Strategie?) ' - body-translation als datum/blitz? ' - fehlerbehandlung '+' ' - alle bodies in endgültiges catpart kopieren '--------------------------------------------------------------------------------------- On Error GoTo RunTree_Error Set oSel = CATIA.ActiveDocument.Selection For i = 1 To oRoot.Products.Count ' MsgBox oRoot.Products.Item(i).Name Set oProdItem = oRoot.Products.Item(i) If IsShow(oSel, oProdItem) Then 'if noshow, skip oProdItem.ApplyWorkMode (DESIGN_MODE) 'set work mode DoEvents '--------------------------------------------------------------------------------------- 'PRODUCT LEVEL If TypeName(oProdItem.ReferenceProduct.Parent) = "ProductDocument" Then oProdItem.position.GetComponents arrProdPos 'get zb axis coords if in zb 'multiply new array with old array; FIRST arg must be NEW array! MatrixProduct arrProdPos, arrRootProd, arrResProdPos 'build array product strNewBodyPath = strNewBodyPath & oProdItem.Name & "/" RunTree oProdItem, arrResProdPos, strNewBodyPath 'reenter one level down '--------------------------------------------------------------------------------------- 'PART LEVEL ElseIf TypeName(oProdItem.ReferenceProduct.Parent) = "PartDocument" Then 'calc displacement oProdItem.position.GetComponents arrPos 'combine axis position arrays MatrixProduct arrPos, arrRootProd, arrResPos 'build resulting array (NEW,OLD,RESULT)! 'create axis according to position array; this defines the translation for the current part Set oTransAx = CreateNewAxisSp(oTempDoc.Part, "TransAxis_" _ & oRoot.Name & "_" & oRoot.Products.Item(i).Name, False) SetHide oSel, oTransAx, True 'set noshow SetAxisComp oTransAx, arrResPos 'change the axis to match displacement 'create references for axistoaxis Set oRefRefAx = oTempDoc.Part.CreateReferenceFromObject(oRefAx) Set oRefTransAx = oTempDoc.Part.CreateReferenceFromObject(oTransAx) '--------------------------------------------------------------------------------------- 'body handler Set oP = oProdItem.ReferenceProduct.Parent.Part For n = 1 To oP.Bodies.Count 'go through the bodies If oP.Bodies.Item(n).InBooleanOperation = False Then 'if not root body, skip If IsShow(oSel, oP.Bodies.Item(n)) Then 'if noshow skip If oP.Bodies.Item(n).Shapes.Count <> 0 Then 'if bodies are empty, skip If AreShapesInActive(oP, oP.Bodies.Item(n).Name) = False Then 'at least one shape active If oP.IsUpToDate(oP.Bodies.Item(n)) = False Then 'if not up-to-date oP.UpdateObject oP.Bodies.Item(n) 'update the body DoEvents 'just in case End If DoCopy oSel, oP.Bodies.Item(n) DoPasteSpecial oSel, oTempDoc.Part, "CATPrtResultWithOutLink" strNewBody = oProdItem.Name & "/" & oP.Bodies.Item(n).Name oTempDoc.Part.Bodies.Item(oTempDoc.Part.Bodies.Count).Name = _ strNewBodyPath & strNewBody Set oAxisToAxis = oTempDoc.Part.ShapeFactory.AddNewAxisToAxis2 _ (oRefRefAx, oRefTransAx) iBodyCount = iBodyCount + 1 End If End If End If End If Next '--------------------------------------------------------------------------------------- 'geoset handler; Pts, Crvs(=Lns), Plns, Surfs For n = 1 To oP.HybridBodies.Count Set oHSs = oP.HybridBodies.Item(n).HybridShapes If oHSs.Count <> 0 Then 'any shapes in the set? If IsShow(oSel, oP.HybridBodies.Item(n)) Then 'if the hybridbody is show, create the set Set oDestSet = CreateGeometricSet(oTempDoc.Part, _ strNewBodyPath & oProdItem.Name & "/" & oP.HybridBodies.Item(n).Name) bAtLeastOne = False 'init flag For m = 1 To oHSs.Count 'walk thru shapes If IsShow(oSel, oHSs.Item(m)) Then 'if the shape is show//value not empty DoCopy oSel, oHSs.Item(m) 'copy shape to clipboard oSel.Clear DoPasteSpecial oSel, oDestSet, "CATPrtResultWithOutLink" 'paste to dest part 'create reference using last created hybridshape Set oRefHBody = oTempDoc.Part.CreateReferenceFromObject _ (oDestSet.HybridShapes.Item(oDestSet.HybridShapes.Count)) Set oHSAxisToAxis = oTempDoc.Part.HybridShapeFactory.AddNewAxisToAxis _ (oRefHBody, oRefRefAx, oRefTransAx) oHSAxisToAxis.VolumeResult = False DoEvents oDestSet.AppendHybridShape oHSAxisToAxis SetHide oSel, oDestSet.HybridShapes.Item _ (oDestSet.HybridShapes.Count - 1), True 'hide initial element bAtLeastOne = True 'at least one shape exists End If Next If bAtLeastOne = False Then 'if no shapes in hybridbody/geoset, DelObject oSel, oDestSet 'then delete set Else iBodyCount = iBodyCount + 1 'inc counter End If End If End If Next '--------------------------------------------------------------------------------------- 'achsensystem handler For n = 1 To oP.AxisSystems.Count If IsShow(oSel, oP.AxisSystems.Item(n)) Then 'check if noshow DoCopy oSel, oP.AxisSystems.Item(n) 'copy oSel.Clear DoPasteSpecial oSel, oTempDoc.Part, "CATPrtResultWithOutLink" 'paste as result oTempDoc.Part.AxisSystems.Item(oTempDoc.Part.AxisSystems.Count).Name = _ "Axis_" & oRoot.Name & "_" & oRoot.Products.Item(i).Name _ & "/" & oP.AxisSystems.Item(n).Name oTempDoc.Part.UpdateObject oTempDoc.Part.AxisSystems.Item _ (oTempDoc.Part.AxisSystems.Count) Set oRefHBody = oTempDoc.Part.CreateReferenceFromObject _ (oTempDoc.Part.AxisSystems.Item(oTempDoc.Part.AxisSystems.Count)) Set oHSAxisToAxis = oTempDoc.Part.HybridShapeFactory.AddNewAxisToAxis _ (oRefHBody, oRefRefAx, oRefTransAx) oHSAxisToAxis.VolumeResult = False DoEvents If oDestSet Is Nothing Then Set oDestSet = CreateGeometricSet(oTempDoc.Part, "TranslSet") iBodyCount = iBodyCount + 1 'inc counter End If oDestSet.AppendHybridShape oHSAxisToAxis SetHide oSel, oTempDoc.Part.AxisSystems.Item _ (oTempDoc.Part.AxisSystems.Count), True 'hide initial element End If Next '--------------------------------------------------------------------------------------- End If End If Next '--------------------------------------------------------------------------------------- 'adjust path; causes error if strBodyPath = "" strNewBodyPath = Left$(strNewBodyPath, Len(strNewBodyPath) - Len(oRoot.Name) - 1) Exit Sub '--------------------------------------------------------------------------------------- RunTree_Error: Dim errMsg As String Dim errRet As VbMsgBoxResult Select Case Err.Number Case 5 'invalid procedure call or argument Resume Next 'ausgelöst durch strNewBodyPath = Left$(... ' Case 438 ' Case -2147467259 Case Else errMsg = Err.Number & ": " & Err.Description & " in procedure RunTree" errRet = MsgBox(errMsg, vbOKOnly, "RunTree") End Select 'Resume Next 'fall thru to quit sub '--------------------------------------------------------------------------------------- End Sub '--------------------------------------------------------------------------------------- ' Procedure : CreateNewPart ' Author : jherzog ' Date : 27.02.2015 ' Time : 18:33 ' Languages : VBA 6.5 ' V5-Release: V5R19/21 ' Purpose : Create a new CATPart ' Parms : strPNummber : CatPart name ' : strDescriptor : Text entered in Properties/Description ' : bNoGeoSet1 : True = Do not create Geometric Set.1 ' : bHideSysPlanes : True = Hide Origin Planes ' Ret. Value: the new partdoc object ' ' Syntax : set oPartNew = CreateNewPart("TestPart","New test part") ' ' Prereqs : ' Remarks : Error 'Unable to change Part number' is none critical '--------------------------------------------------------------------------------------- ' ChangeLog : 02.03.2015 : added Option bNoGeoSet1 ' : added Option bHideSysPlanes '--------------------------------------------------------------------------------------- Function CreateNewPart(strPNumber As String, strDescriptor As String, _ Optional bHideSysPlanes As Boolean = False, _ Optional bNoGeoSet1 As Boolean = False) As PartDocument Dim oADPDoc As PartDocument Dim oADProd As Product Dim oSel As Selection On Error GoTo CreateNewPart_Error Set oADPDoc = CATIA.Documents.Add("Part") 'create new part Set oADProd = CATIA.ActiveDocument.Product oADProd.PartNumber = strPNumber 'change partnumber oADProd.DescriptionRef = strDescriptor 'add descriptor If bHideSysPlanes = True Then Set oSel = CATIA.ActiveDocument.Selection oSel.Add CATIA.ActiveDocument.Part.OriginElements.PlaneXY oSel.Add CATIA.ActiveDocument.Part.OriginElements.PlaneYZ oSel.Add CATIA.ActiveDocument.Part.OriginElements.PlaneZX oSel.VisProperties.SetShow catVisPropertyNoShowAttr oSel.Clear End If If bNoGeoSet1 = True Then Set oSel = CATIA.ActiveDocument.Selection oSel.Add CATIA.ActiveDocument.Part.HybridBodies.Item("Geometrical Set.1") oSel.Delete oSel.Clear End If CATIA.ActiveDocument.Part.Update 'update CATIA.StatusBar = "Creating New Part!" Set CreateNewPart = oADPDoc Exit Function '--------------------------------------------------------------------------------------- CreateNewPart_Error: Dim errMsg As String Dim errRet As VbMsgBoxResult Select Case Err.Number ' Case 438 Case -2147467259 'part already exists in session MsgBox "Unable to set PartNumber!" & vbCrLf & "Rename when saving!", _ vbOKOnly Or vbInformation, "CreateNewPart" Resume Next Case Else errMsg = Err.Number & ": " & Err.Description & " in CreateNewPart" errRet = MsgBox(errMsg, vbOKOnly, "CreateNewPart") End Select 'Resume Next 'fall thru to quit sub '--------------------------------------------------------------------------------------- End Function Function CreateNewAxisSp(oParent As Part, strAxisName As String, _ Optional iCurr As Boolean = True, _ Optional iAxType As CATAxisSystemMainType = catAxisSystemStandard) As AxisSystem Dim oAxSyst As AxisSystem Set oAxSyst = oParent.AxisSystems.Add() oParent.UpdateObject oAxSyst oAxSyst.Type = iAxType oAxSyst.IsCurrent = iCurr oAxSyst.Name = strAxisName oParent.Update Set CreateNewAxisSp = oAxSyst End Function Function CreateGeometricSet(oParent As Part, strGeoSetName As String) As HybridBody Dim HBs As HybridBodies Dim gsNew As HybridBody Set HBs = oParent.HybridBodies Set gsNew = HBs.Add 'add to list gsNew.Name = strGeoSetName 'rename Set CreateGeometricSet = gsNew CATIA.StatusBar = "Creating New Set!" End Function Sub SetAxisComp(oAxis As Object, arrComp) 'modify axis components ' Dim oAxis As Object 'AxisSystem 'Dest Ax Sys for catpart Ax2Ax translation Dim arrOrg(2) 'PutOrigin - array Dim arrVX(2) 'PutXAxis - array Dim arrVY(2) 'PutYAxis - array Dim arrVZ(2) 'PutZAxis - array arrOrg(0) = arrComp(9) arrOrg(1) = arrComp(10) arrOrg(2) = arrComp(11) oAxis.PutOrigin arrOrg arrVX(0) = arrComp(0) arrVX(1) = arrComp(1) arrVX(2) = arrComp(2) oAxis.PutXAxis arrVX arrVY(0) = arrComp(3) arrVY(1) = arrComp(4) arrVY(2) = arrComp(5) oAxis.PutYAxis arrVY arrVZ(0) = arrComp(6) arrVZ(1) = arrComp(7) arrVZ(2) = arrComp(8) oAxis.PutZAxis arrVZ End Sub Sub SetHide(sSel As Selection, oItem As Object, bHide As Boolean) 'set show/noshow sSel.Clear sSel.Add oItem If bHide = True Then sSel.VisProperties.SetShow catVisPropertyNoShowAttr Else sSel.VisProperties.SetShow catVisPropertyShowAttr End If sSel.Clear End Sub Sub DoPasteSpecial(sSel As Selection, oItem As Object, strPasteHow As String) sSel.Add oItem sSel.PasteSpecial strPasteHow sSel.Clear End Sub Sub DoCopy(sSel As Selection, oItem As Object) 'copy one object sSel.Clear sSel.Add oItem sSel.Copy End Sub Sub DelObject(sSel As Selection, oItem As Object) 'delete one object sSel.Clear sSel.Add oItem sSel.Delete sSel.Clear End Sub Function AreShapesInActive(oParent As Part, strBody As String) As Boolean Dim n As Integer AreShapesInActive = True For n = 1 To oParent.Bodies.Item(strBody).Shapes.Count If oParent.IsInactive(oParent.Bodies.Item(strBody).Shapes.Item(n)) = False Then AreShapesInActive = False Exit For End If Next End Function Function IsShow(sSel As Selection, oItem As Object) As Boolean 'show or noshow? Dim showstate As CatVisPropertyShow sSel.Clear sSel.Add oItem 'check if noshow sSel.VisProperties.GetShow showstate 'is the part visible, go on sSel.Clear If showstate = catVisPropertyShowAttr Then IsShow = True Else IsShow = False End If End Function Sub CleanUp() 'delete empty bodies Dim n As Integer Dim oSel As Selection Set oSel = CATIA.ActiveDocument.Selection For n = 1 To oTempDoc.Part.Bodies.Count If oTempDoc.Part.Bodies.Item(n).Shapes.Count = 0 _ And Not oTempDoc.Part.Bodies.Item(n) Is oTempDoc.Part.MainBody Then DelObject oSel, oTempDoc.Part.Bodies.Item(n) End If Next End Sub Sub InitArray(arrPos) arrPos(0) = 1 'init axis cooords to arrPos(1) = 0 'standard r/h system arrPos(2) = 0 arrPos(3) = 0 arrPos(4) = 1 arrPos(5) = 0 arrPos(6) = 0 arrPos(7) = 0 arrPos(8) = 1 arrPos(9) = 0 arrPos(10) = 0 arrPos(11) = 0 End Sub ' QuickSort-Algorithmus ' Autor: Dieter Otter ' www.tools4vb.de ' ' vSort() : zu sortierendes Array ' lngStart, lngEnd: zu sortierender Bereich ' ========================================== Public Sub QuickSort(vSort As Variant, _ Optional ByVal lngStart As Variant, _ Optional ByVal lngEnd As Variant) ' Wird die Bereichsgrenze nicht angegeben, ' so wird das gesamte Array sortiert If IsMissing(lngStart) Then lngStart = LBound(vSort) If IsMissing(lngEnd) Then lngEnd = UBound(vSort) Dim i As Long Dim j As Long Dim H As Variant Dim X As Variant i = lngStart j = lngEnd X = vSort((lngStart + lngEnd) / 2) ' Array aufteilen Do While (vSort(i) < X) i = i + 1 Wend While (vSort(j) > X) j = j - 1 Wend If (i <= j) Then ' Wertepaare miteinander tauschen H = vSort(i) vSort(i) = vSort(j) vSort(j) = H i = i + 1 j = j - 1 End If Loop Until (i > j) ' Rekursion (Funktion ruft sich selbst auf) If (lngStart < j) Then QuickSort vSort, lngStart, j If (i < lngEnd) Then QuickSort vSort, i, lngEnd End Sub ' *********************************************************************** ' ' Purpose: Define the product of two matrix. ' ' Inputs : matrix1 Array array corresponding to the first matrix ' matrix2 Array array corresponding to the second matrix ' ' Outputs: res Array array corresponding to the product ' ' *********************************************************************** ' Borrowed from Dassault macro Public Sub MatrixProduct(ByVal matrix1, ByVal matrix2, ByRef res) Dim a(11) Dim b(11) Dim i As Integer For i = 0 To 11 a(i) = matrix1(i) b(i) = matrix2(i) Next res(0) = a(0) * b(0) + a(1) * b(3) + a(2) * b(6) res(3) = a(3) * b(0) + a(4) * b(3) + a(5) * b(6) res(6) = a(6) * b(0) + a(7) * b(3) + a(8) * b(6) res(1) = a(0) * b(1) + a(1) * b(4) + a(2) * b(7) res(4) = a(3) * b(1) + a(4) * b(4) + a(5) * b(7) res(7) = a(6) * b(1) + a(7) * b(4) + a(8) * b(7) res(2) = a(0) * b(2) + a(1) * b(5) + a(2) * b(8) res(5) = a(3) * b(2) + a(4) * b(5) + a(5) * b(8) res(8) = a(6) * b(2) + a(7) * b(5) + a(8) * b(8) res(9) = a(9) * b(0) + a(10) * b(3) + a(11) * b(6) + b(9) res(10) = a(9) * b(1) + a(10) * b(4) + a(11) * b(7) + b(10) res(11) = a(9) * b(2) + a(10) * b(5) + a(11) * b(8) + b(11) End Sub
[Diese Nachricht wurde von joehz am 12. Mrz. 2015 editiert.] Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Sylas Mitglied
Beiträge: 322 Registriert: 19.11.2012 Dell Precision T3500 Intel Xeon W3550 @ 3,07 GHz 12 GB RAM CATIA V5 R28
|
erstellt am: 17. Apr. 2018 11:29 <-- editieren / zitieren --> Unities abgeben: Nur für joehz
Hallo Joe Ich habe deine Makro versuchen, und kriege ich solche Ergibnis:
auf der Linkeseite nach v 2, auf der Rechteseite nach v3 (mittich Original Produkt). Kannst du mir weiterhelfen? Gruß Lucas Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
razzor88 Mitglied
Beiträge: 42 Registriert: 09.06.2016
|
erstellt am: 17. Apr. 2018 21:52 <-- editieren / zitieren --> Unities abgeben: Nur für joehz
Hallo Zusammen, ich hab die Tage mal ein ähnliches Programm geschrieben, das allerdings kein AllCATPart erstellt, sondern ein RGProduct. D.h. Das vorliegende Product kann 1 zu 1 in ein "totes Product umgewandelt werden" ähnlich wie beim AllCATpart, nur das die Struktur erhalten bleibt. Erst lädt das Programm die Productstruktur in einen TreeView. Den TreeView kann man nach belieben auf / zuklappen ... Die im TreeView sichtbare Struktur wird 1 zu 1 übernommen. D.h. aus nicht aufgeklappten Unterproducten wird ein Part gemacht ... Klickt man auf "Alles Aufklappen" und erstellt das das RGProduct, erhält man quasi die originale Struktur... Ich hoff es ist einigermaßen verständlich? Es werden allerdings nur Körper kopiert! Ich finde das Programm recht hilfreich um tote Daten zu verschicken... Da ich es selber nicht so prickelnd finde wenn ich mal mit AllCATParts arbeiten muss, möchte ich das natürlich anderen auch nicht unbedingt zumuten Viel Spaß beim ausprobieren. Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Sylas Mitglied
Beiträge: 322 Registriert: 19.11.2012 Dell Precision T3500 Intel Xeon W3550 @ 3,07 GHz 12 GB RAM CATIA V5 R28
|
erstellt am: 19. Apr. 2018 06:52 <-- editieren / zitieren --> Unities abgeben: Nur für joehz
Zitat: Original erstellt von razzor88: Hallo Zusammen,ich hab die Tage mal ein ähnliches Programm geschrieben, das allerdings kein AllCATPart erstellt, sondern ein RGProduct. D.h. Das vorliegende Product kann 1 zu 1 in ein "totes Product umgewandelt werden" ähnlich wie beim AllCATpart, nur das die Struktur erhalten bleibt. Erst lädt das Programm die Productstruktur in einen TreeView. Den TreeView kann man nach belieben auf / zuklappen ... Die im TreeView sichtbare Struktur wird 1 zu 1 übernommen. D.h. aus nicht aufgeklappten Unterproducten wird ein Part gemacht ... Klickt man auf "Alles Aufklappen" und erstellt das das RGProduct, erhält man quasi die originale Struktur... Ich hoff es ist einigermaßen verständlich? Es werden allerdings nur Körper kopiert! Ich finde das Programm recht hilfreich um tote Daten zu verschicken... Da ich es selber nicht so prickelnd finde wenn ich mal mit AllCATParts arbeiten muss, möchte ich das natürlich anderen auch nicht unbedingt zumuten Viel Spaß beim ausprobieren.
Hallo Das Programm lauft wirklich gut (fast perfekt ).Nach dem Test kriege ich solche Ergibnis(links Quelle, rechts - Ergebnis): Es fehlt mir Zwischenplatten. Ich verstehe dass nicht - ich habe andere Parts, welche mit Boolische operationen sind, und sie sind da... Trotztdem brauche ich allcatpart (das wird nur ein Ausschnitt vom Code sein) , weil ich muss spater par allcatparts zusammenfasen im neuem Product. Kannst du mir mit das helfen? Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
bgrittmann Moderator Konstrukteur
Beiträge: 11780 Registriert: 30.11.2006 CATIA V5R19
|
erstellt am: 19. Apr. 2018 08:40 <-- editieren / zitieren --> Unities abgeben: Nur für joehz
Servus Und was ist an den Teilen die nicht kopiert werden anders? Schon mal versucht nachzuvollziehen warum das Makro von Joe nicht klappt (schrittweise ausführen und nachvollziehen)? Wenn du noch R19 verwendest: warum dann nicht noch direkt "DECProductToPart" verwenden (AFAIR geht es da noch ohne die DF1) Gruß Bernd
------------------ Warum einfach, wenn es auch kompliziert geht. Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
razzor88 Mitglied
Beiträge: 42 Registriert: 09.06.2016
|
erstellt am: 19. Apr. 2018 09:09 <-- editieren / zitieren --> Unities abgeben: Nur für joehz
Guten Morgen, Ich hatte vergessen zu erwähnen,daß bei meinem Programm nur Sachen die im Show stehen. D.H. Alle ausgeblendeten Products oder Parts werden nicht kopiert. Genauso wie Ausgeblendete Körper. Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
tomtom1972 Mitglied dipl ing maschinenbau
Beiträge: 605 Registriert: 22.03.2005 NVidia Quadro K4000 Intel Xeon E5-1620, 64GB RAM Windows10 64bit R30 <= CATIA V5 > =R19
|
erstellt am: 19. Apr. 2018 09:43 <-- editieren / zitieren --> Unities abgeben: Nur für joehz
Moin, einfach Struktur als .stp exportieren und wieder in CATIA einlesen. Funktioniert mit Script und manuell. Alle Geometrie ist tot, alles ist vorhanden (GSD, Bodies ...) Ebenso die Struktur. Einfacher (und vor allem schneller) geht's nicht. Gruß tomtom ------------------ tomtom1972 Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Sylas Mitglied
Beiträge: 322 Registriert: 19.11.2012 Dell Precision T3500 Intel Xeon W3550 @ 3,07 GHz 12 GB RAM CATIA V5 R28
|
erstellt am: 19. Apr. 2018 09:48 <-- editieren / zitieren --> Unities abgeben: Nur für joehz
Zitat: Original erstellt von razzor88: Guten Morgen, Ich hatte vergessen zu erwähnen,daß bei meinem Programm nur Sachen die im Show stehen. D.H. Alle ausgeblendeten Products oder Parts werden nicht kopiert. Genauso wie Ausgeblendete Körper.
Kein Part (Body) ist im NoShow. Andere Idee? Zitat: Original erstellt von bgrittmann: ServusUnd was ist an den Teilen die nicht kopiert werden anders? Schon mal versucht nachzuvollziehen warum das Makro von Joe nicht klappt (schrittweise ausführen und nachvollziehen)? Wenn du noch R19 verwendest: warum dann nicht noch direkt "DECProductToPart" verwenden (AFAIR geht es da noch ohne die DF1) Gruß Bernd
Was fremd ist die fehlende Teile eigentlich das gleich aufgebaut sind... Das makro von Joe ist sehr zu kompliziert,auch wegen debugging,für mich ... Vielleicht Mann muss CATIA-optionen zuerst irgendwie stellen? Z.B. Geometrical Set mit Neuem Part setzen? Die Makro lauft bei dir ohne Probleme? Ich arbeite schon mit R26, zeitweise mit R24 Gruß Lucas
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
razzor88 Mitglied
Beiträge: 42 Registriert: 09.06.2016
|
erstellt am: 22. Apr. 2018 14:36 <-- editieren / zitieren --> Unities abgeben: Nur für joehz
Hmmmm, seltsam bei mir scheint es bisher immer problemlos zu laufen. Konnte bisher noch keine Fehler feststellen. Ansonsten müsstest du vielleicht mal die Daten zur Verfügung stellen bei denen Fehler auftreten, sofern das möglich ist. Dann würde mich mal gucken ob ich den Fehler finde. Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Sylas Mitglied
Beiträge: 322 Registriert: 19.11.2012 Dell Precision T3500 Intel Xeon W3550 @ 3,07 GHz 12 GB RAM CATIA V5 R28
|
erstellt am: 23. Apr. 2018 07:18 <-- editieren / zitieren --> Unities abgeben: Nur für joehz
Zitat: Original erstellt von razzor88: Hmmmm,seltsam bei mir scheint es bisher immer problemlos zu laufen. Konnte bisher noch keine Fehler feststellen. Ansonsten müsstest du vielleicht mal die Daten zur Verfügung stellen bei denen Fehler auftreten, sofern das möglich ist. Dann würde mich mal gucken ob ich den Fehler finde.
Es tut mir leid, aber Ich kann nicht mit diese Datei verteilen mit :( Zitat: Original erstellt von tomtom1972: Moin, einfach Struktur als .stp exportieren und wieder in CATIA einlesen. Funktioniert mit Script und manuell. Alle Geometrie ist tot, alles ist vorhanden (GSD, Bodies ...) Ebenso die Struktur. Einfacher (und vor allem schneller) geht's nicht. Gruß tomtom ------------------ tomtom1972
Ich denke ich will mit tomtom1972 Idee weiter gehen Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Sylas Mitglied
Beiträge: 322 Registriert: 19.11.2012 Dell Precision T3500 Intel Xeon W3550 @ 3,07 GHz 12 GB RAM CATIA V5 R28
|
erstellt am: 24. Apr. 2018 06:15 <-- editieren / zitieren --> Unities abgeben: Nur für joehz
Zitat: Original erstellt von tomtom1972: Moin, einfach Struktur als .stp exportieren und wieder in CATIA einlesen. Funktioniert mit Script und manuell. Alle Geometrie ist tot, alles ist vorhanden (GSD, Bodies ...) Ebenso die Struktur. Einfacher (und vor allem schneller) geht's nicht. Gruß tomtom
Halo tomtom1972 Ich muss meine Produkte als einzelne CATParts haben - wenn ich exportiere CATProducts als stp-File und danach öffne ich das wieder - ich kriege Productstruktur wieder - wie kann ich das überspringen? Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
moppesle Ehrenmitglied V.I.P. h.c. Konstrukteur
Beiträge: 3418 Registriert: 28.05.2009 CATIA V5 R19 SP9 WIN 7 64bit
|
erstellt am: 24. Apr. 2018 08:59 <-- editieren / zitieren --> Unities abgeben: Nur für joehz
|
Sylas Mitglied
Beiträge: 322 Registriert: 19.11.2012 Dell Precision T3500 Intel Xeon W3550 @ 3,07 GHz 12 GB RAM CATIA V5 R28
|
erstellt am: 25. Apr. 2018 10:13 <-- editieren / zitieren --> Unities abgeben: Nur für joehz
Zitat: Original erstellt von moppesle: Hallo Sylas,öffne die STP-Datei und speichere das Produkt als Catiasfiles wieder.
So einfach? Ich will kein neues CATProduct haben, nur ein neues Part für jedes Product (anlisch wie mit CATIA Funktion: "Generate CATPart from CATProduct"). Bist du sicher? Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
moppesle Ehrenmitglied V.I.P. h.c. Konstrukteur
Beiträge: 3418 Registriert: 28.05.2009 CATIA V5 R19 SP9 WIN 7 64bit
|
erstellt am: 25. Apr. 2018 11:19 <-- editieren / zitieren --> Unities abgeben: Nur für joehz
Hallo Sylas, ich bin mir nicht sicher was du überhaupt möchtest. -Wenn du ein Part von deinem Produkt haben möchtest nutze "Generate Part From Produkt" -Wenn du die Parts mit der Produktstruktur haben möchtest ist die STP-Variante die richtige. -Wenn du die Parts einzeln ohne Produktstruktur benötigst ist auch die STP-Variante und lösche die Produkte von dem Verzeichnis.
Zitat: Ich will kein neues CATProduct haben, nur ein neues Part für jedes Product (anlisch wie mit CATIA Funktion: "Generate CATPart from CATProduct")
-Wenn du für jedes Produkt in deiner Produktstruktur ein PArt haben möchtest musst du halt die Funktion "Generate CATPart from CATProduct" für jedes Produkt ausführen. ------------------ Gruß Uwe Auch Catia ist nur ein Mensch! Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
| Anzeige.:
Anzeige: (Infos zum Werbeplatz >>)
|