Find all bitmaps and resample

Hi,

Is there any VBA code for CorelDRAW 12 to find all bitmaps. Then have a dialogue box asking what resolution you wish to resample them to and what mode you wish to change them to.



Many thanks,

I am working on it. I will let you know when it will be ready.

Regards

Michael Cervantes
MC Design Studio

Thanks,

Looking forward to your reply.

[wOxxOm]

while you wait, take a look at this macro which I use frequently
it is smart enough to not resample if difference is less than 20% (1.2 in code)

Sub downsampleBitmaps()
   Dim s As Shape, ss As New ShapeRange, p As Page, pp As Pages, b As Bitmap, _
       dpi As Single, step As Single, i&, w As Double, h As Double, _
       x As Double, y As Double, stat As AppStatus
   dpi = InputBox("Resolution DPI", "resample all bitmaps", 300): dpi = Val(dpi)
   If dpi <= 0 Or dpi > 9999 Then Exit Sub
   ActiveDocument.PreserveSelection = False
   If ActiveSelectionRange.Count > 0 Then
      Set ss = ActiveDocument.Selection.shapes.FindShapes(, cdrBitmapShape)
   Else
      Set pp = ActiveDocument.Pages: step = 100 / pp.Count
      For Each p In pp
         ss.AddRange p.FindShapes(, cdrBitmapShape)
      Next p
   End If
   If ss.Count = 0 Then Exit Sub
   i = 0: Set stat = Application.Status: stat.BeginProgress CanAbort:=True
   For Each s In ss
      i = i + 1: stat.Progress = i / ss.Count * 100: If stat.Aborted Then Exit For
      s.Selected = True
      If s.Effects.Count = 0 Then
         Set b = s.Bitmap
         If (b.ResolutionX / dpi > 1.2) Or (b.ResolutionY / dpi > 1.2) Then
            On Error GoTo err
            ActiveDocument.BeginCommandGroup
            w = s.SizeWidth: h = s.SizeHeight: x = s.PositionX: y = s.PositionY
            b.Resample Round(dpi / b.ResolutionX * b.SizeWidth + 0.49999), Round(dpi / b.ResolutionY * b.SizeHeight + 0.49999), True, dpi, dpi
            s.SizeWidth = w: s.SizeHeight = h: s.PositionX = x: s.PositionY = y
            ActiveWindow.Refresh
err:        ActiveDocument.EndCommandGroup
         End If
      End If
   Next s
   stat.EndProgress
End Sub

Thanks wOxxOm for code.

But what will I need to change if I want it to resample all bitmaps even if the difference is less than 20%?

Many thanks,

[wOxxOm]

Edit: see code below

Hi wOxxOm,

Thanks for the code. But I get an error when it runs. It seems to process alot of the bitmaps but stops with an error saying "Run-time error '11': Division by zero." I click on debug and it takes me to the line I have marked in the code below:

Sub downsampleBitmaps()
   Dim s As Shape, ss As New ShapeRange, p As Page, pp As Pages, b As Bitmap, _
       dpi As Single, step As Single, i&, w As Double, h As Double, _
       x As Double, y As Double, stat As AppStatus
   dpi = InputBox("Resolution DPI", "resample all bitmaps", 300): dpi = Val(dpi)
   If dpi <= 0 Or dpi > 9999 Then Exit Sub
   ActiveDocument.PreserveSelection = False
   If ActiveSelectionRange.Count > 0 Then
      Set ss = ActiveDocument.Selection.Shapes.FindShapes(, cdrBitmapShape)
   Else
      Set pp = ActiveDocument.Pages: step = 100 / pp.Count
      For Each p In pp
         ss.AddRange p.FindShapes(, cdrBitmapShape)
      Next p
   End If
   If ss.Count = 0 Then Exit Sub
   i = 0: Set stat = Application.Status: stat.BeginProgress CanAbort:=True
   For Each s In ss
      i = i + 1: stat.Progress = i / ss.Count * 100: If stat.Aborted Then Exit For
      s.Selected = True
      If s.Effects.Count = 0 Then
         Set b = s.Bitmap
            On Error GoTo err
            ActiveDocument.BeginCommandGroup
            w = s.SizeWidth: h = s.SizeHeight: x = s.PositionX: y = s.PositionY
            
This line below is where it stops on.
-------------------------------------------------------------------------- 
            b.Resample Round(dpi / b.ResolutionX * b.SizeWidth + 0.49999), Round(dpi / b.ResolutionY * b.SizeHeight + 0.49999), True, dpi, dpi
--------------------------------------------------------------------------
            s.SizeWidth = w: s.SizeHeight = h: s.PositionX = x: s.PositionY = y
            ActiveWindow.Refresh
err:        ActiveDocument.EndCommandGroup
      End If
   Next s
   stat.EndProgress
End Sub

I would send you the CorelDRAW file for you to see the problem yourself but the file is 319KB which is too big to allow me to attach it to this forum.

Many thanks,

[wOxxOm]

Originally Posted by keytecstaff

Hi wOxxOm,

Thanks for the code. But I get an error when it runs. It seems to process alot of the bitmaps but stops with an error saying "Run-time error '11': Division by zero." I click on debug and it takes me to the line I have marked in the code below:

You've got bitmap with zero reosultion, congratulation! I've never seen this before, feel free to surprise me and send this file to woxxom (at) gmail (dot) com ;-)

updated code that will show warning IN THE END if any bad bitmap was encountered. Bads will be selected in that case:

Sub downsampleBitmaps() ' =================================================================================================
   Dim s As Shape, ss As New ShapeRange, p As Page, pp As Pages, b As Bitmap, _
       dpi As Single, step As Single, i&, w As Double, h As Double, _
       x As Double, y As Double, srBad As New ShapeRange
   dpi = InputBox("Resolution DPI", "resample all bitmaps", 300): dpi = Val(dpi)
   If dpi <= 0 Or dpi > 9999 Then Exit Sub
   ActiveDocument.PreserveSelection = False
   If ActiveSelectionRange.Count > 0 Then
      Set ss = ActiveDocument.Selection.shapes.FindShapes(, cdrBitmapShape)
   Else
      Set pp = ActiveDocument.Pages: step = 100 / pp.Count
      For Each p In pp
         ss.AddRange p.FindShapes(, cdrBitmapShape)
      Next p
   End If
   If ss.Count = 0 Then Exit Sub
   i = 0: Set stat = Application.Status: stat.BeginProgress CanAbort:=True
   For Each s In ss
      i = i + 1: stat.Progress = i / ss.Count * 100: If stat.Aborted Then Exit For
      's.Selected = True
      If s.Effects.Count = 0 Then
         Set b = s.Bitmap
         If (b.ResolutionX / dpi > 1.2) Or (b.ResolutionY / dpi > 1.2) Then
            On Error GoTo err
            ActiveDocument.BeginCommandGroup
            w = s.SizeWidth: h = s.SizeHeight: x = s.PositionX: y = s.PositionY
            If b.ResolutionX * b.ResolutionY <= 0 Then srBad.Add s _
               Else b.Resample Round(dpi / b.ResolutionX * b.SizeWidth + 0.49999), Round(dpi / b.ResolutionY * b.SizeHeight + 0.49999), True, dpi, dpi
            s.SizeWidth = w: s.SizeHeight = h: s.PositionX = x: s.PositionY = y
            ActiveWindow.Refresh
err:        ActiveDocument.EndCommandGroup
         End If
      End If
   Next s
   stat.EndProgress
   If srBad.Count > 0 Then srBad.CreateSelection: MsgBox CStr(srBad.Count) + " bad bitmaps selected"
End Sub

Hi wOxxOm,

I have emailed you the CorelDRAW X3 file.

Thanks again for looking at this for me.

[wOxxOm]

look at my previous post - it contains silent code that will not alert you