Vánoční čas

Vánoční volno si užívám v pohodě a klidu. Při sledování filmů a popíjení dobrého čaje tvořím nové výtvory.

Fulleren

Uhlíková struktura C60

Example in wikipedia

Výzdoba kanceláře

Do novéhu uspořádání kanceláře jsem přinesl nový dekorační prvek. Do středu místnosti nad počítače jsem na světlo umístil mého zatím posledního draka - Duhu Úsvitu.

Duha Úsvitu - Dawn Rainbow
barva: zelená
rozpětí: 1000mm
délka: 1000mm
strava: hmyz a drobní hlodavci

Kolekce

Na poličce v kanceláři


Hromadně na křesle


Hromada krabiček

Pěkně barevně

Párty lučních koníků.

Podzim začína

Podzim nám začal výletem na chatu.

A takto opékají profesionálové.

Origami koule

Pěkné kulovité tvary složené s několika kousků papíru.

Koule z pětiúhelníků


Koule z okrasných trojúhelníků

JUDO Soustředění

Tak, letní judo soustředění je za námi. Bylo to faj. Děti převážně malé. Mnoho nových tváří jsem poznali.

Počasí nám přálo. Byla jen jedna bouřka tvajicí celou noc. Hromy, blesky, prostě kanonáda celou noc. Pršelo jen první a prostřední den. Lehný deštík, nic moc.

Perfektně jsme si zacvičili, naučili se nové techniky, někteří si zvýšili svůj technický stupeň.

Na bazénu se ukázali poseroutkové, co se báli, že spadnou do vody. Teda do vody rači skočili, než by je tam někdo hodil. A na druhé si troufli jen v čtyřnásobné přesile.

Letos nebyl na náš tábor pořádán přepad, i když mnozí byli trvale připraveni na tuto situaci. Noční akce byle jiná. Stezka odvahy. Zvýšení odvahy skupny jako celku bylo znatelné. Strašihla nejsou a náhodné kolemjdoucí turisty zdvořile pozdravíme.

Na konci se mnohým domů nechtělo. Byli to převážně trenéři a jim podobní.

Papírové krabičky

Modrá trojúhelníková krabička


Květinová trojúhelníková matrjoška


Květinová šestihranná krabička

OriGami draci

Tříhlavá saň


Zlatý okřídlený had


Rubínový jeskynní okřídlený had

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

Malování v kanceláři

Včera nám v kanceláři vymalovali. Máme novou pěkně žlutou barvu stěn. Jedna věc se jim ale nepovedla - za stanami nemalovali. Škoda, jestli budeme posouvat někdy v budoucnu nábytek bude to vypadat dost podivně.

Vylepil jsem si plakáty a už se cítím jako dřív.