А если шрфтов несколько тысяч...
Гыыы... Как представил... 
Пробовал. Не только ручками.
Я уже описал, чего я хочу. Этот вариант даже не рассматривается.
Это и правда клево. Не верю, что только мне в голову пришла такая замечательная мысль.Dim Schief сказал(а):
Скрипт написать - дело пары секунд, даже и делать не стану, настолько просто. Другой вопрос - вам уже сказали: а что если несколько тысяч шрифтов в системе? На страницу такое точно не влезет, да и надо ли?
Если 1000 шрифтов ручками, то это пугает. Если автоматом - то самый раз. Помимо страницы есть просто рабочее поле. В конце концов можно таблицей выводить, 20*30 например. Если не сложно, напишите скриптик. Многим легче станет.
Мне нужен весь список из которого я сделаю вручную более узкую выборку.
Все просто. Я иногда делаю логотипы. Мне очень тяжело вручную перебирать шрифты.
Например делаю я перекрывание каких-то букв. Одна левее, другая правее. Одна выше, другая ниже. Одна курсивная, другая жирная. Одна крупная, другая мелкая. Не дают шрифтовые менеджеры такой роскоши.
Тогда это совсем другая задача. Получается, вы рисуете комбинацию из нескольких букв или слов, а программа должна вам эту комбинацию разными шрифтами показывать? Это задача гораздо сложнее (хотя в принципе решаемая тоже) и не совсем корректная даже, поскольку у некоторых шрифтов, к примеру, могут отсутствовать жирные или курсивные начертания.
Да, то есть я выделяю объекты, запускаю скрипт и идет клонирование объектов чуть ниже с изменением шрифтов. В словосочетании "выделяю объекты" я имел в виду текстовые объекты, хотя не плохо бы и нетекстовые. Но это не так важно сейчас.
Я потом вручную буду все модерировать, поэтому не страшно.
Ну несколько тысяч - это реал перебор. У меня такого не будет больше. И сам ничего найти не можешь и комп загибается... Вряд ли у кого-то несколько тысяч.
Sub ShowFonts()
ActiveDocument.BeginCommandGroup "ShowFonts"
ActiveDocument.Unit = cdrMillimeter
Dim myIndexNumber As Integer
Dim myWrd As TextRange
Dim mySh As Shape
Dim mySelR, mySelR1, mySelR2, myDubl As ShapeRange
Dim DeltaX As Integer
Dim DeltaY As Integer
Dim XCount As Integer
Dim YCount As Integer
Dim PageWidth As Integer
Dim PageHeight As Integer
Dim PageCount As Integer
Dim FontCount As Integer
Dim CurrentFont As Integer
Dim p1 As Page
Set mySelR = ActiveSelectionRange
DeltaX = mySelR.SizeWidth * 2
DeltaY = mySelR.SizeHeight * 2
PageWidth = Abs(ActivePage.LeftX - ActivePage.RightX)
PageHeight = Abs(ActivePage.TopY - ActivePage.BottomY)
FontCount = Application.FontList.Count
CurrentFont = 1
XCount = Abs(ActivePage.RightX - mySelR.PositionX) / DeltaX - 1
YCount = Abs(ActivePage.BottomY - mySelR.PositionY) / DeltaY - 1
PageCount = FontCount / (XCount * YCount - 1)
mySelR.Copy
For k = 1 To PageCount Step 1
If k > 1 Then
p1.ActiveLayer.Paste
Set mySelR = ActiveSelectionRange
End If
For j = 1 To XCount Step 1
Set mySelR1 = mySelR
For i = 1 To YCount Step 1
Set myDubl = mySelR1.StepAndRepeat(1, 0, -DeltaY, cdrModeNoOffset, cdrRight, cdrModeOffset, cdrDown)
If Not myDubl.Shapes.FindShapes(Type:=cdrTextShape).Count = 0 Then
For Each sh In myDubl.Shapes.FindShapes(Type:=cdrTextShape)
For Each myWrd In sh.Text.Story.Words
myWrd.Font = Application.FontList(CurrentFont)
Next
Next
Else
MsgBox "There are no texts!"
Exit Sub
End If
If CurrentFont < FontCount Then
CurrentFont = CurrentFont + 1
Else
Exit Sub
End If
Set mySelR1 = myDubl
Next i
If j < XCount Then
Set mySelR2 = mySelR.StepAndRepeat(1, DeltaX, 0, cdrModeOffset, cdrRight, cdrModeNoOffset, cdrDown)
If Not mySelR2.Shapes.FindShapes(Type:=cdrTextShape).Count = 0 Then
For Each sh In mySelR2.Shapes.FindShapes(Type:=cdrTextShape)
For Each myWrd In sh.Text.Story.Words
myWrd.Font = Application.FontList(CurrentFont)
Next
Next
Else
MsgBox "There are no texts!"
Exit Sub
End If
If CurrentFont < FontCount Then
CurrentFont = CurrentFont + 1
Else
Exit Sub
End If
Set mySelR = mySelR2
End If
Next j
If k < PageCount Then
Set p1 = ActiveDocument.InsertPagesEx(1, False, ActivePage.Index, PageWidth, PageHeight)
End If
Next k
ActiveDocument.EndCommandGroup
End Sub