ApplyPatternFill Full Color Bitmaps

[shelbym]

I am working on a program that applys full color bitmap fills to several objects, I am trying to get it to run as fast as possible, so I created a little speed test. It seems from my testing the CorelScript method for ApplyPatternFills is faster than the VBA commands.

On my machine the VBA version takes about 16 sec. to complete while the CorelScript completes in about 8 seconds. Also the CorelScript method you only have one line of code vs. the several with VBA.

Just looking for thoughts and ideas about optimizing the code to run even faster or better. Thanks.

Here is my sample code:

Sub BitmapFillSpeedTest()

Dim x As Double, y As Double, Height As Double, Width As Double
Dim MaxX As Double, MaxY As Double, MaxHeight As Double, MaxWidth As Double
Dim tm As Double
Dim s As Shape

MaxX = ActivePage.SizeWidth
MaxY = ActivePage.SizeHeight
MaxHeight = 3
MaxWidth = 3
tm = Timer

Optimization = True

For i = 1 To 250
    x = Rnd() * MaxX
    y = Rnd() * MaxY
    Height = Rnd() * MaxHeight
    Width = Rnd() * MaxWidth
    
    Set s = ActiveLayer.CreateRectangle2(x, y, Width, Height)
    
    With s.Fill.ApplyPatternFill(cdrBitmapPattern, "C:\Program Files\Corel\Corel Graphics 12\Custom Data\Tiles\wood23m.cpt")
        .TileHeight = 2 / s.AbsoluteVScale
        .TileWidth = 2 / s.AbsoluteHScale
        .TransformWithShape = True
    End With
    
    'Application.CorelScript.ApplyFullColorFill "C:\Program Files\Corel\Corel Graphics 12\Custom Data\Tiles\wood23m.cpt", ConvertUnits(2, cdrInch, cdrTenthMicron), ConvertUnits(2, cdrInch, cdrTenthMicron), 0, 0, False, 0, 0, True, 0, 0, 0, 0, 0, 0
Next i

Optimization = False
ActiveWindow.Refresh

MsgBox Round((Timer - tm), 2) & " Seconds"

End Sub