[CDR 2022] Написать размеры выделенного.

C

Captive

Участник
Топикстартер
Сообщения
40
Реакции
0
Добрый день.
Помогите пожалуйста.
На данном форуме нашел макрос по расстановки размеров, хотел бы получить немного другой результат...
Вопрос заключается в следующим; каким образом установить полученные данные высоты и ширины в определенное место, а не в центр фигуры?
Во вложении желаемое место их расположения...
Заранее благодарен.

Пока макрос выглядит так....
Sub razmer_po_centru()
ActiveDocument.Unit = cdrMillimeter
Set OrigSelection = ActiveSelectionRange
For Each s2 In OrigSelection
Dim sh As ShapeRange, w#, h#, s As Shape, s1 As Shape
s2.GetSize w, h



Set s = ActiveDocument.ActiveLayer.CreateParagraphText(1, 1, 0, 0, "", cdrRussian, cdrCharSetRussian, , 12, cdrUndefined, , , cdrCenterAlignment) 'sozdanie textovogo okna
Set t = s.text
t.Story.InsertAfter (h & " mm ")
t.ConvertToArtistic
s.Rotate 90#
s.Fill.UniformColor.CopyAssign s2.Outline.Color
ActiveDocument.CreateShapeRangeFromArray(s2, s).AlignAndDistribute 0, 0, 0, 0, False, 2
s2.Ungroup



Set s1 = ActiveDocument.ActiveLayer.CreateParagraphText(1, 1, 0, 0, "", cdrRussian, cdrCharSetRussian, , 12, cdrUndefined, , , cdrCenterAlignment) 'sozdanie textovogo okna
Set t1 = s1.text
t1.Story.InsertAfter (w & " mm ")
t1.ConvertToArtistic
s1.Fill.UniformColor.CopyAssign s2.Outline.Color
ActiveDocument.CreateShapeRangeFromArray(s2, s, s1).AlignAndDistribute 3, 3, 0, 0, False, 2
s2.Ungroup



Next s2
End Sub
 

Вложения

  • 1.png
    1.png
    77.2 КБ · Просм.: 161
D

Drawer

Участник
Сообщения
1 811
Реакции
797
Кнопочка для кода
1664957070668.png
 
dastin

dastin

Некромант-любитель
12 лет на форуме
Сообщения
2 145
Реакции
2 043
Captive сказал(а):
желаемое место их расположения...
Нажмите, чтобы раскрыть...
числами в строках с Left и Bottom - регулируйте
выравнивание в данном случае - ИМХО ни к чему

Код: 
Sub razmer_ne_po_centru()
Dim sh As ShapeRange, w#, h#, s As Shape, s1 As Shape, s2 As Shape
ActiveDocument.Unit = cdrMillimeter
Set OrigSelection = ActiveSelectionRange
For Each s2 In OrigSelection

s2.GetSize w, h


Set s = ActiveDocument.ActiveLayer.CreateParagraphText(1, 1, 0, 0, "", cdrRussian, cdrCharSetRussian, , 12, cdrUndefined, , , cdrLeftAlignment) 'sozdanie textovogo okna
Set t = s.text
t.Story.InsertAfter (h & " mm ")
t.ConvertToArtistic
s.Rotate 90#
s.Fill.UniformColor.CopyAssign s2.Outline.Color
'ActiveDocument.CreateShapeRangeFromArray(s2, s).AlignAndDistribute 2, 2, 0, 0, False, 2
s2.Ungroup
s.LeftX = s2.LeftX + 5
s.BottomY = s2.BottomY + 10



Set s1 = ActiveDocument.ActiveLayer.CreateParagraphText(1, 1, 0, 0, "", cdrRussian, cdrCharSetRussian, , 12, cdrUndefined, , , cdrLefyAlignment) 'sozdanie textovogo okna
Set t1 = s1.text
t1.Story.InsertAfter (w & " mm ")
t1.ConvertToArtistic
s1.Fill.UniformColor.CopyAssign s2.Outline.Color
'ActiveDocument.CreateShapeRangeFromArray(s2, s, s1).AlignAndDistribute 2, 2, 0, 0, False, 2
s2.Ungroup
s1.LeftX = s2.LeftX + 10
s1.BottomY = s2.BottomY + 5




Next s2
End Sub
 
C

Captive

Участник
Топикстартер
Сообщения
40
Реакции
0
dastin сказал(а):
числами в строках с Left и Bottom - регулируйте
выравнивание в данном случае - ИМХО ни к чему

Код: 
Sub razmer_ne_po_centru()
Dim sh As ShapeRange, w#, h#, s As Shape, s1 As Shape, s2 As Shape
ActiveDocument.Unit = cdrMillimeter
Set OrigSelection = ActiveSelectionRange
For Each s2 In OrigSelection

s2.GetSize w, h


Set s = ActiveDocument.ActiveLayer.CreateParagraphText(1, 1, 0, 0, "", cdrRussian, cdrCharSetRussian, , 12, cdrUndefined, , , cdrLeftAlignment) 'sozdanie textovogo okna
Set t = s.text
t.Story.InsertAfter (h & " mm ")
t.ConvertToArtistic
s.Rotate 90#
s.Fill.UniformColor.CopyAssign s2.Outline.Color
'ActiveDocument.CreateShapeRangeFromArray(s2, s).AlignAndDistribute 2, 2, 0, 0, False, 2
s2.Ungroup
s.LeftX = s2.LeftX + 5
s.BottomY = s2.BottomY + 10



Set s1 = ActiveDocument.ActiveLayer.CreateParagraphText(1, 1, 0, 0, "", cdrRussian, cdrCharSetRussian, , 12, cdrUndefined, , , cdrLefyAlignment) 'sozdanie textovogo okna
Set t1 = s1.text
t1.Story.InsertAfter (w & " mm ")
t1.ConvertToArtistic
s1.Fill.UniformColor.CopyAssign s2.Outline.Color
'ActiveDocument.CreateShapeRangeFromArray(s2, s, s1).AlignAndDistribute 2, 2, 0, 0, False, 2
s2.Ungroup
s1.LeftX = s2.LeftX + 10
s1.BottomY = s2.BottomY + 5




Next s2
End Sub
Нажмите, чтобы раскрыть...
Огромное спасибо!
 
C

Captive

Участник
Топикстартер
Сообщения
40
Реакции
0
Просто при изменении данного значения у меня не чего не меняется текс как был 12 так и остается((
 
dastin

dastin

Некромант-любитель
12 лет на форуме
Сообщения
2 145
Реакции
2 043
Captive сказал(а):
не чего не меняется текс как был
Нажмите, чтобы раскрыть...
м-да ...
хорошо - давайте слегка расчешем граблями у висков
... чтобы не создавать параграф текст, а затем конвертировать его в аристик
и кое-что упростим

Код: 
Sub razmer_ne_po_centru()
Dim w#, h#, s As Shape, s1 As Shape, s2 As Shape, SZ As Single
ActiveDocument.Unit = cdrMillimeter
SZ = 24
Set OrigSelection = ActiveSelectionRange
For Each s2 In OrigSelection

s2.GetSize w, h

Set s = ActiveLayer.CreateArtisticText _
(s2.LeftX, s2.BottomY, h, , , "Tahoma", SZ, Alignment:=cdrLeftAlignment)
s.Text.Story = s.Text.Story & " mm "
s.Rotate 90#
s.Fill.UniformColor.CopyAssign s2.Outline.Color
s2.Ungroup
s.LeftX = s2.LeftX + SZ / 2
s.BottomY = s2.BottomY + SZ


    Set s1 = ActiveLayer.CreateArtisticText _
    (s2.LeftX, s2.BottomY, w, , , "Tahoma", SZ, Alignment:=cdrLeftAlignment)
s1.Text.Story = s1.Text.Story & " mm "
s1.Fill.UniformColor.CopyAssign s2.Outline.Color
s2.Ungroup
s1.LeftX = s2.LeftX + SZ
s1.BottomY = s2.BottomY + SZ / 2

Next s2
End Sub

теперь можно просто менять переменную SZ - в одном месте
SZ = ??
надписи будут менять размер и по мере его увеличения отодвигаться от края s2 и друг от друга
 
  • Спасибо
Реакции: Captive
C

Captive

Участник
Топикстартер
Сообщения
40
Реакции
0
dastin сказал(а):
м-да ...
хорошо - давайте слегка расчешем граблями у висков
... чтобы не создавать параграф текст, а затем конвертировать его в аристик
и кое-что упростим

Код: 
Sub razmer_ne_po_centru()
Dim w#, h#, s As Shape, s1 As Shape, s2 As Shape, SZ As Single
ActiveDocument.Unit = cdrMillimeter
SZ = 24
Set OrigSelection = ActiveSelectionRange
For Each s2 In OrigSelection

s2.GetSize w, h

Set s = ActiveLayer.CreateArtisticText _
(s2.LeftX, s2.BottomY, h, , , "Tahoma", SZ, Alignment:=cdrLeftAlignment)
s.Text.Story = s.Text.Story & " mm "
s.Rotate 90#
s.Fill.UniformColor.CopyAssign s2.Outline.Color
s2.Ungroup
s.LeftX = s2.LeftX + SZ / 2
s.BottomY = s2.BottomY + SZ


    Set s1 = ActiveLayer.CreateArtisticText _
    (s2.LeftX, s2.BottomY, w, , , "Tahoma", SZ, Alignment:=cdrLeftAlignment)
s1.Text.Story = s1.Text.Story & " mm "
s1.Fill.UniformColor.CopyAssign s2.Outline.Color
s2.Ungroup
s1.LeftX = s2.LeftX + SZ
s1.BottomY = s2.BottomY + SZ / 2

Next s2
End Sub

теперь можно просто менять переменную SZ - в одном месте
SZ = ??
надписи будут менять размер и по мере его увеличения отодвигаться от края s2 и друг от друга
Нажмите, чтобы раскрыть...
Отлично! Спасибо огромное!!!!
 
C

Captive

Участник
Топикстартер
Сообщения
40
Реакции
0
Теперь проблемка только в маленьких деталей....
А можно ли сделать так чтобы на больших деталей выполнялось все как сейчас а на узких деталей прописывалось в строчку?
 

Вложения

  • 2.png
    2.png
    81.5 КБ · Просм.: 134
C

Captive

Участник
Топикстартер
Сообщения
40
Реакции
0
Извините за назойливость....
 
dastin

dastin

Некромант-любитель
12 лет на форуме
Сообщения
2 145
Реакции
2 043
Captive сказал(а):
а на узких деталей прописывалось в строчку?
Нажмите, чтобы раскрыть...
добавьте условие -
если w>h*3 то
поворот вертикального текста не делать
и размещать его через 5мм после правого края горизонтального текста
и наоборот - скорее всего вам тоже захочется - если w3<h - поворачивать оба ... ну и т.д
 
C

Captive

Участник
Топикстартер
Сообщения
40
Реакции
0
dastin сказал(а):
добавьте условие -
если w>h*3 то
поворот вертикального текста не делать
и размещать его через 5мм после правого края горизонтального текста
и наоборот - скорее всего вам тоже захочется - если w3<h - поворачивать оба ... ну и т.д
Нажмите, чтобы раскрыть...
А как прописать отмену выполнения поворота?
Простите мне мою необразованность....
 
dastin

dastin

Некромант-любитель
12 лет на форуме
Сообщения
2 145
Реакции
2 043
после строки
s2.GetSize w, h
...
If w>h*3 = False Then
s.Rotate 90# ' если НЕширокая то поврачиваем
Else ' иначе
... тут что ещё
End If
 
Для ответа нужно войти/зарегистрироваться
Верх Низ