[SIZE=2]Const defaultTextToFind As String = "?"
Dim textToFind As String
Dim findedShRange As New ShapeRange
Dim findedShIndex As Long
Sub [B]Zoom[/B](magn As Double, relative As Boolean)
Dim view As ActiveView
Dim VPointX As Double
Dim VPointY As Double
Set view = Application.ActiveWindow.ActiveView
VPointX = view.OriginX
VPointY = view.OriginY
If (relative) Then
view.Zoom = view.Zoom * magn
Else
view.Zoom = magn
End If
If Not ActiveShape Is Nothing Then
view.SetViewPoint ActiveShape.PositionX + ActiveShape.SizeWidth / 2, ActiveShape.PositionY - ActiveShape.SizeHeight / 2
Else
view.SetViewPoint VPointX, VPointY
End If
End Sub
Sub [B]ZoomToTextSelected[/B]()
Dim unit As cdrUnit
Const rel As Double = 15
unit = ActiveDocument.unit
ActiveDocument.unit = cdrPoint
Zoom (100 / rel) * (ActivePage.SizeHeight / ActiveShape.Text.Story.Size), False
ActiveDocument.unit = unit
End Sub
Function [B]FindText[/B]() As Boolean
Dim sh As shape
Dim shRange As ShapeRange
Dim selectedShRange As ShapeRange
If (textToFind = "") Then
textToFind = defaultTextToFind
End If
FindText = True
textToFind = InputBox("Введите текст для поиска", "Поиск текста", textToFind)
If Len(textToFind) = 0 Then
findedShIndex = 0
FindText = False
Exit Function
End If
'На время выполнения поиска выделение снимается, т.к. поиск при наличии выделения втрое замедляется
Set selectedShRange = ActiveSelectionRange
ActiveSelectionRange.RemoveFromSelection
findedShRange.RemoveAll
Set shRange = ActivePage.FindShapes(, cdrTextShape)
For Each sh In shRange
If sh.Text.Find(textToFind, False) > 0 Then
findedShRange.Add sh
End If
Next sh
findedShIndex = 0
If shRange.count > 0 Then findedShIndex = 1
'Восстановление выделения по окончании поиска
selectedShRange.CreateSelection
End Function
Sub [B]FindNPText[/B](dir)
Dim singleMsgNeed As Boolean
If (findedShIndex = 0) Then
FindNewText
Exit Sub
End If
singleMsgNeed = True
If dir Then
If findedShRange.count > 1 Then
findedShIndex = findedShIndex + 1
If (findedShIndex > findedShRange.count) Then findedShIndex = 1
singleMsgNeed = False
End If
Else
If findedShRange.count > 1 Then
findedShIndex = findedShIndex - 1
If (findedShIndex < 1) Then findedShIndex = findedShRange.count
singleMsgNeed = False
End If
End If
If singleMsgNeed Then
MsgBox "Найден только один текстовый объект," + vbCrLf + "содержащий фрагмент '" + textToFind + "'."
End If
'выделение
ActiveSelectionRange.RemoveFromSelection
On Error GoTo DelMsg
findedShRange(findedShIndex).Selected = True
On Error GoTo 0
'масштабирование
ZoomToTextSelected
Exit Sub
DelMsg: MsgBox findedShIndex & "-й текстовый объект," + vbCrLf + "содержащий фрагмент '" + textToFind + "', был удалён."
End Sub
Sub [COLOR=Blue]FindNewText[/COLOR]()
Dim actualSearch As Boolean
actualSearch = FindText
If Not actualSearch Then Exit Sub
If (findedShRange.count = 0) Then
MsgBox "Текст '" + textToFind + "' не найден." + vbCrLf + "Возможно, искомый текст находится на невидимом слое."
findedShIndex = 0
Else
MsgBox "Найдено текстовых объектов: " & findedShRange.count & vbCrLf + "Искомый фрагмент: '" + textToFind + "'."
findedShIndex = 1
End If
'выделение
ActiveSelectionRange.RemoveFromSelection
findedShRange(1).Selected = True
'масштабирование
ZoomToTextSelected
End Sub
Sub [COLOR=Blue]FindNextText[/COLOR]()
FindNPText (True)
End Sub
Sub [COLOR=Blue]FindPreviousText[/COLOR]()
FindNPText (False)
End Sub
