Vítejte !   Přihlášení | Registrace
Hledat
Hlavní menu
CATIA fórum.cz
Novinky
Seriál CATIA
Obecně o CAD
Novinky ze světa DS
Makra pro CATIA V5
Diskuse
Vytvořit téma
Koncepty
Seznam oblíbených
Soukromé zprávy
Pravidla
Live CHAT
VIP žádost
Základy Catia
Ke stažení
Doporučujeme
Pracovní příležitosti
Reklama a kampaně
O fóru
Nápověda

Ořezání rovinou na základě objemu

Kompletní přehled příspěvků v tématu Ořezání rovinou na základě objemu řazený podle data jejich publikace na fóru.

UživatelPříspěvek
pmazda

Poslat zprávu | Profil
Datum: 8.3. 2013 | Zobrazeno: 10162x
Konfigurace CATIA:

Text dotazu:
Dobrý den,
mám solid o určitém objemu, dále mám danou rovinu. Potřebuju posunovat s offsetem dané roviny tak, aby solid dosáhl požadovaného objemu po ořezání totou offsetovou rovinou. Cílem by mělo být zadání objemu tělesa -> na jehož základě dostanu ořezovou rovinu. Co s tím (parametr/makro)?

Břeťa Doležal

Poslat zprávu | Profil 		[#3720] | Publikováno: 08.03. 2013 - 09:28
Na přesně toto mám makro, kde vstupem jsou dva parametry (vzdálenost řezné roviny, druhý parametr je objem). Dále se musí definovat počáteční krok prvního z parametrů. Používám toto makro na řezání objemů a funguje i v sestavách, kdy např. potřebuji najít určitou polohu sestavy (např. minimální vzdálenost nějakého dílu od jiného).
Makro nedělá nic jiného než že inkrementuje první z parametrů, provede update a vyhodnotí druhý parametr a toto v cyklu, který je omezen přesností, jakou vyžaduji a omezuji si to i max. počtem kroků, páč někdy zadám špatně vstup. Makro pracuje s parametry a s hodnotovými constrainy.
Pokud hodláte makro komerčně používat, tak Vám mohu zaslat číslo účtu, kam je možno poukázat odměnu za toto makro.

A zde je již ono makro: 



Option Explicit



Public oPart As Part

Public oSestava As Product

Public prmVstupniParam As KnowledgewareTypeLib.Parameter

Public prmVystupParam As KnowledgewareTypeLib.Parameter

Public dblZadanaHodnota As Double

Public dblKrok As Double

Public btePresnost As Byte

Public lngMaxPocIter As Long

Public strDokTyp As String

Public blnZadano As Boolean





Sub CATMain()

  'Statistika používání makra:

  Dim clsLog As New clsLogFile

  clsLog.MakroLog ("Optimalizace")

  clsLog.CloseFile

  Set clsLog = Nothing

  

  'Zaèátek samotného makra

  Call InterfaceOptimalizace

  

  Set oPart = Nothing

  Set oSestava = Nothing

  Set prmVstupniParam = Nothing

  Set prmVystupParam = Nothing

End Sub





Sub InterfaceOptimalizace()



Dim MsgText As String

Dim MsgResponse As Long

Dim intOptimVysledek As Integer

blnZadano = False

strDokTyp = ""



Err.Clear

'Kontrola jestli je aktivní dokument Part nebo Product, jinak ukonèi makro

On Error GoTo ErrHandler    ' in Case when Desk is active document

  If TypeName(CATIA.ActiveDocument) = "PartDocument" Then

  'Aktivní dokument je Part, pokraèuj

    Set oPart = CATIA.ActiveDocument.Part

    strDokTyp = "Part"

  ElseIf TypeName(CATIA.ActiveDocument) = "ProductDocument" Then

  'Aktivní dokument je Product, pokraèuj

    Set oSestava = CATIA.ActiveDocument.Product

    strDokTyp = "Product"

  Else

  'Aktivní dokument není Part ani produkt, ukonèi makro

    MsgText = TypeName(CATIA.ActiveDocument) & " is unsupported document!" & vbCrLf

    MsgText = MsgText & "CATPart or CATProduct hAs to be active."

    MsgResponse = MsgBox(MsgText, vbExclamation)

    Exit Sub

  End If

Err.Clear

On Error GoTo 0

frmOptimEnter.Show

   

If blnZadano Then 'Pokud byli zadány vstupní parametry, optimalizuj

  If strDokTyp = "Part" Then

  'Pokud se jedna o Part spus OptimalizacniFce

    intOptimVysledek = OptimalizacniFce(oPart, prmVstupniParam, prmVystupParam, _

      dblKrok, dblZadanaHodnota, btePresnost, lngMaxPocIter)

  ElseIf strDokTyp = "Product" Then

  'Pokud se jedna o Product spus OptimalizacniFceProduct

    intOptimVysledek = OptimalizacniFceProduct(oSestava, prmVstupniParam, prmVystupParam, _

      dblKrok, dblZadanaHodnota, btePresnost, lngMaxPocIter)

  Else

  'Nìco není v poøádku

    intOptimVysledek = -6

  End If

  CATIA.StatusBar = "Výsledek optimalizace: " & CStr(intOptimVysledek)

Else 'Nebyli zadány vstupní parametry, informuj o pøerušení Makra - zavøen formuláø

  CATIA.StatusBar = "Makro pøerušeno"

End If

    

  Exit Sub

ErrHandler:

    ' Pokud je nìco divného s aktivním dokumentem informuj uživatele a konec

    MsgText = "Unsupported document is active!" & vbCrLf

    MsgText = MsgText & "CATPart or CATProduct hAs to be active."

    MsgResponse = MsgBox(MsgText, vbExclamation)

    

End Sub





Function OptimalizacniFce(prtSoucast As Part, prmRidiciParametr As KnowledgewareTypeLib.Parameter, _

  prmOptimalizovanyParametr As KnowledgewareTypeLib.Parameter, dblVstupniKrok As Double, _

  dblCilovaHodnota As Double, Optional btePresnost As Byte = 3, Optional lngMaxPocetIteraci As Long = 5000) As Integer

'+----------------------------------------------------------------------------------+

'| Jmeno: »»»»» OptimalizacniFce «««««                                              |

'| Vstupni parametry:   prtSoucast As Part                                          |

'|                      prmRidiciParametr As KnowledgewareTypeLib.Parameter         |

'|                      prmOptimalizovanyParametr As KnowledgewareTypeLib.Parameter |

'|                      dblVstupniKrok As Double                                    |

'|                      dblCilovaHodnota As Double                                  |

'|                      btePresnost As Byte                                         |

'|                      lngMaxPocetIteraci As Long                                  |

'| Vystupni hodnota:    lngIterace = pocet iteraci k dosazeni cilove hodnoty        |

'|                      -1 = nelze poupravit ani krok (max. 100x krat zjemnuje)     |

'|                      -2 = prekrocen maximalni pocet iteracnich kroku             |

'|                           (nekonverguje), ev. je nutno vice kroku                |

'|                      -3 = chyba pri "update" soucasti                            |

'|                      -4 = neni co optimalizovat                                  |

'| Autor funkce:        Bretislav Dolezal®, +420-483354426                          |

'+----------------------------------------------------------------------------------+

  

Dim dblDump As Double

Dim dblHodnotaPredIteraci, dblHodnotaPoIteraci As Double

Dim dblKrok, dblPresnost As Double

Dim blnUpravenyKrok As Boolean

Dim MsgResponse As Integer

Dim intItKrok, lngIterace As Integer

Dim dblPomocne1, dblPomocne2 As Double

Dim intZnamenko As Integer



dblDump = prmRidiciParametr.Value

dblPresnost = 10 ^ (-btePresnost)

dblKrok = dblVstupniKrok

dblHodnotaPredIteraci = prmOptimalizovanyParametr.Value

intItKrok = 1

lngIterace = 1

intZnamenko = 1

If dblCilovaHodnota < prmOptimalizovanyParametr.Value Then intZnamenko = -1



If Abs(dblCilovaHodnota - prmOptimalizovanyParametr.Value) > dblPresnost Then

' neni nahodou cilova hodnota stejna jako stavajici

  

  Do 'smycka pro kontrolu a pripadnou upravu kroku

    blnUpravenyKrok = False

    prmRidiciParametr.Value = prmRidiciParametr.Value + dblKrok

    

    On Error Resume Next

    prtSoucast.Update

    

    If Err.Number <> 0 Then

      OptimalizacniFce = -3

      prmRidiciParametr.Value = dblDump

      prtSoucast.Update

      Exit Function

    End If

    On Error GoTo 0

    

    dblHodnotaPoIteraci = prmOptimalizovanyParametr.Value

    prmRidiciParametr.Value = prmRidiciParametr.Value - dblKrok

      

    dblPomocne1 = Abs(dblCilovaHodnota - dblHodnotaPredIteraci)

    dblPomocne2 = Abs(dblHodnotaPoIteraci - dblHodnotaPredIteraci)

     If dblPomocne1 < dblPomocne2 Then

       If dblPomocne2 <> 0 And dblPomocne1 <> 0 Then 'kontrola pro zamezeni deleni nulou

         dblKrok = dblKrok / (2 * dblPomocne2 / dblPomocne1)

       End If

       intItKrok = intItKrok + 1

       If intItKrok > 100 Then

         'chyba, vypadato na spatne podminky a nelze ani poupravit krokovani

         OptimalizacniFce = -1

         prmRidiciParametr.Value = dblDump

         prtSoucast.Update

         Exit Function

       End If

       blnUpravenyKrok = True

     End If

  Loop Until blnUpravenyKrok = False

  

  Do 'iterace na cilovou hodnotu

    Do

      

      prmRidiciParametr.Value = prmRidiciParametr.Value + dblKrok

      On Error Resume Next

      prtSoucast.Update

      If Err.Number <> 0 Then

        OptimalizacniFce = -3

        prmRidiciParametr.Value = dblDump

        prtSoucast.Update

        Exit Function

      End If

      On Error GoTo 0

      

      dblHodnotaPoIteraci = prmOptimalizovanyParametr.Value

      lngIterace = lngIterace + 1

      CATIA.StatusBar = "Aktuální po&#232;et itera&#232;ních krok&#249;:" & CStr(lngIterace) & "; akt.cílová hodnota:" & prmOptimalizovanyParametr.ValueAsString

      

      If lngIterace > lngMaxPocetIteraci Then

        'prekrocen maximalni pocet iteraci

        OptimalizacniFce = -2

        prmRidiciParametr.Value = dblDump

        prtSoucast.Update

        Exit Function

      End If

    

    'zpomaleni

    'Dim i, j As Long

    'j = 0

    'For i = 1 To 10000

    '  j = j + 1

    '  DoEvents

    'Next i

      

    Loop Until (intZnamenko * prmOptimalizovanyParametr.Value) >= (intZnamenko * dblCilovaHodnota)

      prmRidiciParametr.Value = prmRidiciParametr.Value - dblKrok  'pokud p&#248;ekro&#232;eno, vra&#157; krok zp&#236;t a zmenši krok (**)

      dblKrok = dblKrok / 10

      

  Loop Until Abs(dblCilovaHodnota - prmOptimalizovanyParametr.Value) < dblPresnost

  

  'úprava hodnoty na poslední hodnotu iterace, kv&#249;li p&#248;epo&#232;tu ve smy&#232;ce, viz (**) 5 &#248;ádk&#249; zp&#236;t

  prmRidiciParametr.Value = prmRidiciParametr.Value + dblKrok * 10

  

  On Error Resume Next

  prtSoucast.Update

  

  If Err.Number <> 0 Then

    OptimalizacniFce = -3

    prmRidiciParametr.Value = dblDump

    prtSoucast.Update

    Exit Function

  End If

  On Error GoTo 0

  

  OptimalizacniFce = lngIterace

  

Else

  OptimalizacniFce = -4

  prmRidiciParametr.Value = dblDump

  prtSoucast.Update

End If



End Function



Public Function OptimalizacniFceProduct(prdSestava As Product, prmRidiciParametr As KnowledgewareTypeLib.Parameter, _

  prmOptimalizovanyParametr As KnowledgewareTypeLib.Parameter, dblVstupniKrok As Double, _

  dblCilovaHodnota As Double, Optional btePresnost As Byte = 3, Optional lngMaxPocetIteraci As Long = 5000) As Integer

'+----------------------------------------------------------------------------------+

'| Jmeno: »»»»» OptimalizacniFceProduct «««««                                       |

'| Vstupni parametry:   prdSestava As Product                                       |

'|                      prmRidiciParametr As KnowledgewareTypeLib.Parameter         |

'|                      prmOptimalizovanyParametr As KnowledgewareTypeLib.Parameter |

'|                      dblVstupniKrok As Double                                    |

'|                      dblCilovaHodnota As Double                                  |

'|                      btePresnost As Byte                                         |

'|                      lngMaxPocetIteraci As Long                                  |

'| Vystupni hodnota:    lngIterace = pocet iteraci k dosazeni cilove hodnoty        |

'|                      -1 = nelze poupravit ani krok (max. 100x krat zjemnuje)     |

'|                      -2 = prekrocen maximalni pocet iteracnich kroku             |

'|                           (nekonverguje), ev. je nutno vice kroku                |

'|                      -3 = chyba pri "update" soucasti                            |

'|                      -4 = neni co optimalizovat                                  |

'| Autor funkce:        Bretislav Dolezal®, +420-483354426                          |

'+----------------------------------------------------------------------------------+



Dim dblDump As Double

Dim dblHodnotaPredIteraci, dblHodnotaPoIteraci As Double

Dim dblKrok, dblPresnost As Double

Dim blnUpravenyKrok As Boolean

Dim MsgResponse As Integer

Dim intItKrok As Integer

Dim lngIterace As Long

Dim dblPomocne1, dblPomocne2 As Double

Dim intZnamenko As Integer



dblDump = prmRidiciParametr.Value

dblPresnost = 10 ^ (-btePresnost)

dblKrok = dblVstupniKrok

dblHodnotaPredIteraci = prmOptimalizovanyParametr.Value

intItKrok = 1

lngIterace = 1

intZnamenko = 1

If dblCilovaHodnota < prmOptimalizovanyParametr.Value Then intZnamenko = -1



If Abs(dblCilovaHodnota - prmOptimalizovanyParametr.Value) > dblPresnost Then

' neni nahodou cilova hodnota stejna jako stavajici

  

  Do 'smycka pro kontrolu a pripadnou upravu kroku

    blnUpravenyKrok = False

    prmRidiciParametr.Value = prmRidiciParametr.Value + dblKrok

    

    On Error Resume Next

    prdSestava.Update

    If Err.Number <> 0 Then

      OptimalizacniFceProduct = -3

      prmRidiciParametr.Value = dblDump

      prdSestava.Update

      Exit Function

    End If

    On Error GoTo 0

    

    dblHodnotaPoIteraci = prmOptimalizovanyParametr.Value

    prmRidiciParametr.Value = prmRidiciParametr.Value - dblKrok

      

    dblPomocne1 = Abs(dblCilovaHodnota - dblHodnotaPredIteraci)

    dblPomocne2 = Abs(dblHodnotaPoIteraci - dblHodnotaPredIteraci)

     If dblPomocne1 < dblPomocne2 Then

       If dblPomocne2 <> 0 And dblPomocne1 <> 0 Then 'kontrola pro zamezeni deleni nulou

         dblKrok = dblKrok / (2 * dblPomocne2 / dblPomocne1)

       End If

       intItKrok = intItKrok + 1

       If intItKrok > 100 Then

         'chyba, vypadato na spatne podminky a nelze ani poupravit krokovani

         OptimalizacniFceProduct = -1

         prmRidiciParametr.Value = dblDump

         prdSestava.Update

         Exit Function

       End If

       blnUpravenyKrok = True

     End If

  Loop Until blnUpravenyKrok = False

  

  Do 'iterace na cilovou hodnotu

    Do

      prmRidiciParametr.Value = prmRidiciParametr.Value + dblKrok

      On Error Resume Next

      prdSestava.Update

      If Err.Number <> 0 Then

        OptimalizacniFceProduct = -3

        prmRidiciParametr.Value = dblDump

        prdSestava.Update

        Exit Function

      End If

      On Error GoTo 0

      

      dblHodnotaPoIteraci = prmOptimalizovanyParametr.Value

      lngIterace = lngIterace + 1

      CATIA.StatusBar = "Aktuální po&#232;et itera&#232;ních krok&#249;:" & CStr(lngIterace) & "; akt.cílová hodnota:" & prmOptimalizovanyParametr.ValueAsString

      If lngIterace > lngMaxPocetIteraci Then

        'prekrocen maximalni pocet iteraci

         OptimalizacniFceProduct = -2

         prmRidiciParametr.Value = dblDump

         prdSestava.Update

         Exit Function

      End If

    Loop Until (intZnamenko * prmOptimalizovanyParametr.Value) >= (intZnamenko * dblCilovaHodnota)

      prmRidiciParametr.Value = prmRidiciParametr.Value - dblKrok  'pokud p&#248;ekro&#232;eno, vra&#157; krok zp&#236;t a zmenši krok (**)

      dblKrok = dblKrok / 10

      

  Loop Until Abs(dblCilovaHodnota - prmOptimalizovanyParametr.Value) < dblPresnost

  

  'úprava hodnoty na poslední hodnotu iterace, kv&#249;li p&#248;epo&#232;tu ve smy&#232;ce, viz (**) 5 &#248;ádk&#249; zp&#236;t

  prmRidiciParametr.Value = prmRidiciParametr.Value + dblKrok * 10

  

  On Error Resume Next

  prdSestava.Update

  If Err.Number <> 0 Then

    OptimalizacniFceProduct = -3

    prmRidiciParametr.Value = dblDump

    prdSestava.Update

    Exit Function

  End If

  On Error GoTo 0

  

  OptimalizacniFceProduct = lngIterace

  

Else

  OptimalizacniFceProduct = -4

  prmRidiciParametr.Value = dblDump

  prdSestava.Update



End If



End Function



Public Function VyberParametru(strZprava As String) As KnowledgewareTypeLib.Parameter



Const strFiltr As String = "Parameter, Constraint"  'co m&#249;že uživatel vybírat

Dim oSelekce As Object

Dim varTempArr As Variant

Dim vararrFiltr() As Variant

Dim strStatus As String

Dim i As Byte

Dim oParam As KnowledgewareTypeLib.Parameter

      

'p&#248;evod String na pole pro funkci SelectElement

varTempArr = Split(strFiltr, ",")

ReDim vararrFiltr(UBound(varTempArr))

For i = 0 To UBound(varTempArr)

  vararrFiltr(i) = Trim(varTempArr(i))

Next i



strZprava = strZprava & "    [ESC]=Strono"

Set oSelekce = CATIA.Application.ActiveDocument.Selection

oSelekce.Clear

CATIA.Application.Visible = True



strStatus = oSelekce.SelectElement3(vararrFiltr, strZprava, False, CATMultiSelTriggWhenSelPerf, False) 'CATMonoSel



'pro toto lepší parametr CATMonoSel na místo CATMultiSelTrigg.. nefunguje! Nevím pro&#232;....?

'jednodušší varianta:

'strStatus = oSelekce.SelectElement2(vararrFiltr, "Vyber parametr", False)

  

'Rozbor výsledk&#249; selekce:

Select Case strStatus

  Case "Normal"

    'i = oSelekce.Count2

    'Jedna se o Constrain?

    If TypeName(oSelekce.Item2(1).Value) = "Constraint" Then

      If oSelekce.Item2(1).Value.Type = catCstTypeDistance Or _

      oSelekce.Item2(1).Value.Type = catCstTypeLength Or _

      oSelekce.Item2(1).Value.Type = catCstTypeAngle Or _

      oSelekce.Item2(1).Value.Type = catCstTypePlanarAngle Or _

      oSelekce.Item2(1).Value.Type = catCstTypeRadius Or _

      oSelekce.Item2(1).Value.Type = catCstTypeMajorRadius Or _

      oSelekce.Item2(1).Value.Type = catCstTypeMinorRadius Or _

      oSelekce.Item2(1).Value.Type = catCstTypeChamfer Or _

      oSelekce.Item2(1).Value.Type = catCstTypeChamferPerpEnd Or _

      oSelekce.Item2(1).Value.Type = catCstTypeCylinderRadius Then

      'Ov&#236;&#248;uje se, zda-li se jedná o constrain, kde se upravuje n&#236;jaká hodnota

        Set oParam = oSelekce.Item2(1).Value.Dimension

        If IsNumeric(oParam.Value) Then

          Set VyberParametru = oParam 'Jedná se o vhodný constrain jakožto parametr. Funkce vrátí parametr

        Else 'Constrain nemá &#232;íselnou hodnotu, Funkce vrátí objekt Nothing a vyvolá chybu

          Set VyberParametru = Nothing

          Err.Number = vbObjectError + 50

          Err.Source = "Catia"

          Err.Description = "Vybrán špatný constrain - nejedná se o &#232;íselnou hodnotu."

        End If

      Else 'Constrain není v seznamu použitelných typ&#249;, Funkce vrátí objekt Nothing a vyvolá chybu

        Set VyberParametru = Nothing

        Err.Number = vbObjectError + 50

        Err.Source = "Catia"

        Err.Description = "Vybrán špatný constraint - nejedná se o &#232;íselnou hodnotu."

      End If

    'Nejedná se o Constrain, ale o Parameter

    Else

      Set oParam = oSelekce.Item2(1).Value

      If IsNumeric(oParam.Value) Then 'Jedná se o &#232;íselný parametr:

        Set VyberParametru = oParam 'Funkce vrátí parametr

      Else 'Nejedná-li se o &#232;íselný parametr:

        Set VyberParametru = Nothing 'Funkce vrátí objekt Nothing a vyvolá chybu

        Err.Number = vbObjectError + 50

        Err.Source = "Catia"

        Err.Description = "Vybrán špatný parametr - nejedná se o &#232;íselnou hodnotu."

      End If

    End If

  Case "Undo" 'P&#248;i výb&#236;ru se použilo UnDo &#232;i ReDo - nemá smysl pro toto makro

  Case "Redo"

  Case "Cancel"  '[Esc] - Storno

    Set VyberParametru = Nothing  'Funkce vrátí objekt Nothing

    Err.Number = vbObjectError + 50

    Err.Source = "Catia"

    Err.Description = "ESC - zrušena akce"

  Case Else 'N&#236;co neur&#232;itého se p&#248;i výb&#236;ru pod&#236;lalo

    Set VyberParametru = Nothing  'Funkce vrátí objekt Nothing

    Err.Number = vbObjectError + 50

    Err.Source = "Catia"

    Err.Description = "N&#236;co špatn&#236; p&#248;i výb&#236;ru parametru"

End Select

  

'+---------------------------------------------------------------------------+

'| *** Pozn. typy parametru: ***                                                   |

'+---------------------------------------------------------------------------+

'| TypeName(Parameter) = "Length", "Angle", "StrParam", "BoolParam",         |

'|                       "IntParam", "Dimension", "RealParam"                |

'+---------------------------------------------------------------------------+



'Destruct object (not necessary, but sometime it helps):

Set oSelekce = Nothing

Set oParam = Nothing



End Function
pmazda

Poslat zprávu | Profil 		[#3726] | Publikováno: 12.03. 2013 - 07:17
Tak se mě to nepodařilo, asi je to na mě moc těžce napsané.
Petr

Poslat zprávu | Profil 		[#4070] | Publikováno: 29.08. 2013 - 10:35
Uživatel odpovídá na příspěvek #3720:

Zvažuji nasazení u nás ve firmě. Chtěl bych podrobný popis makra a také formulář pro vložení hodnot. Kolik by se mělo poslat na účet :-) Díky za info. Petr


Uživatel nepřihlášen

Pro zobrazení obsahu stránky / provedení akce (vytvoření nového téma, napsání odpovědi do diskuse apod.) musíte být přihlášeni.