[CDR 2017-2020] Размерные линии

izrukvruki

Топикстартер
12 лет на форуме
Сообщения
1 684
Реакции
276
Вокруг выделенного объекта хочу сделать размерные линии, код пишу такой:

Set s = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pt1, pt2, True, , , cdrDimensionStyleDecimal, 0, , cdrDimensionUnitCM, , , , , , , 1, , , , 200)

1653546074351.png


Хочу чтоб в цифре отображалась только целая часть. Вроде как нолик (выделен жирным) должен отвечать за это... Но почему то он не работает.
1653546150159.png
 

DukereD

Участник
Сообщения
219
Реакции
50
Вокруг выделенного объекта хочу сделать размерные линии, код пишу такой:

Set s = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pt1, pt2, True, , , cdrDimensionStyleDecimal, 0, , cdrDimensionUnitCM, , , , , , , 1, , , , 200)

Хочу чтоб в цифре отображалась только целая часть. Вроде как нолик (выделен жирным) должен отвечать за это... Но почему то он не работает.

это зависит не от кода, а от настроек размерных линий. берем инструмент размерной линии. не рисуя и не выбирай ни один объект задаем ему параметры. теперь макрос будет расставлять буковки согласно выставленным значениям. (по умолчанию)
 
  • Спасибо
Реакции: mnemonix и izrukvruki

izrukvruki

Топикстартер
12 лет на форуме
Сообщения
1 684
Реакции
276
это зависит не от кода, а от настроек размерных линий. берем инструмент размерной линии. не рисуя и не выбирай ни один объект задаем ему параметры. теперь макрос будет расставлять буковки согласно выставленным значениям. (по умолчанию)

Настройки программы это хорошо, но я бы хотел макросом контролировать процесс, чтоб на всех компах, не зависимо от настроек Корела. Если это конечно возможно...
 

DukereD

Участник
Сообщения
219
Реакции
50
Настройки программы это хорошо, но я бы хотел макросом контролировать процесс, чтоб на всех компах, не зависимо от настроек Корела. Если это конечно возможно...
я тож с этим ковырялся другого способа не нашел.

может как-то можно в кореловские настройки залезть считать/поменять их?
 
  • Спасибо
Реакции: izrukvruki

eugeny

15 лет на форуме
Сообщения
568
Реакции
126
Сработает так:
Код:
Set s = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pt1, pt2, True, , , cdrDimensionStyleDecimal, 0, , cdrDimensionUnitCM)

удалите "хвост".
 
  • Спасибо
Реакции: izrukvruki

izrukvruki

Топикстартер
12 лет на форуме
Сообщения
1 684
Реакции
276
Сработает так:
Код:
Set s = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pt1, pt2, True, , , cdrDimensionStyleDecimal, 0, , cdrDimensionUnitCM)

удалите "хвост".

а хвост мне тоже нужен... там толщина линий (1см) и размер шрифта задаю (200pt)
 

eugeny

15 лет на форуме
Сообщения
568
Реакции
126
а хвост мне тоже нужен... там толщина линий (1см) и размер шрифта задаю (200pt)
ХОтя кажется решение проще. (Я просто уже забыл %8) Добавьте после создания:
Код:
s.style.GetProperty("dimension").SetProperty "precision", 0
Давно находил корень этой проблемы
 

eugeny

15 лет на форуме
Сообщения
568
Реакции
126
вот, кстати, у меня после создания каждого размера добавлены три строки (возможно у вас и размер может слетать):
Код:
rasm.Dimension.TextShape.text.Story.size = CLng(fnt)
rasm.style.GetProperty("dimension").SetProperty "precision", 0
rasm.style.GetProperty("dimension").SetProperty "units", 3
 
  • Спасибо
Реакции: DukereD

izrukvruki

Топикстартер
12 лет на форуме
Сообщения
1 684
Реакции
276
вот, кстати, у меня после создания каждого размера добавлены три строки (возможно у вас и размер может слетать):
Код:
rasm.Dimension.TextShape.text.Story.size = CLng(fnt)
rasm.style.GetProperty("dimension").SetProperty "precision", 0
rasm.style.GetProperty("dimension").SetProperty "units", 3
а толщину обводки так нельзя задать?
 

dastin

Некромант-любитель
12 лет на форуме
Сообщения
1 680
Реакции
1 502
опробуйте это ...
тут дополнительно заданы коэффициенты увеличения размера шрифта и отступа размерных линий - в зависимости от размера объекта
...

Код:
Sub razmer_vydeleniya()
    ActiveDocument.Unit = cdrMillimeter

    Optimization = True
    EventsEnabled = False
    ActiveDocument.SaveSettings
    ActiveDocument.BeginCommandGroup "Print_Size"
   
    Dim x#, y#, sx#, sy#, k#
    Dim pt1 As SnapPoint, pt2 As SnapPoint
    Dim s As Shape
   

    ActiveSelection.GetBoundingBox x, y, sx, sy
    If sx >= sy Then k = sx / 8
    If sy > sx Then k = sy / 8
   
    Set pt1 = CreateSnapPoint(x, y + sy)
    Set pt2 = CreateSnapPoint(x + sx, y + sy)
    Set s = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pt1, pt2, True, , , cdrDimensionStyleDecimal, , , , , , , , , , , , , , k)
    s.Dimension.TextShape.SetPosition x + sx / 2, y + sy + (k / 2)
    ForceDimensionPrecision s, 1

    Set pt1 = CreateSnapPoint(x, y)
    Set pt2 = CreateSnapPoint(x, y + sy)
    Set s = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pt1, pt2, True, , , cdrDimensionStyleDecimal, , , , , , , , , , , , , , k)
    s.Dimension.TextShape.SetPosition x - (k / 2), y + sx / 2
    ForceDimensionPrecision s, 1
   
    ActiveDocument.EndCommandGroup
    ActiveDocument.RestoreSettings
    EventsEnabled = True
    Optimization = False
    ActiveDocument.ClearSelection
    ActiveWindow.Refresh
    Application.Refresh

End Sub

Private Sub ForceDimensionPrecision(ByVal s As Shape, ByVal precision As Integer)
    s.Style.GetProperty("dimension").SetProperty "precision", precision
End Sub

ну или готовый gms
 

Вложения

  • Size_Selection.zip
    7.3 КБ · Просм.: 15
Последнее редактирование:
  • Спасибо
Реакции: mnemonix и izrukvruki

izrukvruki

Топикстартер
12 лет на форуме
Сообщения
1 684
Реакции
276
Код не мой, подправил числа, вставил несколько подсказанных здесь строчек.
Делал для знакомого, для наружки, объекты у него большие, ориентировался на 300*70см, на мелких объектах смотрится плохо.

Код:
Sub razmery()
    Dim x As Double, y As Double, sx As Double, sy As Double
    Dim pt1 As SnapPoint, pt2 As SnapPoint
    Dim s As Shape
    
    ActiveDocument.BeginCommandGroup "Размеры объекта"
    
    ActiveDocument.Unit = cdrCentimeter
    
    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)
    s.Dimension.TextShape.SetPosition x + sx / 2, y - 8
    s.Style.GetProperty("dimension").SetProperty "precision", 0
    s.Style.GetProperty("dimension").SetProperty "units", 15
    s.Dimension.TextShape.Text.Story.Size = 200
    s.Dimension.TextShape.Text.Story.Font = "Arial Black"
    s.Outline.Width = 1
    
    Set pt1 = CreateSnapPoint(x + sx, y)
    Set pt2 = CreateSnapPoint(x + sx, y + sy)
    Set s = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pt1, pt2, True, , , cdrDimensionStyleDecimal)
    s.Dimension.TextShape.SetPosition x + sx + 8, y + sx / 2
    s.Style.GetProperty("dimension").SetProperty "precision", 0
    s.Style.GetProperty("dimension").SetProperty "units", 15
    s.Dimension.TextShape.Text.Story.Size = 200
    s.Dimension.TextShape.Text.Story.Font = "Arial Black"
    s.Outline.Width = 1
    
    ActiveDocument.EndCommandGroup
End Sub
 
  • Спасибо
Реакции: mnemonix и eugeny

eugeny

15 лет на форуме
Сообщения
568
Реакции
126
Я в своем модуле использовал один вариант cdrDimensionSlanted, отказавшись от cdrDimensionVertical и cdrDimensionHorizontal.
Код:
Set rasm = ActiveLayer.CreateLinearDimension(cdrDimensionSlanted, ActiveDocument.CreateFreeSnapPoint(arrCoord(0), arrCoord(1)),  ActiveDocument.CreateFreeSnapPoint(arrCoord(2), arrCoord(3)), True, ArrSdvig(0), ArrSdvig(1), cdrDimensionStyleDecimal, 0, True, cdrDimensionUnitMM):

После задания всех параметров, сравниваю размер текста в размере и самого размера.
Вот пример для верхнего размера:
Код:
x = rasm.Dimension.TextShape.SizeWidth: Set r = rasm.Dimension: xx = r.Linear.Point2.PositionX - r.Linear.Point1.PositionX:
If xx < (x + 4) Then rasm.Dimension.Placement = cdrDimensionAboveLine:
Сравниваю x и xx (плюс 4мм), и если текст больше, то помещаю его над линией: rasm.Dimension.Placement = cdrDimensionAboveLine.
По аналогии делаю с боковыми и нижним.