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

izrukvruki

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

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

1653546074351.png


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

DukereD

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

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

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

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

izrukvruki

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

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

DukereD

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

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

eugeny

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

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

izrukvruki

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

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

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

eugeny

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

eugeny

15 лет на форуме
Сообщения
628
Реакции
145
вот, кстати, у меня после создания каждого размера добавлены три строки (возможно у вас и размер может слетать):
Код:
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 716
Реакции
286
вот, кстати, у меня после создания каждого размера добавлены три строки (возможно у вас и размер может слетать):
Код:
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 798
Реакции
1 667
опробуйте это ...
тут дополнительно заданы коэффициенты увеличения размера шрифта и отступа размерных линий - в зависимости от размера объекта
...

Код:
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 КБ · Просм.: 46
Последнее редактирование:
  • Спасибо
Реакции: mnemonix и izrukvruki

izrukvruki

Топикстартер
12 лет на форуме
Сообщения
1 716
Реакции
286
Код не мой, подправил числа, вставил несколько подсказанных здесь строчек.
Делал для знакомого, для наружки, объекты у него большие, ориентировался на 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 лет на форуме
Сообщения
628
Реакции
145
Я в своем модуле использовал один вариант 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.
По аналогии делаю с боковыми и нижним.
 

dastin

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

Итак - если объект меньше 10 мм - стрелки и толщина выносных линий менют размер
для совсем мелких - меньше 3 мм - текст ещё слегка уменьшается и получает обводку позади заполнения

1668886819484.png
1668887076392.png


+ инверсный вариан - для темных бэкграундов - работает с клавишей SHIFT

1668887348705.png
1668887384654.png


+ мульти размер - когда выделено несколько объектов - работает с клавишей CTRL - можно вкупе с +SHIFT
Тут надо заметить - если в выделение попадёт объект составной и несгруппированный - то ничего хорошего из этого не выйдет.
Потому макрос спросит (на всякий случай) - Понимаете, что вы хотите сделать? - Ну раз ДА, то и ...
Поводом для вопроса послужит число объектов более 10
Впрочем CTRL+Z никто пока не отменял.

1668887889276.png
1668888187250.png


и вот ещё что - собирал в 2019 - потому работать будет с Х7 и дальше
Для более ранних надо будет собирать заново - bas во 2-м архиве
 

Вложения

  • Size_Selection+3.zip
    12.6 КБ · Просм.: 14
  • Size_Selection+3_bas.zip
    1.4 КБ · Просм.: 9
  • Спасибо
Реакции: Molodchik и izrukvruki