Otasek napsal(a): Lze nějak zjistit největší rozměry dílce ve směrech souřadného systému? Není potřeba rozlišovat jeho tvar, pouze největší opsaný kvádr, do kterého se vejde

Ale to se muze lisit .. nemusi to byt jen kvadr jako nejlepsi polotovar.

Nebylo by lepsi udelat uzivatelske vlastnosti a ty pak definovat > nacist do razitka ..

Radek Pícha napsal(a): Ručně vložit jedno políčko do oblasti roh.razítka je podle mě pro uživatele zatěžující. Spouštění makra jedním tlačítkem před dokončením výkresu se mi zdá jednodušší. Makro, které spouštím, řeší více věcí, například aktualizuje datum poslední změny. Též by se mi líbilo, kdyby to fungovalo bez nutnosti mačkat tlačítko...

Dobrý den!

Automatické spuštění makra lze v Inventoru zajistit jeho správným pojmenováním. Pokud název makra obsahuje "AutoOpen", "AutoNew", "AutoSave", "AutoClose" nebo "AutoEdit", makro se automaticky spustí při provádění příslušné akce, např. při ukládání výkresu (podrobnosti viz. Help v Inventoru).

Pro inspiraci přikládám makro (viz. níže), které řeší zápis hmotnosti modelu a použitých výkresových měřítek do uživatelských parametrů výkresu.

Prosím kohokoliv, kdo je ochoten poskytnout nějaká makra pro Inventor, aby je poslal na mou adresu nebo je zveřejnil v této konferenci (třeba pod nějakým novým tématem). Děkuji.

Option Explicit
Const SpaceBeforeMassUnit As Integer = 1
Const TotalMassUnit As String = "kg"

'Always use X and Y in the Scale display string
'Example HowToDisplayFirstViewScale=[X:Y] will display as [1:2] in the properties
Const HowToDisplayFirstViewScale As String = "X:Y"

'Always use X and Y in the Scale display string
'Example HowToDisplayAllViewScales=X:Y will display as 1:2 in the properties
Const HowToDisplayAllViewScales As String = "X:Y"
 
'Set the charactor for the All View Scales list separator
'Example ListSparator="," the list will dispaly as [5:1],[1:1]
Const ListSparator As String = " "
 
'Value that will control if the the First View is excluded from the All View Scales list
'True: Exclude the Scale of the First View from the All View Scales list
'False: All View Scales are included in the list
Const ExcludeFirstInAllScales As Boolean = True

'True: Uses the same display style as inventor, Scale 2.5 is shown as 2.5:1
'False: Always find an integer value for both values, Scale 2.5 is shown as 5:2
Const ShowScaleAsInventor As Boolean = True
Const ShowScaleAsInventorDecimals As Integer = 2

Public Sub AutoSave()
    Call UpdateTotalMassInPartsList
    Call ShowFirstViewScale
    Call ShowAllScales
End Sub

 
Public Sub UpdateTotalMassInPartsList()
   
    'ThisApplication.StatusBarText = "Updating Totalmass in the Parts List, Please wait."

    'On Error GoTo WrongPartsList
    ' Set a reference to the drawing document.
    ' This assumes a drawing document is active.
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
   
    Dim oPropSet As Property
    'Set the custom property "TotalMass" with the Assembly Mass
    Set oPropSet = oDrawDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE }").Item("TotalMass")

    If oDrawDoc.ReferencedFiles.Count <> 0 Then
        Dim oTotalMass As MassProperties
        Set oTotalMass = oDrawDoc.ReferencedFiles.Item(1).ComponentDefinition.MassPro perties
   
        Dim TotalMass As Double
        TotalMass = Round(oTotalMass.Mass, 1)
   
   
        oPropSet.Value = TotalMass & Space(SpaceBeforeMassUnit) & TotalMassUnit
    Else
        MsgBox ("Ve výkresu není pohled")
        oPropSet.Value = ""
    End If
   
End Sub

Private Sub ShowFirstViewScale()
 
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
    Dim ScaleProp As String
   
    On Error Resume Next
 
    'Find the Scale of the first View on the first Sheet
    ScaleProp = ConvScale2Fraction(oDrawDoc.Sheets.Item(1).DrawingViews.Item (1).Scale, True)
   
    'Add a custom property "Scale" with all the view scales
    Dim oPropSet As PropertySet
   
    Set oPropSet = ThisApplication.ActiveDocument.PropertySets("{D5CDD505-2E9C- 101B-9397-08002B2CF9AE}")
    Call oPropSet.Item("FirstViewScale").Delete
    Call oPropSet.Add(ScaleProp, "FirstViewScale")
   
    'Still having some problems that the last property does not update correct
    Call RefreshProperties
   
End Sub
 

Private Sub ShowAllScales()
   
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
   
    ' Set a reference to the first drawing view on the active sheet.
    ' This assumes that a parts list is on the active sheet.
   
    Dim ScaleProp As String
    Dim UniqueScales As New Collection
    Dim SortedScales() As Double
    Dim temp As Double
    Dim AllScales As String
   
    On Error Resume Next
   
    Dim i, j As Integer
   
    'Find all unique Scale on all the Sheets
    For j = 1 To oDrawDoc.Sheets.Count
        For i = 1 To oDrawDoc.Sheets.Item(j).DrawingViews.Count
             UniqueScales.Add CStr(oDrawDoc.Sheets.Item(j).DrawingViews.Item(i).Scale), CStr(oDrawDoc.Sheets.Item(j).DrawingViews.Item(i).Scale)
        Next i
    Next j
     
    ' Exclude the Scale of the First View from the All View Scales list
    If ExcludeFirstInAllScales Then UniqueScales.Remove (CStr(oDrawDoc.Sheets.Item(1).DrawingViews.Item(1).Scale))
     
    ReDim SortedScales(UniqueScales.Count - 1)
     
    'Copy the Scales from the Collection to an Array for bubble sort
    For i = 0 To UniqueScales.Count
        SortedScales(i) = CDbl(UniqueScales.Item(i + 1))
    Next i
     
    'Bubble Sortes the Scales
    For i = 0 To UBound(SortedScales) - 1
        For j = 0 To UBound(SortedScales) - 1
             If SortedScales(j) > SortedScales(j + 1) Then
                 temp = SortedScales(j)
                 SortedScales(j) = SortedScales(j + 1)
                 SortedScales(j + 1) = temp
             End If
        Next j
    Next i
   
    ' Add all the Scales to a String
    For i = UBound(SortedScales) To 1 Step -1
        AllScales = AllScales + ConvScale2Fraction(SortedScales(i), False) + ListSparator
    Next i
       
        AllScales = AllScales + ConvScale2Fraction(SortedScales(0), False)
       
    'Add a custom property "Scale" with all the view scales
    Dim oPropSet As PropertySet
   
    Set oPropSet = ThisApplication.ActiveDocument.PropertySets("{D5CDD505-2E9C- 101B-9397-08002B2CF9AE}")
    oPropSet.Item("AllViewScales").Delete
    Call oPropSet.Add(AllScales, "AllViewScales")
   
    'Still having some problems that the last property does not update correct
    Call RefreshProperties
       
End Sub
   
 
Private Function ConvScale2Fraction(ValScale As Double, FirstView As Boolean) As String
 
    Dim TempStr As String
    Dim sx As Long
    Dim sy As Long
    Dim dsx As Double
    Dim dsy As Double

   
    'Convert the deciaml value to a fraction
    Call DecToFrac(ValScale, sx, sy)
   
    dsx = sx
    dsy = sy
   
    If ShowScaleAsInventor Then
        If sx > 1 And sy >= 1 Then
             dsx = Round(ValScale, ShowScaleAsInventorDecimals)
             dsy = 1
        End If
    End If
   
    If FirstView Then
        TempStr = Replace(UCase(HowToDisplayFirstViewScale), "X", CStr(dsx))
        ConvScale2Fraction = Replace(TempStr, "Y", CStr(dsy))
    Else
        TempStr = Replace(UCase(HowToDisplayAllViewScales), "X", CStr(dsx))
        ConvScale2Fraction = Replace(TempStr, "Y", CStr(dsy))
    End If

End Function
 
Private Sub DecToFrac(DecimalNum As Double, Numerator As Long, Denom As Long)
 
   ' The BigNumber constant can be adjusted to handle larger fractional parts
   Const BigNumber = 1000
   Const SmallNumber = 0.0001
 
   Dim Inverse As Double, FractionalPart As Double
   Dim WholePart As Long, SwapTemp As Long
 
   Inverse = 1 / DecimalNum
   WholePart = Int(Inverse)
   FractionalPart = Frac(Inverse)
 
   If 1 / (FractionalPart + SmallNumber) < BigNumber Then
        ' Notice that DecToFrac is called recursively.
        Call DecToFrac(FractionalPart, Numerator, Denom)
        Numerator = Denom * WholePart + Numerator
 
        SwapTemp = Numerator
        Numerator = Denom
        Denom = SwapTemp
   Else ' If 1 / (FractionalPart + SmallNumber) > BigNumber
        ' Recursion stops when the final value of FractionalPart is 0 or
        ' close enough.  SmallNumber is added to prevent division by 0.
        Numerator = 1
        Denom = Int(Inverse)
   End If
  
End Sub
 
' This function is used by DecToFrac and DecToProperFact
 
Private Function Frac(x As Double) As Double
    Frac = Abs(Abs(x) - Int(Abs(x)))
End Function
 
' This additional procedure handles "improper" fractions and returns
' them in mixed form (a b/c) when the numerator is larger than the denominator
 
Private Sub DecToProperFrac(x As Double, a As Long, b As Long, c As Long)
   If x > 1 Then a = Int(x)
   If Frac(x) <> 0 Then
      Call DecToFrac(Frac(x), b, c)
   End If
End Sub
 
Private Sub RefreshProperties()
   
    Dim oPropSet As PropertySet
    Dim oPropSets As PropertySets
   
    Set oPropSet = ThisApplication.ActiveDocument.PropertySets("{D5CDD505-2E9C- 101B-9397-08002B2CF9AE}")
    Call oPropSet.Add("", "MyDummy")
    oPropSet.Item("MyDummy").Delete
   
    Call oPropSets.FlushToFile
 
End Sub

Lubomír Baďura napsal(a): Radek Pícha napsal(a): Ručně vložit jedno políčko do oblasti roh.razítka je podle mě pro uživatele zatěžující. Spouštění makra jedním tlačítkem před dokončením výkresu se mi zdá jednodušší. Makro, které spouštím, řeší více věcí, například aktualizuje datum poslední změny. Též by se mi líbilo, kdyby to fungovalo bez nutnosti mačkat tlačítko... Dobrý den! Automatické spuštění makra lze v Inventoru zajistit jeho správným pojmenováním. Pokud název makra obsahuje "AutoOpen", "AutoNew", "AutoSave", "AutoClose" nebo "AutoEdit", makro se automaticky spustí při provádění příslušné akce, např. při ukládání výkresu (podrobnosti viz. Help v Inventoru). Pro inspiraci přikládám makro (viz. níže), které řeší zápis hmotnosti modelu a použitých výkresových měřítek do uživatelských parametrů výkresu. Prosím kohokoliv, kdo je ochoten poskytnout nějaká makra pro Inventor, aby je poslal na mou adresu nebo je zveřejnil v této konferenci (třeba pod nějakým novým tématem). Děkuji. Option Explicit Const SpaceBeforeMassUnit As Integer = 1 Const TotalMassUnit As String = "kg" 'Always use X and Y in the Scale display string 'Example HowToDisplayFirstViewScale=[X:Y] will display as [1:2] in the properties Const HowToDisplayFirstViewScale As String = "X:Y" 'Always use X and Y in the Scale display string 'Example HowToDisplayAllViewScales=X:Y will display as 1:2 in the properties Const HowToDisplayAllViewScales As String = "X:Y"   'Set the charactor for the All View Scales list separator 'Example ListSparator="," the list will dispaly as [5:1],[1:1] Const ListSparator As String = " "   'Value that will control if the the First View is excluded from the All View Scales list 'True: Exclude the Scale of the First View from the All View Scales list 'False: All View Scales are included in the list Const ExcludeFirstInAllScales As Boolean = True 'True: Uses the same display style as inventor, Scale 2.5 is shown as 2.5:1 'False: Always find an integer value for both values, Scale 2.5 is shown as 5:2 Const ShowScaleAsInventor As Boolean = True Const ShowScaleAsInventorDecimals As Integer = 2 Public Sub AutoSave()     Call UpdateTotalMassInPartsList     Call ShowFirstViewScale     Call ShowAllScales End Sub Public Sub UpdateTotalMassInPartsList()         'ThisApplication.StatusBarText = "Updating Totalmass in the Parts List, Please wait."     'On Error GoTo WrongPartsList     ' Set a reference to the drawing document.     ' This assumes a drawing document is active.     Dim oDrawDoc As DrawingDocument     Set oDrawDoc = ThisApplication.ActiveDocument         Dim oPropSet As Property     'Set the custom property "TotalMass" with the Assembly Mass     Set oPropSet = oDrawDoc.PropertySets("{D5CDD505-2E9C-101B-9397-08002B2CF9AE }").Item("TotalMass")     If oDrawDoc.ReferencedFiles.Count <> 0 Then         Dim oTotalMass As MassProperties         Set oTotalMass = oDrawDoc.ReferencedFiles.Item(1).ComponentDefinition.MassPro perties             Dim TotalMass As Double         TotalMass = Round(oTotalMass.Mass, 1)                 oPropSet.Value = TotalMass & Space(SpaceBeforeMassUnit) & TotalMassUnit     Else         MsgBox ("Ve výkresu není pohled")         oPropSet.Value = ""     End If     End Sub Private Sub ShowFirstViewScale()       Dim oDrawDoc As DrawingDocument     Set oDrawDoc = ThisApplication.ActiveDocument     Dim ScaleProp As String         On Error Resume Next       'Find the Scale of the first View on the first Sheet     ScaleProp = ConvScale2Fraction(oDrawDoc.Sheets.Item(1).DrawingViews.Item (1).Scale, True)         'Add a custom property "Scale" with all the view scales     Dim oPropSet As PropertySet         Set oPropSet = ThisApplication.ActiveDocument.PropertySets("{D5CDD505-2E9C- 101B-9397-08002B2CF9AE}")     Call oPropSet.Item("FirstViewScale").Delete     Call oPropSet.Add(ScaleProp, "FirstViewScale")         'Still having some problems that the last property does not update correct     Call RefreshProperties     End Sub   Private Sub ShowAllScales()         Dim oDrawDoc As DrawingDocument     Set oDrawDoc = ThisApplication.ActiveDocument         ' Set a reference to the first drawing view on the active sheet.     ' This assumes that a parts list is on the active sheet.         Dim ScaleProp As String     Dim UniqueScales As New Collection     Dim SortedScales() As Double     Dim temp As Double     Dim AllScales As String         On Error Resume Next         Dim i, j As Integer         'Find all unique Scale on all the Sheets     For j = 1 To oDrawDoc.Sheets.Count         For i = 1 To oDrawDoc.Sheets.Item(j).DrawingViews.Count              UniqueScales.Add CStr(oDrawDoc.Sheets.Item(j).DrawingViews.Item(i).Scale), CStr(oDrawDoc.Sheets.Item(j).DrawingViews.Item(i).Scale)         Next i     Next j           ' Exclude the Scale of the First View from the All View Scales list     If ExcludeFirstInAllScales Then UniqueScales.Remove (CStr(oDrawDoc.Sheets.Item(1).DrawingViews.Item(1).Scale))           ReDim SortedScales(UniqueScales.Count - 1)           'Copy the Scales from the Collection to an Array for bubble sort     For i = 0 To UniqueScales.Count         SortedScales(i) = CDbl(UniqueScales.Item(i + 1))     Next i           'Bubble Sortes the Scales     For i = 0 To UBound(SortedScales) - 1         For j = 0 To UBound(SortedScales) - 1              If SortedScales(j) > SortedScales(j + 1) Then                  temp = SortedScales(j)                  SortedScales(j) = SortedScales(j + 1)                  SortedScales(j + 1) = temp              End If         Next j     Next i         ' Add all the Scales to a String     For i = UBound(SortedScales) To 1 Step -1         AllScales = AllScales + ConvScale2Fraction(SortedScales(i), False) + ListSparator     Next i                 AllScales = AllScales + ConvScale2Fraction(SortedScales(0), False)             'Add a custom property "Scale" with all the view scales     Dim oPropSet As PropertySet         Set oPropSet = ThisApplication.ActiveDocument.PropertySets("{D5CDD505-2E9C- 101B-9397-08002B2CF9AE}")     oPropSet.Item("AllViewScales").Delete     Call oPropSet.Add(AllScales, "AllViewScales")         'Still having some problems that the last property does not update correct     Call RefreshProperties         End Sub       Private Function ConvScale2Fraction(ValScale As Double, FirstView As Boolean) As String       Dim TempStr As String     Dim sx As Long     Dim sy As Long     Dim dsx As Double     Dim dsy As Double         'Convert the deciaml value to a fraction     Call DecToFrac(ValScale, sx, sy)         dsx = sx     dsy = sy         If ShowScaleAsInventor Then         If sx > 1 And sy >= 1 Then              dsx = Round(ValScale, ShowScaleAsInventorDecimals)              dsy = 1         End If     End If         If FirstView Then         TempStr = Replace(UCase(HowToDisplayFirstViewScale), "X", CStr(dsx))         ConvScale2Fraction = Replace(TempStr, "Y", CStr(dsy))     Else         TempStr = Replace(UCase(HowToDisplayAllViewScales), "X", CStr(dsx))         ConvScale2Fraction = Replace(TempStr, "Y", CStr(dsy))     End If End Function   Private Sub DecToFrac(DecimalNum As Double, Numerator As Long, Denom As Long)      ' The BigNumber constant can be adjusted to handle larger fractional parts    Const BigNumber = 1000    Const SmallNumber = 0.0001      Dim Inverse As Double, FractionalPart As Double    Dim WholePart As Long, SwapTemp As Long      Inverse = 1 / DecimalNum    WholePart = Int(Inverse)    FractionalPart = Frac(Inverse)      If 1 / (FractionalPart + SmallNumber) < BigNumber Then         ' Notice that DecToFrac is called recursively.         Call DecToFrac(FractionalPart, Numerator, Denom)         Numerator = Denom * WholePart + Numerator           SwapTemp = Numerator         Numerator = Denom         Denom = SwapTemp    Else ' If 1 / (FractionalPart + SmallNumber) > BigNumber         ' Recursion stops when the final value of FractionalPart is 0 or         ' close enough.  SmallNumber is added to prevent division by 0.         Numerator = 1         Denom = Int(Inverse)    End If    End Sub   ' This function is used by DecToFrac and DecToProperFact   Private Function Frac(x As Double) As Double     Frac = Abs(Abs(x) - Int(Abs(x))) End Function   ' This additional procedure handles "improper" fractions and returns ' them in mixed form (a b/c) when the numerator is larger than the denominator   Private Sub DecToProperFrac(x As Double, a As Long, b As Long, c As Long)    If x > 1 Then a = Int(x)    If Frac(x) <> 0 Then       Call DecToFrac(Frac(x), b, c)    End If End Sub   Private Sub RefreshProperties()         Dim oPropSet As PropertySet     Dim oPropSets As PropertySets         Set oPropSet = ThisApplication.ActiveDocument.PropertySets("{D5CDD505-2E9C- 101B-9397-08002B2CF9AE}")     Call oPropSet.Add("", "MyDummy")     oPropSet.Item("MyDummy").Delete         Call oPropSets.FlushToFile   End Sub

jak sem to tak zkoumal tak Patrik se napichnul do registrů a pomocí nic při volání "save" zpouští svou rutinku a je mu celkem jedno jestli je to ipt, iam, idw.. podle druhu souboru doplňuje volitelné proměnné

S tím poskytování vylepšení by chtělo přejít na úplně jinou politiku. Nikoliv prodávat vylepšení, ale vylepšení by měla být volně dostupná, aby každý potencionální uživatel viděl, že když si koupí tento soft, tak dopředu ví co tím získá a že nekupuje zajíce v pytli s těm co takové fičurky vymýšlí by měli ještě poskytovat slevy na upgrade.

Tedka pokud bych chtěl přejít ke konkurenci, tak vím přesně na co se zaměřit, co mě tady chybí a jaké jsou nedostatky a sondoval jak tyto problémy řeší oni.

hmm tak to už jsem vysunut out... nemám ambice tvořit profi rutiny pomocí "Visual Basic, popř. C++, C#, VB.Net atd." a VBA mi autospouštění v AplicationProject neumožní (jako třeba starý lisp)...

K návrhu politiky poskytování prospěšných rutin by se mohl vyjádřit třeba pan Michl...

tolik radosti co způsobyly 100kB text sem dlouho nezažil, a když člověk smaže ten ini soubor, tak při následném uložení si ten "zázrak" po sobě pouklízí

a máte udělaný rozvin? bez toho te nejde

Tedka mě tak trklo, že AI zjistit velikost dílce nějakým způsobem umí.
Když dělám plechařinu a nejsem zarovnaný do souřadného systému (kreslím nějak zešika) tak pak je rozvin také zašikma, a když se podívám na jeho velikost tak to hlásí největší rozměry vzhledem k osám souř.systému. a to je ta vlastnost co chci, jenže standartně je jen u plechů.
Každý dílec jde zapnout jako plech, ale to je trošku difné řešení...

Jo, to je přesně to co celou dobu chci o sestavu se mi nejedná.
No tedka ještě zjistit jak načíst hodnotu z položky "POPIS" v ipt a mám vyřešeno což se mi s pomocí p. Lisky hravě zdařilo...díky moc
Až budu mít udělátor hotový tak určitě dám vědět

Upravil Otasek