Zobacz temat - CreateLinearDimension w Corel X4

Corel FORUM
Forum użytkowników programów firmy Corel. Grafika wektorowa, rastrowa i obróbka zdjęć cyfrowych

Makra - CreateLinearDimension w Corel X4

michal.s - 14 Czerwiec 2017, 17:45
Temat postu: CreateLinearDimension w Corel X4

Witam.
Czy mógłbym prosić Was o pomoc w przygotowaniu makra do wymiarowania elementów w Corel-u X4?
Przygotowuję do każdego projektu siatkę wykrojnika, która składa się z 4 prostokątów. Za każdym razem o innych wymiarach.
Kiedyś pomogliście mi w przygotowaniu makra do rysowania takich opakowań. Do dziś z tego korzystam i nie wyobrażam sobie pracy bez tego programiku :-)

Oto część tego kodu

Private Sub RysujPudelko()
Dim s As Shape
Dim sp As SubPath
Dim crv As Curve
Dim brk3 As ShapeRange
On Error GoTo koniec
s_1 = X1.Text: s_2 = X2.Text: w_1 = Y.Text: k = X0.Text

's_1 = 100: s_2 = 300: w_1 = 200: k = 40

k = k / 25.4:
a = s_1 / 25.4:
b = s_2 / 25.4:
c = w_1 / 25.4:
d = a / 2:
e = 0.3 / 2.54

' A-szerokość 1 boku, B-szerokość drugiego boku
' C-wysokość pudełka, D-połowa wysokości pudełka, k-klapka klejowa

' rysujemy pudełko

Set s = ActiveLayer.CreateRectangle(k, d, k + a, c + d)
s.Fill.ApplyNoFill
s.Outline.SetProperties 0.02, , CreateCMYKColor(0, 0, 0, 100), ArrowHeads(0), ArrowHeads(0)

Set s = ActiveLayer.CreateRectangle(k + a, d, k + a + b, c + d)
s.Fill.ApplyNoFill
s.Outline.SetProperties 0.02, , CreateCMYKColor(0, 0, 0, 100), ArrowHeads(0), ArrowHeads(0)

Set s = ActiveLayer.CreateRectangle(k + a + b, d, k + a + b + a, c + d)
s.Fill.ApplyNoFill
s.Outline.SetProperties 0.02, , CreateCMYKColor(0, 0, 0, 100), ArrowHeads(0), ArrowHeads(0)

Set s = ActiveLayer.CreateRectangle(k + a + b + a, d, k + a + b + a + b, c + d)
s.Fill.ApplyNoFill
s.Outline.SetProperties 0.02, , CreateCMYKColor(0, 0, 0, 100), ArrowHeads(0), ArrowHeads(0)

koniec:
PudFormKarton.Hide

Niestety nie można nagrać takiego makra i potem sobie go dopasować do swoich potrzeb.
Tak zrobiłem już kilka i działają bez zarzutu.
W necie znalazłem coś takiego

Kod:

Sub MakeDimensions()
Dim x As Double, y As Double, sx As Double, sy As Double
Dim pt1 As SnapPoint, pt2 As SnapPoint
Dim s As Shape

ActiveSelection.GetBoundingBox x, y, sx, sy
Set pt1 = CreateSnapPoint(x, y)
Set pt2 = CreateSnapPoint(x + sx, y)
Set s = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pt1, pt2, True, , , cdrDimensionStyleDecimal, Units:=cdrDimensionUnitIN)
s.Dimension.TextShape.SetPosition x + sx / 2, y - 1

Set pt1 = CreateSnapPoint(x + sx, y)
Set pt2 = CreateSnapPoint(x + sx, y + sy)
Set s = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pt1, pt2, True, , , cdrDimensionStyleDecimal, Units:=cdrDimensionUnitIN)
s.Dimension.TextShape.SetPosition x + sx + 1, y + sx / 2
End Sub