Sub Test
Dim i As Long
For i = 1 To Val(stepen)
ActiveDocument.Range.Font.Shrink
Next i
End Sub
Перебор символов в Word
Здравствуйте.
У меня возникла задача такого рода. Есть документ Ворд. в нём текст набран шрифтами разного размера. Мне нужно уменьшить размер каждого символа по формуле:
новыйразмер=старыйразмер-числопунктовуменьшения
Я накидал что-то вроде
For i = 1 To ActiveDocument.Characters.Count
ActiveDocument.Characters(i).Select
If Selection.Font.Size > Val(stepen) Then
Selection.Font.Size = Selection.Font.Size - Val(stepen)
Label4.Caption = Str$(i)
UserForm1.Repaint
End If
Next i
Но работает жутко долго. Есть ли другой способ?
Заранее спасибо.
У меня возникла задача такого рода. Есть документ Ворд. в нём текст набран шрифтами разного размера. Мне нужно уменьшить размер каждого символа по формуле:
новыйразмер=старыйразмер-числопунктовуменьшения
Я накидал что-то вроде
For i = 1 To ActiveDocument.Characters.Count
ActiveDocument.Characters(i).Select
If Selection.Font.Size > Val(stepen) Then
Selection.Font.Size = Selection.Font.Size - Val(stepen)
Label4.Caption = Str$(i)
UserForm1.Repaint
End If
Next i
Но работает жутко долго. Есть ли другой способ?
Заранее спасибо.
Цитата:
Originally posted by quant
Здравствуйте.
У меня возникла задача такого рода. Есть документ Ворд. в нём текст набран шрифтами разного размера. Мне нужно уменьшить размер каждого символа по формуле:
новыйразмер=старыйразмер-числопунктовуменьшения
Я накидал что-то вроде
For i = 1 To ActiveDocument.Characters.Count
ActiveDocument.Characters(i).Select
If Selection.Font.Size > Val(stepen) Then
Selection.Font.Size = Selection.Font.Size - Val(stepen)
Label4.Caption = Str$(i)
UserForm1.Repaint
End If
Next i
Но работает жутко долго. Есть ли другой способ?
Заранее спасибо.
Здравствуйте.
У меня возникла задача такого рода. Есть документ Ворд. в нём текст набран шрифтами разного размера. Мне нужно уменьшить размер каждого символа по формуле:
новыйразмер=старыйразмер-числопунктовуменьшения
Я накидал что-то вроде
For i = 1 To ActiveDocument.Characters.Count
ActiveDocument.Characters(i).Select
If Selection.Font.Size > Val(stepen) Then
Selection.Font.Size = Selection.Font.Size - Val(stepen)
Label4.Caption = Str$(i)
UserForm1.Repaint
End If
Next i
Но работает жутко долго. Есть ли другой способ?
Заранее спасибо.
Главный тормоз - прерывания внутри цикла (repaint...).
лучше вставь вначале и в конце
Application.ScreenUpdating
И еще - цикл For Each работает быстрее
В общем рекомендую примерно так:
Application.ScreenUpdating = False
For Each c In ActiveDocument.Characters
If c.Font.Size > Val(stepen) Then
c.Font.Size = c.Font.Size - Val(stepen)
End If
Next c
Label4.Caption = Str$(i)
Application.ScreenUpdating = True
Попробовал. Действительно лучше. Спасибо за совет. А может есть в Ворде готовая такая штука. Пропорциональное уменьшение размера символов?
Цитата:
Originally posted by quant
Попробовал. Действительно лучше. Спасибо за совет. А может есть в Ворде готовая такая штука. Пропорциональное уменьшение размера символов?
Попробовал. Действительно лучше. Спасибо за совет. А может есть в Ворде готовая такая штука. Пропорциональное уменьшение размера символов?
Код:
Обратно - Grow.