Seznam příspěvků uživatele

        'kolik běží procesů Catie

        locProc = Process.GetProcessesByName("CNEXT")

        If locProc.Count > 1 Then 'pokud běží více CATII najednou, nutno ošetřit

CATIA.RefreshDisplay = False 'začátek



rekurzivní procházení sestavy



CATIA.RefreshDisplay = True 'konec

CATIA.Interactive = True / False

CATIA.Visibility = True / False

Dim Datum As DateTime

Dim rok, mesic, den As Integer



rok = Datum.Year

mesic = Datum.Month

den =  DateTime.Day



vyslednystring = rok.ToString & "-" & mesic.ToString & "-" & den.ToString

 msgText = msgText & Format(DateTime.Now, "dd MMMM yyyy") 

'uživatel:

Set wshNet = CreateObject("WScript.Network")

strUzivatel = wshNet.UserName

'datum pomocí funkce

mujdatum = Date

'a už jde jen o to nasypat údaje Do CATIE:

drwAutor, drwDate As DrawingText

drwAutor.Text = strUzivatel

drwDate.Text = mujdatum

    Public Function MaterialOfBody(ByVal iBody As Body) As String

        

        Dim locMaterial As Material = Nothing

        Dim locMatManager As MaterialManager

        

        locMatManager = CType(iBody.GetItem("CATMatManagerVBExt"), MaterialManager)

        locMatManager.GetMaterialOnBody(iBody, locMaterial)

        If locMaterial Is Nothing Then

            Return ("NONE")

        Else

            Return (locMaterial.Name)

        End If

    End Function 

           CATBarva = CLng(255L + (256L * b) + (256L * 256L * g) + (256L * 256L * 256L * r))

            hranice = CLng((2 ^ 32 / 2) - 1)



            If CATBarva > hranice Then

                CATBarva = CATBarva - CLng(256 ^ 4)

            End If

            dt.TextProperties.Color = CInt(CATBarva)

MyText.SetParameterOnSubString catColor, 0, 0, redCol 'Encoded RGBA color within long integer (R=255 G=0  B=0  A=255)

    Dim locSubKomp As New cls_SubComponent

        Dim strT1, strT2 As String

        Dim mycount As Integer

        Dim myShapes As Shapes

        Dim myHybBod As HybridBodies

        Dim myHybSha As HybridShapes

        Dim mySolid As MECMOD.Solid





        'mySolid.SourceElement

        'mySolid.SourceProduct





        myShapes = iBody.Shapes

        mycount = myShapes.Count

        strT1 = ""

        strT2 = ""

        For Each mySp As Shape In myShapes

            If Not IsNothing(mySp) Then

                strT1 = strT1 + mySp.Name + "-" + TypeName(mySp) + "|"

                If TypeName(mySp) = "Solid" Then



                    mySolid = CType(mySp, MECMOD.Solid)

                    strT2 = strT2 + TypeName(mySolid.Parent)



                    'strT2 = mySolid.SourceElement.Name

                    'strT2 = strT2 + mySolid.SourceProduct.Parent.ToString



                End If

            End If

        Next mySp



        myShapes = Nothing

myproc = Process.GetProcessesByName("CNEXT")



        If myproc.Count > 1 Then



            '!!!! pokud běží více CATII najednou, nutno ošetřit



        End If

 INFITF.Application 

locCATApp = CType(GetObject(, "CATIA.Application"), INFITF.Application)

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

Public Class frmOutputTable

    Public Const strCaption As String = "Makro - Partname & FileName"

    Public CATIA As INFITF.Application 'CATIA Application Object



    Dim msgText As String

    Dim msgResp As MsgBoxResult

    Dim msgButtons As MsgBoxStyle

    Dim colAssyLevel As New Collections.Generic.List(Of Integer)

    Dim colPodprodukty As New Collections.Generic.List(Of Product)

    Dim objProdukt As Product

    Dim intMaxAssyLevel As Integer





    Public Function JeKonec(ByVal istrMessage As String) As Boolean

        'Vrátí True nebo False podle reakce uživatele



        CATIA.StatusBar = istrMessage

        istrMessage &= vbCrLf & "Chceš teď předčasně ukončit makro"

        msgButtons = MsgBoxStyle.Question Or MsgBoxStyle.YesNo

        msgResp = MsgBox(istrMessage, msgButtons, strCaption)

        If msgResp = vbYes Then

            Return (True)

        Else

            Return (False)

        End If

        CATIA.StatusBar = ""

    End Function 'JeKonec



    Public Function GetProdukt(ByVal iCATIA As INFITF.Application) As Product

        'Vrátí objekt Product z aktivního dokumentu, případně otevře nový dokument.

        'V případě, že není aktivní Product a makro bude přerušeno, Funkce vrátí Nothing

        Dim Soubor As String

        Dim objDocument As Document

        Dim blnSestavaOtevrena As Boolean = False



        Do

            Try

                objDocument = iCATIA.ActiveDocument 'Přiřazení aktivního dokumentu

                If TypeName(objDocument) = "ProductDocument" Then 'Pokud je aktivním dokumentem setava tak ji předá a ukončí tuto funkci

                    Return (CType(objDocument.Product, Product))

                Else

                    msgText = TypeName(objDocument) & " nemůže být použit pro toto makro" & vbCrLf 'Sice je něco v Catii, ale není to sestava "

                    msgText &= "Sestava (CATProduct) musí být načtená a aktivní pro toto makro!"

                    If JeKonec(msgText) Then 'Chceš skončit tuto funkci

                        Return (Nothing) ' ANO konec funkce, vrací nothing

                    End If

                End If



            Catch ex As Exception

                msgText = "Sestava (CATProduct) musí být načtená a aktivní pro toto makro!"

                If JeKonec(msgText) Then 'Chceš skončit tuto funkci

                    Return (Nothing) ' ANO konec funkce, vrací nothing

                End If

            End Try



            'NE neukončí funkci a dále nabídne otevření sestavy

            Do

                msgText = "Otevři sestavu (CATProduct), kterou chceš analyzovat"

                iCATIA.StatusBar = msgText

                Soubor = iCATIA.FileSelectionBox("Oteřít CATProduct", "*.CATProduct", CatFileSelectionMode.CatFileSelectionModeOpen)



                If String.IsNullOrEmpty(Soubor) Or Not (Soubor.Contains("CATProduct")) Then

                    msgText = "Otevřen špatný soubor. Musí být otevřen CATProduct!"

                    If JeKonec(msgText) Then 'Chceš skončit tuto funkci

                        Return (Nothing) ' ANO konec funkce, vrací nothing

                    End If

                Else

                    Try

                        iCATIA.Documents.Open(Soubor)

                        blnSestavaOtevrena = True 'pokud se podaří otevřít dokument smyčka pro otvírání souboru bude ukončena

                    Catch ex As Exception

                        msgText = "Sestavu nelze otevřít!"

                        If JeKonec(msgText) Then 'Chceš skončit tuto funkci

                            Return (Nothing) ' ANO konec funkce, vrací nothing

                        End If

                    End Try

                End If

                'NE tak znovu otevírej sestavu, smyčka



            Loop Until blnSestavaOtevrena

        Loop

    End Function 'GetProdukt



    ''' summary

    ''' Rekurzivní funkce pro procházení sestavy

    ''' summary

    ''' param name=iProduktDefinuje Product který se má projítparam

    ''' param name=iAssyLevelAktuální úroveň Productu v sestavěparam

    ''' param name=iPodproduktyKolekce vyzískaných Produktuparam

    ''' remarks

    ''' Prozkoumá sestavu iProdukt Do hloubky a případné nalezené produkty přidá Do iPodprodukty

    ''' remarks

    Public Sub ProduktExplorer(ByVal iProdukt As Product, ByVal iAssyLevel As Integer, ByVal iPodprodukty As Collections.Generic.List(Of Product))

        Dim locProdukty As Products 'Kolekce produktů uvnitř produktu iProdukt

        Dim locProdukt As Product   'Produkt z kolekce Produkty

        Dim intAssyLevel As Integer = iAssyLevel



        intAssyLevel += 1

        locProdukty = iProdukt.Products

        For Each locProdukt In locProdukty

            iPodprodukty.Add(locProdukt)

            colAssyLevel.Add(intAssyLevel)

            ProduktExplorer(locProdukt, intAssyLevel, iPodprodukty) 'Rekurzivní volání

        Next locProdukt

        intAssyLevel -= 1

    End Sub 'ProduktExplorer



    ''' summary

    ''' Určení nejnižší úrovně sestavy

    ''' summary

    ''' param name=iAssyLevelsKolekce iAssyLevels, ze kterých se má určit maximumparam

    ''' returnsMaximální level - nejnižší úroveň sestavyreturns

    ''' remarks

    ''' Projde kolekci a vyhledá nejvyšší vnoření v sestavě

    ''' remarks

    Public Function GetMaxLevel(ByVal iAssyLevels As System.Collections.Generic.List(Of Integer)) As Integer

        'Vrátí maximální level v seznamu subkomponent

        Dim locMaxLevel As Integer = 0



        For i As Integer = 0 To iAssyLevels.Count - 1

            If iAssyLevels.Item(i) > locMaxLevel Then locMaxLevel = iAssyLevels.Item(i)

        Next i

        Return locMaxLevel

    End Function 'GetMaxLevel



    Private Sub btnStart_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnStart.Click

        Dim locDocument As Document

        Dim locProdukt As Product

        Dim intLevel As Integer





        Cursor.Current = Cursors.WaitCursor

        CleanGrid()



        'vytvoření objektu CATIA

        Try

            CATIA = CType(GetObject(, "CATIA.Application"), INFITF.Application)

            Exit Try

        Catch ex As Exception

            msgText = "Catie nemůže být nalezena mezi běžícími procesy." & vbCrLf

            msgText &= "Zkontroluj zda máš spušťenou Catii a spusť makro ještě jednou" & vbCrLf

            msgText &= "Pokud ji máš spuštěnou, může být něco s makrem, volej +420-604600585" & vbCrLf

            MsgBox(msgText, vbExclamation, strCaption)

            Exit Sub

        End Try



        objProdukt = GetProdukt(CATIA)

        If IsNothing(objProdukt) Then Exit Sub 'nebyla přiřazena sestava - ukonči tuto proceduru, popř. přidat odezvu Do formuláře 



        colPodprodukty.Add(objProdukt)

        colAssyLevel.Add(1)



        ProduktExplorer(objProdukt, 1, colPodprodukty)



        intMaxAssyLevel = colAssyLevel.Max





        'EXLSheet.Cells(1, 1) = "Struktura sestavy" & objProdukt.Name

        'EXLSheet.get_Range(EXLSheet.Cells(1, 1), EXLSheet.Cells(1, intMaxAssyLevel + 1)).Merge()



        Dim RowEntering(intMaxAssyLevel + 1) As String

        MyGrid.Columns.Add("AssyLevel", "Assy Level")



        For i As Integer = 1 To intMaxAssyLevel

            MyGrid.Columns.Add("PN" & CStr(i) & "Level", "Part Number" & vbCrLf & CStr(i) & ".Assy Level")

        Next i

        MyGrid.Columns.Add("FileName", "File Name")

        MyGrid.Columns.Add("Changes", "Proceeded Changes")





        For i As Integer = 0 To colPodprodukty.Count() - 1



            'světlé odstíny červená, zelená, modrá

            '    intRed = CInt(155 + (50 + colAssyLevel.Item(i) / intMaxAssyLevel) * (colAssyLevel.Item(i) Mod 3))

            '    intGreen = CInt(155 + (50 + colAssyLevel.Item(i) / intMaxAssyLevel) * ((colAssyLevel.Item(i) + 1) Mod 3))

            '    intBlue = CInt(155 + (50 + colAssyLevel.Item(i) / intMaxAssyLevel) * ((colAssyLevel.Item(i) + 2) Mod 3))



            For j As Integer = 0 To RowEntering.Count - 1

                RowEntering(j) = ""

            Next



            locProdukt = colPodprodukty.Item(i)

            locDocument = CType(locProdukt.ReferenceProduct.Parent, Document)

            intLevel = colAssyLevel.Item(i)



            RowEntering(0) = CStr(intLevel)

            RowEntering(intLevel) = locProdukt.PartNumber

            RowEntering(intMaxAssyLevel + 1) = locDocument.FullName



            MyGrid.Rows.Add(RowEntering)



        Next i



        Cursor.Current = Cursors.Arrow

        btnChangePN.Enabled = True



    End Sub



    Public Sub New()



        ' This call is required by the designer.

        InitializeComponent()



        ' Add any initialization after the InitializeComponent() call.

        Me.Text = strCaption

        MyGrid.Top = 30

        MyGrid.Height = Me.Height - 56

        MyGrid.Left = 0

        MyGrid.Width = Me.Width - 7

        btnChangePN.Enabled = False



    End Sub



    Private Sub frmOutputTable_SizeChanged(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.SizeChanged

        MyGrid.Top = 30

        MyGrid.Height = Me.Height - 56

        MyGrid.Left = 0

        MyGrid.Width = Me.Width - 7



    End Sub



    Private Sub CleanGrid()

        MyGrid.Rows.Clear()

        MyGrid.Columns.Clear()



        colAssyLevel.Clear()

        colPodprodukty.Clear()

        btnChangePN.Enabled = False



    End Sub



    Private Sub btnVycistit_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnVycistit.Click

        CleanGrid()

    End Sub



    

    Private Sub btnChangePN_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnChangePN.Click

        Dim locDocument As Document

        Dim locProduct As Product

        Dim PathCutted() As String

        Dim OldNameCutted() As String

        Dim strNewName, strOldPN As String

        Dim strOldIndex As String





        For i As Integer = 0 To colPodprodukty.Count() - 1

            locProduct = colPodprodukty.Item(i)

            locDocument = CType(locProduct.ReferenceProduct.Parent, Document)



            strOldPN = locProduct.PartNumber

            OldNameCutted = Split(locProduct.Name, ".")

            strOldIndex = OldNameCutted(OldNameCutted.Count() - 1)



            strNewName = locDocument.FullName

            PathCutted = Split(strNewName, "\")

            strNewName = PathCutted(PathCutted.Count() - 1)

            If strNewName.Contains("CATProduct") Then strNewName = strNewName.Remove(strNewName.Length - 11)

            If strNewName.Contains("CATPart") Then strNewName = strNewName.Remove(strNewName.Length - 8)



            If Not strNewName = locProduct.PartNumber Then

                locProduct.PartNumber = strNewName

                locProduct.Name = strNewName & "." & strOldIndex



                MyGrid.Rows(i).Cells("Changes").Value = "PN Change from: '" & strOldPN & "' to '" & strNewName & "'"



                Dim MyStyle As New DataGridViewCellStyle()

                MyStyle.ForeColor = Color.Red



                MyGrid.Rows(i).Cells("Changes").Style.ApplyStyle(MyStyle)



                MyGrid.Rows(i).Cells(colAssyLevel(i)).Value = locProduct.PartNumber

            End If









        Next i

    End Sub

End Class

Dim WSNet As Object

Dim Zprava As String



Set WSNet = CreateObject("WScript.Network")



Zprava = "Uživatel: " & WSNet.UserName & vbCrLf

Zprava = Zprava & "Počítač:  " & WSNet.ComputerName & vbCrLf

MsgBox Zprava, vbExclamation, "Msg"

    Public Shared Function AreParalel(ByVal iPart As Part, ByVal iFirstPlane As Plane, ByVal iSecondPlane As Plane) As Boolean

        Dim locSPAWB As SPATypeLib.SPAWorkbench

        Dim locFirstReference, locSecondReference As Reference

        Dim locMeasurable As SPATypeLib.Measurable

        Dim dblAngle As Double



        locFirstReference = iPart.CreateReferenceFromObject(iFirstPlane)

        locSecondReference = iPart.CreateReferenceFromObject(iSecondPlane)

        locSPAWB = iPart.Parent.GetWorkbench("SPAWorkbench") 'aktivování Space Analysis workbench

        locMeasurable = locSPAWB.GetMeasurable(locFirstReference) 'definování 1.reference k měření (základna pro měření)

        dblAngle = locMeasurable.GetAngleBetween(locSecondReference) 'měření úhlu mezi definovanou 2.reference a již definovanou 1.referencí



        If dblAngle = 0 Then

            Return (True)

        Else

            Return (False)

        End If

    End Function

'---- Begin resolution script For object : Sweep.1



Dim partDocument1 As PartDocument

Set partDocument1 = CATIA.ActiveDocument



Dim part1 As Part

Set part1 = partDocument1.Part



Dim hybridBodies1 As HybridBodies

Set hybridBodies1 = part1.HybridBodies



Dim hybridShapeFactory1 As HybridShapeFactory

Set hybridShapeFactory1 = part1.HybridShapeFactory



Dim hybridBody1 As HybridBody

Set hybridBody1 = hybridBodies1.Item("Geometrical Set.1")



Dim hybridShapes1 As HybridShapes

Set hybridShapes1 = hybridBody1.HybridShapes



Dim hybridShapeSweepExplicit1 As HybridShapeSweepExplicit

Set hybridShapeSweepExplicit1 = hybridShapes1.Item("Sweep.1")



Dim hybridShapePlaneOffset5 As HybridShapePlaneOffset

Set hybridShapePlaneOffset5 = hybridShapes1.Item("Plane.1")





Dim reference6 As Reference

Set reference6 = part1.CreateReferenceFromObject(hybridShapeSweepExplicit1)



Dim reference7 As Reference

Set reference7 = part1.CreateReferenceFromObject(hybridShapePlaneOffset5)



Dim objSPAWorkbench As Workbench

Set objSPAWorkbench = part1.Parent.GetWorkbench("SPAWorkbench")



Dim objMeasurable As Measurable

Set objMeasurable = objSPAWorkbench.Measurable(reference6)



Dim MinimumDistance As Double

MinimumDistance = TheMeasurable.GetMinimumDistance(reference7)



'Dim CompositeRef As Reference

'Set CompositeRef = reference6.ComposeWith(reference7)

'Dim TheMeasurable As Measurable

'Set TheMeasurable = objSPAWorkbench.Measurable(reference7)

'objSPAWorkbench.M

Dim hybridShapeSplit1 As HybridShapeSplit

Set hybridShapeSplit1 = hybridShapeFactory1.AddNewHybridSplit(reference6, reference7, 1)

hybridShapeFactory1.GSMVisibility reference6, 0

hybridBody1.AppendHybridShape hybridShapeSplit1

part1.InWorkObject = hybridShapeSplit1

part1.Update



'---- End resolution script

End Sub

    Public Function ProductPosition(ByVal iProduct As Product) As Double()

         '' x axis components

        'iAxisComponentsArray(0) = 1.0

        'iAxisComponentsArray(1) = 0

        'iAxisComponentsArray(2) = 0.707

        '' y axis components

        'iAxisComponentsArray(3) = 0

        'iAxisComponentsArray(4) = 0

        'iAxisComponentsArray(5) = 0.707

        '' z axis components

        'iAxisComponentsArray(6) = 0

        'iAxisComponentsArray(7) = -0.707

        'iAxisComponentsArray(8) = 0.707

        '' origin point coordinates

        'iAxisComponentsArray(9) = 1.0

        'iAxisComponentsArray(10) = 2.0

        'iAxisComponentsArray(11) = 3.0



        Dim dblAxisComp(11) As Double

        Dim locAxisComponentsArray(11) As Object

        iProduct.Position.GetComponents(locAxisComponentsArray)

        For i As Integer = 0 To 11

            dblAxisComp(i) = CType(locAxisComponentsArray(i), Double)

        Next i

        Return (dblAxisComp)

    End Function 'ProductPosition

   Public Function GetProductInertia(ByVal iProdukt As Product) As Inertia

        'If successful, this Function will Return an Inertia object of Product

        'Otherwise, Nothing is returned (you should check the Return value)

        'Function For Product measuring - from website: http://v5vb.wordpress.com/2010/10/27/measuring-mass-inertia/

        'Mass, density, center of gravity, etc. can be obtained from Inertia object

        Dim objInertia As Inertia



        Try

            objInertia = CType(iProdukt.ReferenceProduct.GetTechnologicalObject("Inertia"), Inertia)

            Return (objInertia)

        Catch ex As Exception

            Return (Nothing)

        End Try

    End Function 'GetProductInertia



    Public Function GetBodyInertiaMeasure(ByVal iPart As Part, ByVal iBody As Body) As Inertia

        'If Function is successfully proceeded, this Function will Return an inertia object

        'Otherwise, Nothing is returned (you should check the Return value)

        'Function For body measuring - from website: http://v5vb.wordpress.com/2010/10/27/measuring-mass-inertia/

        'Mass, density, center of gravity, etc. can be obtained from Inertia object

        Dim objSPAWorkbench As SPAWorkbench

        Dim objInertia As Inertia



        Try

            objSPAWorkbench = CType(iPart.Parent.GetWorkbench("SPAWorkbench"), SPAWorkbench)

            objInertia = CType(objSPAWorkbench.Inertias.Add(iBody), Inertia)

            Return (objInertia)

        Catch ex As Exception

            Return (Nothing)

        End Try



    End Function 'GetBodyInertiaMeasure

Public Shared Function Selekce(ByVal iCATIA As INFITF.Application, ByVal strVyzva As String, ByVal strTypy As String) As Object



        Dim oSelekce As INFITF.Selection

        Dim objFilterArr() As Object

        Dim strDocasne() As String

        Dim strStatus As String

        Dim intFiltrPocet As Integer



        'Dim oParam As KnowledgewareTypeLib.Parameter



        'převod String na pole pro funkci SelectElement

        strDocasne = strTypy.Split(CChar(","))

        For Each s As String In strDocasne

            s.Trim()

        Next s



        intFiltrPocet = strDocasne.Length()



        'pokud vstupní parametr strTypy je prazdný, tak nic nevracej, uživatel špatně používá funkci

        If intFiltrPocet < 1 Then

            Return (Nothing)

        End If



        ReDim objFilterArr(intFiltrPocet - 1)



        For i As Integer = 0 To intFiltrPocet - 1

            objFilterArr(i) = strDocasne(i)



        Next i



        strVyzva = strVyzva & "    [ESC]=Strono"

        oSelekce = iCATIA.Application.ActiveDocument.Selection

        oSelekce.Clear()



        iCATIA.Application.Visible = True



        strStatus = oSelekce.SelectElement3(objFilterArr, strVyzva, False, INFITF.CATMultiSelectionMode.CATMultiSelTriggWhenSelPerf, False)

Err.Clear

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

On Error GoTo ErrHandler    ' V případě že Desk nebo nic je aktivní

  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

Public Sub ProduktExplorer(ByVal iProdukt As Product, ByVal iPodprodukty As System.Collections.Generic.List(Of cls_SubComponent))

        'Prozkoumá sestavu iProdukt Do hloubky a případné nalezené produkty přidá Do ArrayListu iPodprodukty

        'Příklad:

        'Dim Pole As ArrayList

        'ProduktExplorer (CATIA.ActiveDocument.Product, Pole)



        Dim locProdukty As Products 'Kolekce produktů uvnitř produktu iProdukt

        Dim locProdukt As Product   'Produkt z kolekce Produkty

        Dim locDocument As Document

        Dim locSubKomp As New cls_SubComponent

        Dim locPart As Part



        intAssyLevel += 1

        locProdukty = iProdukt.Products

        For Each locProdukt In locProdukty



            locDocument = CType(locProdukt.ReferenceProduct.Parent, Document)

            'pokud je V4 model tak neprovede přetypování a locDocument je referencí na předchozí úspěšné přetypování, nutno před tímto ověřit co je V4 model,

            ' ale jak zjistit je locProduct je V4 model





            If TypeName(locDocument) = "PartDocument" Then

                locPart = CType(locProdukt.ReferenceProduct.Parent.Part, Part)

                locSubKomp = StorePartInfo(locPart, intAssyLevel)

                iPodprodukty.Add(locSubKomp)

                'ještě projít jednotlivá Body

                For Each iBody As Body In locPart.Bodies

                    If iBody.InBooleanOperation = False Then

                        locSubKomp = StoreBodyInfo(locPart, iBody, intAssyLevel + 1)

                        iPodprodukty.Add(locSubKomp)

                    End If

                Next

            ElseIf TypeName(locDocument) = "ProductDocument" Then

                locSubKomp = StoreProductInfo(locProdukt, intAssyLevel)



                'If locDocument.FullName.Contains("model") Then  'TOTO ZATIM NEFUNGUJE NUTNO OPRAVIT !!!!!!!!!!!!!!!!

                '    locSubKomp.Type = cls_SubComponent.SubComponentType.Model

                'End If

                iPodprodukty.Add(locSubKomp)

            Else

                'dokument není ani Part ani Product, neznámý object

                locSubKomp.Name = locDocument.FullName

                locSubKomp.Type = cls_SubComponent.SubComponentType.Unknown

                iPodprodukty.Add(locSubKomp)

            End If

            ProduktExplorer(locProdukt, iPodprodukty) 'Rekurzivní volání

        Next locProdukt

        intAssyLevel -= 1

    End Sub 'ProduktExplorer

Product.PartNumber = Document.Product.PartNumber

Part = Product.ReferencedProduct.Part

Part = Document.Part

Part = Product.ReferenceProduct.Parent.Part 

   

Public Function MaterialOfBody(ByVal iBody As Body) As String

        'Vrátí název materiálu pro Body

        Dim locMaterial As Material = Nothing

        Dim locMatManager As MaterialManager

        locMatManager = CType(iBody.GetItem("CATMatManagerVBExt"), MaterialManager)

        locMatManager.GetMaterialOnBody(iBody, locMaterial)

        If locMaterial Is Nothing Then

            Return ("NONE")

        Else

            Return (locMaterial.Name)

        End If

    End Function 'MaterialOfBody