Makro AI2008 - Rozvin plechu do dxf

Toto makro pro Autodesk Inventor 2008 z rozvinu modelu plechu vytvoří dxf soubor do v makru určeného místa.

Public Sub Rozvin_do_DXF()
 Dim invDoc As Inventor.Document
 Set invDoc = ThisApplication.ActiveDocument
 Dim sFileName As String
 sFileName = invDoc.DisplayName
 sFileName = Left(sFileName, Len(sFileName) - 4) 'bez .IPT
 Dim oDataIO As DataIO
 On Error Resume Next
 Set oDataIO = invDoc.ComponentDefinition.DataIO
 If Err.Number = 438 Then
  MsgBox "Je otevřen výkres, musí být otevřen model s rozvinem. Chyba č.: " & Err.Number
  Exit Sub
 End If
 On Error GoTo 0
 Dim sParam As String
 sParam = "FLAT PATTERN DXF?AcadVersion=R12&BendLayer=OHYBY&TangentLayer=ZACATEK_OHYBU&OuterProfileLayer=OBRYS"
 'dostupné formáty: AcadVersion = "2005","2004","2002", "2000", "R14", "R13", "R12" (R12 jen pro DXF)
 'možné parametry TangentLayer a BendLayer; příklady:
 Dim sDXFFileName As String
 sDXFFileName = "C:\Documents and Settings\Cedivoda.AUSTIN\Dokumenty\VÝKRESY PŘIPRAVENÉ K ODESLÁNÍ\" & sFileName & ".dxf"
 On Error Resume Next
 oDataIO.WriteDataToFile sParam, sDXFFileName
 Select Case Err
 Case 0
  MsgBox "Rozvin uložen do: " & sDXFFileName
 Case Else
  MsgBox "Chyba č.: " & Err.Number
 End Select
End Sub

Amfolkfest 2008

Stejně jako loni jsem byl na Pulčinách pomáhat při organizaci folkového festivalu Amfolkfest.

A letos jsem navíc učil sebeobranu.

Noví ptáčci

Jak jinak trávit dovolenou, když je deštivé počasí. Venku je škaredě. Jsou prázdniny, tak v televizi není cokoli, co by stálo za to zhlédnout. Sedím doma a skládám si u konvičky čaje.

Papoušek


Holubička


Labuť

Nové zvířátka

Moje nejnovější zvířátka. Teda krom dráčka. Dráček není zvíře, ale je prostě drak. Snad každý ví, že draci nejsou zvěř stejně tak jako lidé.

Netopýr


Jeřáb


Dráček

Noví hmyzáci

Podívejte se na moje nové výtvory ze života hmyzu. Ty jejich malinkaté nožičky mi dali ale zabrat. Bez pinzety ani ránu.

Luční koník

Brouk

Makro AI2008 - vyplnit měřítko

Toto makro pro Autodesk Inventor 2008 ve výkrese doplní do uživatelských vlastností měřítko podle vybraného pohledu.

Public Sub VyplnitMeritko()
If Not ThisApplication.ActiveDocument.DocumentType = kDrawingDocumentObject Then
  MsgBox "Funkci lze použít jen ve výkrese s alepoň jedním pohledem."
  Exit Sub
 End If
 Dim oDrgDoc As DrawingDocument
 Set oDrgDoc = ThisApplication.ActiveDocument
 If oDrgDoc.SelectSet.Count < 1 Then
  MsgBox "Musí být předem vybrán určující pohled"
  Exit Sub
 End If
 Dim Vybrane As SelectSet
 Dim VybranyPohled As DrawingView
 Set Vybrane = oDrgDoc.SelectSet
 If Not Vybrane.Item(1).Type = kDrawingViewObject Then
  MsgBox "Musí být předem vybrán pohled s modelem"
  Exit Sub
 End If
 Set VybranyPohled = Vybrane.Item(1)
 Dim MeritkoPohledu As Double
 MeritkoPohledu = VybranyPohled.Scale
 Dim SpravneMeritko As String
 Select Case Round(MeritkoPohledu, 4)
  Case 0.0667
   SpravneMeritko = "1 : 15"
  Case 0.1
   SpravneMeritko = "1 : 10"
  Case 0.125
   SpravneMeritko = "1 : 8"
  Case 0.1667
   SpravneMeritko = "1 : 6"
  Case 0.2
   SpravneMeritko = "1 : 5"
  Case 0.25
   SpravneMeritko = "1 : 4"
  Case 0.3333
   SpravneMeritko = "1 : 3"
  Case 0.4
   SpravneMeritko = "2 : 5"
  Case 0.5
   SpravneMeritko = "1 : 2"
  Case 0.6667
   SpravneMeritko = "2 : 3"
  Case 0.8
   SpravneMeritko = "4 : 5"
  Case 1
   SpravneMeritko = "1 : 1"
  Case 2
   SpravneMeritko = "2 : 1"
  Case 3
   SpravneMeritko = "3 : 1"
  Case 4
   SpravneMeritko = "4 : 1"
  Case 5
   SpravneMeritko = "5 : 1"
  Case 10
   SpravneMeritko = "10 : 1"
  Case 15
   SpravneMeritko = "15 : 1"
  Case 20
   SpravneMeritko = "20 : 1"
  Case Else
   SpravneMeritko = ""
 End Select
 Dim invDTProperties As PropertySet
 Set invDTProperties = oDrgDoc.PropertySets.Item("Uživatelsky definované vlastnosti programu Inventor")
 invDTProperties.Item("Měřítko").Value = SpravneMeritko
End Sub

Robot - SolidWorks

Od SolidWokrsu jsem si z jejich reklamní kampaně objednál návod aj s papírem na složení origami robota. Vyšel celkem pěkně.

Vypadá drsňácky, jako roboti od J. M. Trosky.

Makro AI2008 - průměr

Toto makro pro Autodesk Inventor 2008 ve výkrese doplní před vybrané kóty značku průměru a po opětovném spuštění ji odebere.

Public Sub PrumerPredKotu()
 If Not ThisApplication.ActiveDocument.DocumentType = kDrawingDocumentObject Then
  MsgBox "Funkci lze použít jen ve výkrese."
  Exit Sub
 End If
 Dim oDrgDoc As DrawingDocument
 Set oDrgDoc = ThisApplication.ActiveDocument
 Dim AList As Sheet
 Set AList = oDrgDoc.ActiveSheet
 If oDrgDoc.SelectSet.Count < 1 Then
  MsgBox "Musí být vybána kóta"
  Exit Sub
 End If
 Dim i As Long
 Dim counter As Long
 Dim VybranaKota As DrawingDimension
 For Each VybranaKota In oDrgDoc.SelectSet
  If VybranaKota.Tolerance.ToleranceType = kReferenceTolerance Then
   VybranaKota.Tolerance.SetToDefault
   VybranaKota.Text.FormattedText = "(" & ChrW(216) & VybranaKota.Text.FormattedText & ")"
  Else
   If Left(VybranaKota.Text.Text, 1) = ChrW(216) Then
    VybranaKota.Text.FormattedText = Mid(VybranaKota.Text.FormattedText, 2, Len(VybranaKota.Text.FormattedText) - 1)
   ElseIf Left(VybranaKota.Text.Text, 1) = "(" And Mid(VybranaKota.Text.Text, 2, 1) = ChrW(216) Then
    VybranaKota.Text.FormattedText = "(" & Mid(VybranaKota.Text.FormattedText, 3, Len(VybranaKota.Text.FormattedText) - 3) & ")"
   ElseIf Left(VybranaKota.Text.Text, 1) = "(" Then
    VybranaKota.Text.FormattedText = "(" & ChrW(216) & Mid(VybranaKota.Text.FormattedText, 2, Len(VybranaKota.Text.FormattedText) - 2) & ")"
   Else
    VybranaKota.Text.FormattedText = ChrW(216) & VybranaKota.Text.FormattedText
   End If
  End If
 Next
End Sub

Makro AI2008 - přepsaná kóta

Tímto makrem do Autodesk Inventor 2008 se ve výkrese kóty, které mají přepsanou hotnotu kóty modelu, zvýrazní červeně a při dalším zpuštění zase zčernají.

Public Sub ZvyrazniPrepsane()
 If Not ThisApplication.ActiveDocument.DocumentType = kDrawingDocumentObject Then
  MsgBox "Funkci lze použít jen ve výkrese."
  Exit Sub
 End If
 Dim oDrgDoc As DrawingDocument
 Set oDrgDoc = ThisApplication.ActiveDocument
 Dim AList As Sheet
 Set AList = oDrgDoc.ActiveSheet
 Dim counter As Long
 Dim VybranaKota As DrawingDimension
 Dim BarvaCervena As Inventor.Color
 Set BarvaCervena = ThisApplication.TransientObjects.CreateColor(255, 0, 0)
 Dim BarvaCerna As Inventor.Color
 Set BarvaCerna = ThisApplication.TransientObjects.CreateColor(0, 0, 0)
 Dim Obarvit As String
 Obarvit = "zjistit"
 For Each VybranaKota In AList.DrawingDimensions  
  If VybranaKota.ModelValueOverridden Then
   If Obarvit = "zjistit" Then
    If VybranaKota.Text.Color.Red = 255 Then
     Obarvit = "black"
    Else
     Obarvit = "red"
    End If
   End If
   If Obarvit = "red" Then
    VybranaKota.Text.Color = BarvaCervena
   ElseIf Obarvit = "black" Then
    VybranaKota.Text.Color = BarvaCerna
   End If
  End If
 Next
End Sub