Re: текс определенной гартнитуры в кривые

Написал AsdPiton в 19/09/2008 18:00:43

вот тебе макрос - выделяет вообще весь текст в файле... может поможет...
Sub textinfo() ' ========================================================================================
Dim s As Shape, p As Page, sr As ShapeRange, doc As Document, dd As Boolean, i#
On Error Resume Next
Set doc = ActiveDocument
dd = doc.Dirty
doc.ClearSelection
Set p = ActivePage
Set sr = p.FindShapes(, cdrTextShape, True)
If sr.Count > 0 Then sr.CreateSelection: GoTo found
If doc.Pages.Count = 1 Then Exit Sub

For Each p In doc.Pages
Set sr = p.FindShapes(, cdrTextShape, True)
If sr.Count > 0 Then sr.CreateSelection: GoTo found
Set s = p.FindShape(, cdrTextShape)
If Not s Is Nothing Then s.Selected = True: GoTo found
Next
doc.Dirty = dd
Exit Sub
found:
p.Activate
Set sr = doc.SelectableShapes.All
sr.RemoveRange doc.Pages(0).Layers("Guides".shapes.All
With ActiveSelection
i = IIf(.SizeWidth > .SizeHeight, .SizeWidth / sr.SizeWidth, .SizeHeight / sr.SizeHeight)
End With
With CorelDRAW.ActiveWindow.ActiveView
.ToFitSelection
If Abs(i - 1) > 0.2 Then _
.SetViewPoint .OriginX, .OriginY, .Zoom * IIf(i > 0.2, i, 0.2)
End With
doc.Dirty = dd
End Sub