Домашняя страница Undo Do Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Подмена шрифтов - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, китин  
Мир MS Excel » Вопросы и решения » Excel и другие приложения » Word » Подмена шрифтов (Word)
Подмена шрифтов
368800 Дата: Воскресенье, 27.04.2014, 13:41 | Сообщение № 1
Группа: Пользователи
Ранг: Участник
Сообщений: 63
Репутация: 0 ±
Замечаний: 0% ±

2010
Помогите пожалуйста со скриптом для Word. Вот посоветовали скрипт для замены шрифтов в разброс но почему то когда запускаю скрипт то Word зависает. Суть скрипта подогнать конспекты под рукописный текст путем замены некоторых букв другими шрифтами.

[vba]
Код
Sub RandomFont()
Application.ScreenUpdating = False

Set objDoc = ActiveDocument
Set objRandom = CreateObject("System.Random")

Set objRange = objDoc.Range()
Set colCharacters = objRange.Characters

For Each strCharacter In colCharacters
'strCharacter.Font.Reset
strCharacter.Font.Scaling = 100 + objRandom.Next_2(-50, 50) / 8 'разброс ширины шрифта
strCharacter.Font.Position = objRandom.Next_2(-200, 300) / 700 'разброс позиции относительно базовой линии
strCharacter.Font.Size = strCharacter.Font.Size + objRandom.Next_2(-300, 400) / 400 'разброс размеров шрифта
strCharacter.Font.Kerning = 12 + objRandom.Next_2(-10, 40) / 5 'разброс кернинга
Select Case objRandom.Next_2(1, 5) 'рандомный шрифт
Case 1
strCharacter.Font.Name = "ZimM-1"
Case 2
strCharacter.Font.Name = "ZimM-2"
Case 3
strCharacter.Font.Name = "ZimM-3"
Case 4
strCharacter.Font.Name = "ZimM-4"
End Select
Next

Application.ScreenUpdating = True
End Sub
[/vba]
К сообщению приложен файл: 0743619.doc (28.5 Kb)


Сообщение отредактировал Serge_007 - Воскресенье, 27.04.2014, 16:39
 
Ответить
СообщениеПомогите пожалуйста со скриптом для Word. Вот посоветовали скрипт для замены шрифтов в разброс но почему то когда запускаю скрипт то Word зависает. Суть скрипта подогнать конспекты под рукописный текст путем замены некоторых букв другими шрифтами.

[vba]
Код
Sub RandomFont()
Application.ScreenUpdating = False

Set objDoc = ActiveDocument
Set objRandom = CreateObject("System.Random")

Set objRange = objDoc.Range()
Set colCharacters = objRange.Characters

For Each strCharacter In colCharacters
'strCharacter.Font.Reset
strCharacter.Font.Scaling = 100 + objRandom.Next_2(-50, 50) / 8 'разброс ширины шрифта
strCharacter.Font.Position = objRandom.Next_2(-200, 300) / 700 'разброс позиции относительно базовой линии
strCharacter.Font.Size = strCharacter.Font.Size + objRandom.Next_2(-300, 400) / 400 'разброс размеров шрифта
strCharacter.Font.Kerning = 12 + objRandom.Next_2(-10, 40) / 5 'разброс кернинга
Select Case objRandom.Next_2(1, 5) 'рандомный шрифт
Case 1
strCharacter.Font.Name = "ZimM-1"
Case 2
strCharacter.Font.Name = "ZimM-2"
Case 3
strCharacter.Font.Name = "ZimM-3"
Case 4
strCharacter.Font.Name = "ZimM-4"
End Select
Next

Application.ScreenUpdating = True
End Sub
[/vba]
Автор - 368800
Дата добавления - 27.04.2014 в 13:41
Alex_ST Дата: Вторник, 29.04.2014, 17:25 | Сообщение № 2
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3209
Репутация: 609 ±
Замечаний: 0% ±

2003
Подключите библиотеку System (Tools ->References найдите в списке и поставить гульку на System)
Но жутко тормозной код.
Зачем нужно использовать объект "System.Random" я понятия не имею. И искать его синтаксис и свойства - ни какого желания.
Но я сильно подозреваю, что он мало чем отличается от стандартной встроенной в VBA функции Rnd
Вот так - то же самое, но тоже циклится цикл почему-то:[vba]
Код
Sub RandomFont2()
     Dim xChar
'   Application.ScreenUpdating = False

     For Each xChar In ActiveDocument.Range.Characters
'      xChar.Font.Reset
'      xChar.Font.Scaling = 100 + fRnd(-50, 50) / 8   'разброс ширины шрифта
'      xChar.Font.Position = fRnd(-200, 300) / 700   'разброс позиции относительно базовой линии
'      xChar.Font.Size = xChar.Font.Size + fRnd(-300, 400) / 400   'разброс размеров шрифта
'      xChar.Font.Kerning = 12 + fRnd(-10, 40) / 5   'разброс кернинга
        Select Case fRnd(1, 5)   'рандомный шрифт
           Case 1
              xChar.Font.Name = "Arial"
           Case 2
              xChar.Font.Name = "Calibri"
           Case 3
              xChar.Font.Name = "Times New Roman"
           Case 4
              xChar.Font.Name = "Monotype Corsiva"
        End Select
     Next

'   Application.ScreenUpdating = True
End Sub

Function fRnd%(iMin%, iMax%)
fRnd = Int((iMax * Rnd) + iMin)
End Function
[/vba]надо разбираться


С уважением,
Алексей
MS Excel 2003 - the best!!!

Сообщение отредактировал Alex_ST - Вторник, 29.04.2014, 20:38
 
Ответить
СообщениеПодключите библиотеку System (Tools ->References найдите в списке и поставить гульку на System)
Но жутко тормозной код.
Зачем нужно использовать объект "System.Random" я понятия не имею. И искать его синтаксис и свойства - ни какого желания.
Но я сильно подозреваю, что он мало чем отличается от стандартной встроенной в VBA функции Rnd
Вот так - то же самое, но тоже циклится цикл почему-то:[vba]
Код
Sub RandomFont2()
     Dim xChar
'   Application.ScreenUpdating = False

     For Each xChar In ActiveDocument.Range.Characters
'      xChar.Font.Reset
'      xChar.Font.Scaling = 100 + fRnd(-50, 50) / 8   'разброс ширины шрифта
'      xChar.Font.Position = fRnd(-200, 300) / 700   'разброс позиции относительно базовой линии
'      xChar.Font.Size = xChar.Font.Size + fRnd(-300, 400) / 400   'разброс размеров шрифта
'      xChar.Font.Kerning = 12 + fRnd(-10, 40) / 5   'разброс кернинга
        Select Case fRnd(1, 5)   'рандомный шрифт
           Case 1
              xChar.Font.Name = "Arial"
           Case 2
              xChar.Font.Name = "Calibri"
           Case 3
              xChar.Font.Name = "Times New Roman"
           Case 4
              xChar.Font.Name = "Monotype Corsiva"
        End Select
     Next

'   Application.ScreenUpdating = True
End Sub

Function fRnd%(iMin%, iMax%)
fRnd = Int((iMax * Rnd) + iMin)
End Function
[/vba]надо разбираться
Автор - Alex_ST
Дата добавления - 29.04.2014 в 17:25
Alex_ST Дата: Вторник, 29.04.2014, 21:03 | Сообщение № 3
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3209
Репутация: 609 ±
Замечаний: 0% ±

2003
Дома протестировал. Ничего не циклится. Просто объект .Font почему-то жутко тормозит даже при самых простых операциях.
Для примера ограничил область действия макроса только выделенным текстом.
Но всё равно даже при выделении всего пары строк ждать приходится больше минуты.[vba]
Код
Sub RandomFont()
       Dim xChar As Range, Start As Single
       'Start = Timer
       Application.ScreenUpdating = False
       For Each xChar In Selection.Range.Characters
           'xChar.Font.Reset
           xChar.Font.Scaling = 100 + fRnd(-50, 50) / 8   'разброс ширины шрифта
           xChar.Font.Position = fRnd(-200, 300) / 700   'разброс позиции относительно базовой линии
           xChar.Font.Size = xChar.Font.Size + fRnd(-300, 400) / 400   'разброс размеров шрифта
           xChar.Font.Kerning = 12 + fRnd(-10, 40) / 5   'разброс кернинга
           xChar.Font.Name = Choose(fRnd(1, 4), "Arial", "Calibri", "Times New Roman", "Monotype Corsiva")    'рандомный шрифт
       Next
       'Debug.Print Timer - Start
       Application.ScreenUpdating = True
End Sub
[/vba]


С уважением,
Алексей
MS Excel 2003 - the best!!!

Сообщение отредактировал Alex_ST - Вторник, 29.04.2014, 21:14
 
Ответить
СообщениеДома протестировал. Ничего не циклится. Просто объект .Font почему-то жутко тормозит даже при самых простых операциях.
Для примера ограничил область действия макроса только выделенным текстом.
Но всё равно даже при выделении всего пары строк ждать приходится больше минуты.[vba]
Код
Sub RandomFont()
       Dim xChar As Range, Start As Single
       'Start = Timer
       Application.ScreenUpdating = False
       For Each xChar In Selection.Range.Characters
           'xChar.Font.Reset
           xChar.Font.Scaling = 100 + fRnd(-50, 50) / 8   'разброс ширины шрифта
           xChar.Font.Position = fRnd(-200, 300) / 700   'разброс позиции относительно базовой линии
           xChar.Font.Size = xChar.Font.Size + fRnd(-300, 400) / 400   'разброс размеров шрифта
           xChar.Font.Kerning = 12 + fRnd(-10, 40) / 5   'разброс кернинга
           xChar.Font.Name = Choose(fRnd(1, 4), "Arial", "Calibri", "Times New Roman", "Monotype Corsiva")    'рандомный шрифт
       Next
       'Debug.Print Timer - Start
       Application.ScreenUpdating = True
End Sub
[/vba]
Автор - Alex_ST
Дата добавления - 29.04.2014 в 21:03
Мир MS Excel » Вопросы и решения » Excel и другие приложения » Word » Подмена шрифтов (Word)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!