Sub bitmapsizer()
Static sz$
Dim sh As Shape, sr As ShapeRange, sr2 As ShapeRange, s$, x#, y#, pg As Page, bAll%, tPClip&
On Error Resume Next
s = Trim$(InputBox(Replace("SizeX SizeY [AP]|0 = proportional|A = all pages|P = check powerclips)", "|", vbCr & vbTab), , sz))
If Len(s) = 0 Then Exit Sub
x = Left$(s, InStr(s, " ")): y = Split(LTrim$(Mid$(s, InStr(s, " "))), " ")(0)
bAll = InStr(1, s, "a", vbTextCompare) <> 0
tPClip = IIf(InStr(1, s, "p", vbTextCompare) <> 0, 0, cdrBitmapShape)
If err.Number Or x < 0 Or y < 0 Then MsgBox "Bad number", vbExclamation: Exit Sub
sz = s
Set sr = ActiveSelection.Shapes.FindShapes(, tPClip)
If tPClip = 0 Then Set sr2 = New ShapeRange
ActiveDocument.Unit = cdrMillimeter
ActiveDocument.BeginCommandGroup "resize bitmaps"
ActiveDocument.PreserveSelection = False: Optimization = True: EventsEnabled = 0
For Each pg In ActiveDocument.Pages
If bAll Or pg Is ActivePage Then
If bAll Or sr.Count = 0 Then Set sr = pg.FindShapes(, tPClip)
Do
For Each sh In sr
If sh.Type = cdrBitmapShape Then
If x = 0 Then
If Abs(sh.SizeHeight - y) > 0.000001 Then sh.SetSize sh.SizeWidth * y / sh.SizeHeight, y
Else
If Abs(sh.SizeWidth - x) > 0.000001 Then sh.SetSize x, sh.SizeHeight * x / sh.SizeWidth
End If
End If
If tPClip = 0 Then _
If Not sh.PowerClip Is Nothing Then sr2.AddRange sh.PowerClip.Shapes.FindShapes
Next
If tPClip <> 0 Then Exit Do
sr.RemoveAll: sr.AddRange sr2: sr2.RemoveAll
Loop Until sr.Count = 0
End If
Next
ActiveDocument.PreserveSelection = True: Optimization = 0: EventsEnabled = True
ActiveDocument.EndCommandGroup
ActiveDocument.ClearSelection
CorelScript.RedrawScreen
Refresh
End Sub
