Převod Acad úseček na SCTN do Aveva PDMS

Při práci s PDMS občas potřebujete načíst nějakou grafiku z Autocadu pomocí datalu, toto je skript který vytvoří txt soubor, ves správné syntaxi pro tvorbu PDMS grafiky

Sub writdatal()

On Error Resume Next
ThisDrawing.SelectionSets.Item("oznac").Delete
If Err Then Err.Clear

MsgBox ("Vyber objekty pro převod do pdms, převedeny budou jen objekty typu line")

Dim line As AcadLine
Dim soubor As String
Dim startPoint As Variant
Dim endPoint As Variant

soubor = "c:\cad\output.txt"
soubor = InputBox("Zadej výstupní cestu", "Urči výstup", soubor)

Set objSelectionSet = ThisDrawing.SelectionSets.Add("oznac")

objSelectionSet.SelectOnScreen
Open soubor For Output As #1
For Each line In objSelectionSet

radek = "new sctn POSS N" & Round(line.startPoint(1), 0) & " E" & Round(line.startPoint(0), 0) & " U" & Round(line.startPoint(2), 0) & " POSE N" & Round(line.endPoint(1), 0) & " E" & Round(line.endPoint(0), 0) & " U" & Round(line.endPoint(2), 0)

Print #1, radek


Next

Close #1


objSelectionSet.Delete

End Sub

Nastavení Global width = 0 pro všechny polyline

Z programu Aveva PDMS 12.1 jsou generovány DXF soubory s nenulovou globalwidth u polyline
zde  je utilitka do Autocadu které u všech nastaví globalwidth=0

Sub zerothick()
'všem polyline ve výkrese nastaví globalwidth = 0
'deklarace
Dim intGroupCode(0) As Integer
Dim varDataCode(0) As Variant
Dim objAcadPoly As AcadLWPolyline 'deklarace jako objekt

' mazání starých selection setů

On Error Resume Next
intGroupCode(0) = 0
varDataCode(0) = "LWPolyline"
ThisDrawing.SelectionSets.Item("Poly").Delete
If Err Then Err.Clear

'select all
Set objSelectionSet = ThisDrawing.SelectionSets.Add("Poly")
objSelectionSet.Select acSelectionSetAll, , , intGroupCode, varDataCode

'cyklus prochází všechny poly v selekci, a nastaví Globalwidth = 0
For Each objAcadPoly In objSelectionSet
objAcadPoly.ConstantWidth = 0
Next objAcadPoly

End Sub

Autocad VBA Open Drawings

Jak pomocí makra pro Autocad otevřít hromadně více výkresů a provést naplánovanou akci? 

Public cesta As String
Public adresar As String
Public Soubory As String

Sub dxf2dwg()
'toto je cyklus ktery projde ve složce c:\prevod všechny dxf soubory
'cyklus projde jeden za druhým a na kažkém spustí funkci openDXF
adresar = "c:\prevod\" ' cesta se kterou se pracuje

Soubory = Dir(adresar & "\*.dxf") ' možno změnit na .dwg apod.
Do While Soubory <> ""

    cesta = adresar & Soubory ' sestaví cestu "c:\prevod\aaa.dxf"
    Debug.Print Soubory
    opendxf ' volá funkci open dxf
    ' zde je možné přidat dlaší procedury
    Soubory = Dir
    Loop
End Sub

Function opendxf()

ThisDrawing.Application.Documents.Open cesta  'otevře "c:\prevod\aaa.dxf"

Dim newLimits(0 To 3) As Double     'autocad klasika, deklarace souřadnic
    newLimits(0) = 0#: newLimits(1) = 0#: newLimits(2) = 594#: newLimits(3) = 420#
ThisDrawing.Limits = newLimits  ' nastavení limit
ThisDrawing.Regen acActiveViewport ' regen
' zde je mozno pridat další sekvenvi prikazu

ZoomAll ' nocomment
newnazaev = adresar & Replace(Soubory, ".dxf", ".dwg") 'sestavení cesty pro uložení
ThisDrawing.SaveAs (newnazaev) ' uloží jako
ThisDrawing.Close 'zavře výkres

End Function

Toto je konkrétní makro které otevře soubory *.dxf v c:\prevod\