[VBA] - jak stworzyć nowy styl wymiarowania

[Michał J]

Witam

pytnie jak w temacie,

mam ZwCada 2009i pro, 2009.07.30(11052)

przerabiam makro z AutoCada które wygląda tak:

Sub Styl_WYM()

Dim StylWym As AcadDimStyle

Dim WYMIAR As AcadDimAligned

Dim P1(0 To 2) As Double

Dim P2(0 To 2) As Double

Dim Ptext(0 To 2) As Double

Dim SKALA_RYS As Integer

Dim WARSTWA As AcadLayer

SKALA_RYS = 50 ' przykładowo

Set WARSTWA = ThisDrawing.Layers.Add("Mic_WYMIARY")

WARSTWA.color = 8

ThisDrawing.ActiveLayer = WARSTWA

P1(0) = 0: P1(1) = 0: P1(2) = 0

P2(0) = 200: P2(1) = 0: P2(2) = 0

Ptext(0) = 100: Ptext(1) = 100: Ptext(2) = 0

Set WYMIAR = ThisDrawing.ModelSpace.AddDimAligned(P1, P2, Ptext) ' wstawiam wymiar

'edytuje wstawiony wymiar

WYMIAR.ScaleFactor = SKALA_RYS

WYMIAR.Arrowhead1Type = acArrowOblique

WYMIAR.Arrowhead2Type = acArrowOblique

WYMIAR.ArrowheadSize = 2.5

WYMIAR.TextStyle = "Mic_ROMANS_WYM"

WYMIAR.TextHeight = 3

WYMIAR.TextColor = acCyan

WYMIAR.DimensionLineExtend = 1.25

WYMIAR.DimensionLineColor = "8"

WYMIAR.ExtensionLineExtend = 3

WYMIAR.ExtensionLineColor = "8"

WYMIAR.ExtensionLineOffset = 10

WYMIAR.RoundDistance = 1

WYMIAR.TextMovement = acDimLineWithText

Dim NAZWA As String

NAZWA = "Mic_" & SKALA_RYS

Set StylWym = ThisDrawing.DimStyles.Add(NAZWA) ' tworze nowy styl wymiarowy

StylWym.CopyFrom WYMIAR ' kopiuje do stylu ustawienia z wstawionego wymiaru

ThisDrawing.ActiveDimStyle = StylWym ' ustawiam nowy styl wymiarowania na aktywny

WYMIAR.Delete 'kasuje juz niepotrzebny wymiar

End Sub

przeróbka do ZwCad'a:

Sub Styl_WYM()

Dim StylWym As ZwcadDimStyle

Dim WYMIAR As ZwcadDimAligned

Dim SKALA_RYS As Integer

Dim WARSTWA As ZwcadLayer

SKALA_RYS = 50 ' przykładowo

Set WARSTWA = Thisdocument.Layers.Add("Mic_WYMIARY")

WARSTWA.Color = 8

Thisdocument.ActiveLayer = WARSTWA

Dim X1, X2, X3, Y1, Y2, Y3 As Double 'inna deklaracja punktów wstawienia niż w ACad

Dim P1 As New ZwcadPoint

Dim P2 As New ZwcadPoint

Dim P3 As New ZwcadPoint

X1 = 0: Y1 = 0

X2 = 200: Y2 = 0

X3 = 100: Y3 = 100

P1.x = X1

P1.y = Y1

P2.x = X2

P2.y = Y2

P3.x = X3

P3.y = Y3

Set WYMIAR = Thisdocument.ModelSpace.AddDimAligned(P1, P2, P3)

'edytuje wstawiony wymiar

WYMIAR.ScaleFactor = SKALA_RYS

WYMIAR.Arrowhead1Type = zcArrowOblique

WYMIAR.Arrowhead2Type = zcArrowOblique

WYMIAR.ArrowheadSize = 2.5

WYMIAR.TextStyle = "Mic_ROMANS_WYM"

WYMIAR.TextHeight = 3

WYMIAR.TextColor = zcCyan

WYMIAR.DimensionLineExtend = 1.25

WYMIAR.DimensionLineColor = "8"

WYMIAR.ExtensionLineExtend = 3

WYMIAR.ExtensionLineColor = "8"

WYMIAR.ExtensionLineOffset = 10

WYMIAR.RoundDistance = 1

WYMIAR.TextMovement = zcDimLineWithText

Dim NAZWA As String

NAZWA = "Mic_" & SKALA_RYS

Set StylWym = Thisdocument.DimensionStyles.Add(NAZWA) ' w tej lini

StylWym.CopyFrom WYMIAR ' albo w tej makro sie wykrzacza

Thisdocument.ActiveDimStyle = StylWym

WYMIAR.Delete

End Sub

problem jest w tym że w ZwCad'zie klasa ZwCadDimStyle nie posiada CopyFrom jak to jest w AutoCadzie, pytanie jak ten problem obejść ?? czy ktoś już się z tym zetknął ??

problem jest też z grotami - niezmienia mi ich na "/" tylko są domyślne strzałki :( i pozostałych danych też nieprzypisuje :( jak inaczej można programowo edytować wymiar??

[kruszynski]

Rzeczywiście nie ma funkcji CopyFrom.

Dlaczego wybrał Pan taką metodę - Tworzenie obiektu wymiarowania i kopiowanie jego ustawień do stylu? Moim zdaniem lepiej byłoby poprostu utworzyć nowy styl i poustawiać jego właściwości.

W katalogu ZWCAD/Help jest plik: VBARef.chm, Jest w nim opisany model obiektowy i wszystkie dostępne właściwości i funkcje dla poszczególnych typów obiektów, style wymiarowania też są opisane.

Raczej nie znam łatwego rozwiązania problemu wyświetlania innych strzałek niż są we właściwościach, skonsultuję tą sprawę z producentem programu.

Inaczej programowo można edytować wymiary przez LISP. Jest to skomplikowane ale możliwe.

[Michał J]

Witam

i już po problemie :) :grin:

tworząc nowy styl wymiarowania pobiera on ustawienia ze zmiennych systemowych, więc najpierw nadaje odpowiednim zmiennym odpowiednie wartości a potem dodaje styl.

Przykładowy kod poniżej:

Sub Nowy_StylWYM()

Dim newStyle1 As ZwcadDimStyle

Thisdocument.SetVariable "DIMSCALE", 1

Thisdocument.SetVariable "DIMBLK", "."

Thisdocument.SetVariable "DIMASZ", 2.5

Thisdocument.SetVariable "DIMTXSTY", "Standard" '

Thisdocument.SetVariable "DIMTXT", 3

Thisdocument.SetVariable "DIMCLRT", 4

Thisdocument.SetVariable "DIMTAD", 0

Thisdocument.SetVariable "DIMTVP", 2.5 / 3

Thisdocument.SetVariable "DIMCLRE", 8

Thisdocument.SetVariable "DIMDLE", 0 '1.25

Thisdocument.SetVariable "DIMCLRD", 8

Thisdocument.SetVariable "DIMEXE", 2

Thisdocument.SetVariable "DIMJUST", 0

Thisdocument.SetVariable "DIMEXO", 10

Thisdocument.SetVariable "DIMRND", 1

Thisdocument.SetVariable "DIMDEC", 0

Thisdocument.SetVariable "DIMADEC", 1

Thisdocument.SetVariable "DIMTMOVE", 0

Thisdocument.SetVariable "DIMDLI", 5

Thisdocument.SetVariable "DIMATFIT", 0

Set newStyle1 = Thisdocument.DimensionStyles.Add("STYL_1")

Thisdocument.ActiveDimStyle = newStyle1

End Sub

W przeciwieństwie do tworzenia stylów tekstów to powyższy kod działa tylko przy pierwszym użyciu, przy drugiej próbie wyskakuje gdyż już taki styl ma dodany. Moje pytanie w związku z tym, czy ktoś wie jak sprawdzić czy dany styl już istnieje

- jeżeli niema to dodaje a jeżeli istnieje to nie dodaje. Proszę o jakiś przykład.

Z góry dziękuje

[kruszynski]

ja to robie tak:

On Error Resume Next
Set Blode = Thisdocument.Blocks.Item(newName)
On Error GoTo 0
If TypeName(Blode) <> "Nothing"
   ' chyba może też być warunek Blode Not(IsNothing)
   ' tu sie dzieje co ma sie dziać
EndIf

[Michał J]

Witam

Dziękuje za podpowiedz, po drobnej modyfikacji działa jak trzeba i wygląda to tak:

...
...
...
On Error Resume Next
Set Blode = Thisdocument.Blocks.Item("STYL_1")

If TypeName(Blode) = "Nothing" Then
   Set newStyle1 = Thisdocument.DimensionStyles.Add("STYL_1")
   Thisdocument.ActiveDimStyle = newStyle1
End If

End Sub

W między czasie zrobiłem to tak : (wydaje mi się że prościej) :smile:

Sub Nowy_StylWYM()
Dim newStyle1 As ZwcadDimStyle

On Error GoTo KONIEC

  ' deklaracja zmiennych systemowych
  ' dodanie stylu
  ' aktywacja dodanego stylu

KONIEC:
End Sub

Tylko niewiem czy jak bardziej rozbuduje ten kod to może się okazać że ten sposób jest niewystarczający, ale pożyjemy zobaczymy :smile:

Jeszcze raz dziękuje za podpowiedź

Pozdrawiam

[kruszynski]

Niby dobrze, ale niedobrze

Blocks dałem jako przykład bo taki miałem pod ręką, powinno być Textstyles czy jakoś podobnie.

To co Pan napisał będzie działało ale jak na końcu nie będzie

On Error GoTo 0

to poza funkcją jeśli wystąpi jakiś inny dowolny błąd to wróci znów do etykiety KONIEC co skutecznie zapętli program. Powodzenia w późniejszym diagnozowaniu gdzie jest błąd.

[kruszynski]

Można też zrobić tak:

.
.
On Error GoTo DefiniujStyl
'teraz styl jest, albo nie
Set Blode = Thisdocument.Textstyles.Item("STYL_1") 'jak nie ma, to przechodzi do etykiety
'Tu moge używać stylu bo napewno jest

Exit Sub ' jak tego nie będzie to zawsze wykona sie to co jest po etykiecie. 

DefiniujStyl:
'Tu tworze i definiuje właściwości stylu
Resume Next ' to przenosi spowrotem do Set Blode....
End Sub

Czasem też można użyć takich sposobów, ale przy większej ilości kodu łatwo sie w tym pogubić.