Pokud chci vytvořit DMT, tak musím data textů vyexportovat přípradně provést report z Mapu, upravit v excelu, uložit a znovu načíst tabulku bodů a z nich pak vytvořit DMT. Zdá se mi to celkem zdržující a komplikované. Takže pro zájemce je tady kostra jednoduchého VBA makra, které převede (a případně rovnou vymaže) dané texty na 3D body ACADu, ze kterých lze konverzí přímo udělat body Civilu. Nevýhodou je, že body nemají vlastní čísla (Civil je očísluje sám). Doufám, že to někomu přijde vhod i jako příklad VBA. Šťastné a veselé všem uživatelům CAD Fóra.

 

'pomocné makro pro převod výšek, které jsou jako textové hodnoty do 3D bodů ACADu
'Chop 19.12.2006

'před spuštěním byste měli mít vybrány objekty ke zpracování (texty)
'pomocné ACADbody se vytvoří do aktivní hladiny
'pomocné ACADbody nejsou očíslovány

'po proběhnutí makra již ručně stačí použít příkaz Civilu z nabídky
'CreatePoints "Convert ACAD Points"
'očíslování bodů si udělá CIVIL 3D sám
'pomocné body ACAD Points jsou opravdu konvertovány na body Civilu a nemusíte je mazat
'a nezapoměňe si předem vypnout dotaz na Description (Prompt for Descriptions: None)
'pak lze DMT vytvořit jediným příkazem z bodů

Dim obj As AcadObject 'pomocná proměnná pro obecný objekt ACADu
For Each obj In ThisDrawing.ActiveSelectionSet 'projdeme všechny vybrané objekty (musí být vybrány před spuštěním tohoto makra)
    If TypeOf obj Is AcadText Then 'pracujeme pouze s texty
        Dim txt As AcadText 'vytvoříme pomocný objekt konkrétního typu
        Set txt = obj 'a tady z obecného objektu vytvoříme konkrétní, protože jinak se nedostaneme k podrobným vlastnostem jako je obsah textu
        If Len(txt.TextString) > 0 Then 'pokud obsah textu není prázdný pokračujeme ve zpracování
           Dim bod(0 To 2) As Double 'pomocné pole pro vytvoření 3D bodu
           bod(0) = txt.InsertionPoint(0) 'převzetí x-ové souřadnice nového bodu z x-ové souřadnice textu
           bod(1) = txt.InsertionPoint(1) 'převzetí y-ové souřadnice nového bodu z y-ové souřadnice textu
           bod(2) = Val(txt.TextString) 'převzetí z-ové souřadnice bodu z textové hodnoty - není ošetřeno na nesmyslné textové hodnoty! CDbl kupodivu hlásí chybu (nezvládne ")
           ThisDrawing.ModelSpace.AddPoint bod 'vytvoření nového bodu v modelu
           'txt.Delete 'pokud chcete použitý text z výkresu vymazat, odstraňte první '
        End If 'konec zpracování neprázdného textu
     End If 'konec zpracování jednoho textu
Next obj 'pokračujeme ve zpracování dalšího objektu
End Sub