Array optimization - String or Integer?

[Milk]

Here's a quick way to get those pixels into an array using GetDIBits. There is a slight caveat extacting the data this way inverts the Y axis and alters the colours (they become BGRA as opposed to RGBA). I've included a conversion function to toggle between RGBA and BGRA. There is also an option to produce a two Dimensional array but you will find the single dimensional array performs better. If you want to use this with the two dimensional array you will have to invert the Y coordinates in your Database, much better would be to then convert each pair of X and inverted Y integers into a single Long and use a one dimensional array, this is easier than it sounds and can be done quickly.

Also seeing as you are only interested in a few colours it's worth converting the image data from a long array and into a byte array that just holds the colours you are interested in, see the retByteData function.

'Module code
Option Explicit
 
Private Declare Function GetObjectA Lib "GDI32" (ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long
Private Declare Function GetDIBits Lib "GDI32" (ByVal hDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal Length As Long)
 
Private Type BITMAP '24 bytes
 bmType As Long
 bmWidth As Long
 bmHeight As Long
 bmWidthBytes As Long
 bmPlanes As Integer
 bmBitsPixel As Integer
 bmBits As Long
End Type
 
Private Type RGBQUAD
 Blue As Byte
 Green As Byte
 Red As Byte
 Alpha As Byte
End Type
 
Private Type BITMAPINFOHEADER '40 bytes
 bmSize As Long
 bmWidth As Long
 bmHeight As Long
 bmPlanes As Integer
 bmBitCount As Integer
 bmCompression As Long
 bmSizeImage As Long
 bmXPelsPerMeter As Long
 bmYPelsPerMeter As Long
 bmClrUsed As Long
 bmClrImportant As Long
End Type
 
Private Type BITMAPINFO
 bmHeader As BITMAPINFOHEADER
 bmColors(0 To 255) As RGBQUAD
End Type
 
Public Function RetDIBDataLong(PictureObject As Object, Optional Return2DArray As Boolean) As Long()
Dim BM As BITMAP, bmi As BITMAPINFO, lngImageData() As Long
   'The PictureObject must be an object with both a HDC and Image property
   'such as a PictureBox, UserControl or Form
   
   GetObjectA PictureObject.Image, 24, BM
   bmi.bmHeader.bmWidth = BM.bmWidth
   bmi.bmHeader.bmHeight = BM.bmHeight
   bmi.bmHeader.bmSize = 40
   bmi.bmHeader.bmPlanes = 1
   bmi.bmHeader.bmBitCount = 32
   
   If Return2DArray Then
     ReDim lngImageData(BM.bmWidth - 1, BM.bmHeight - 1)
     GetDIBits PictureObject.hDC, PictureObject.Image.Handle, 0, BM.bmHeight, lngImageData(0, 0), bmi, 0
   Else
     ReDim lngImageData(BM.bmWidth * BM.bmHeight - 1)
     GetDIBits PictureObject.hDC, PictureObject.Image.Handle, 0, BM.bmHeight, lngImageData(0), bmi, 0
   End If
   
   RetDIBDataLong = lngImageData
End Function
 
Public Function retByteData(PictureObject As Object, SearchPalette() As Long) as Byte()
'The ImageObject must be an object with both a HDC and Image property
'such as a PictureBox, UserControl or Form
 
'The searchpalette should contain no more than 255 colours and these
'colours must be in the form of DIBSection colours i.e. BGRA not RGBA see
'ConvertColour function below
 
 
Dim i As Long, ii As Long, lPalLen As Long, lngImageData() As Long, bytImageData() As Byte
  lPalLen = UBound(SearchPalette)
  If lPalLen > 254 Then lPalLen = 254
  
  lngImageData = RetDIBDataLong(PictureObject)
  i = UBound(lngImageData)
  ReDim bytImageData(i)
  
  For i = 0 To i
    For ii = 0 To lPalLen
      If lngImageData(i) = SearchPalette(ii) Then
        bytImageData(i) = ii + 1
        Exit For
      End If
    Next ii
  Next i
  
 'If you only want a couple of colours they might be better HardCoded here rather
 'than in the passed SearchPalette, example loop would then be...
  'For i = 0 To i
      'Select Case lngImageData(i)
        'Case Colour1
          'bytImageData(i) = 1
        'Case Colour2
          'bytImageData(i) = 2
      'End Select
  'Next i
  
  retByteData = bytImageData
End Function
 
Public Function ConvertColour(ByVal Colour As Long) As Long
Dim uRGBA As RGBQUAD, Swp As Byte
  RtlMoveMemory uRGBA, Colour, 4&
  With uRGBA
     Swp = .Red
    .Red = .Blue
    .Blue = Swp
  End With
  RtlMoveMemory Colour, uRGBA, 4&
  ConvertColour = Colour
End Function

'Example calling code for a form with two pictureboxes and two command buttons
Option Explicit
Private Declare Function SetPixelV Lib "GDI32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Byte
 
Private Sub Command1_Click()
Dim PicData() As Byte, pal() As Long, i As Long, W As Long
  ReDim pal(3)
  'First fill the pal array with the colours we want to capture, up to 255
  'RGB can be used to generate 32bpp DIB Colours by swaping Red for Blue and visa versa
  pal(0) = RGB(0, 3, 1) 'same as ConvertColour(RGB(1, 3, 0))
  pal(1) = RGB(3, 0, 15)
  pal(2) = RGB(33, 0, 206)
  pal(3) = RGB(249, 252, 250)
  PicData = retByteData(Picture1, pal)
  
  'This next bit is slow, it is just to show the data we have just gained visualy
  With Picture1
    W = Picture1.ScaleX(.ScaleWidth, .ScaleMode, vbPixels)
  End With
  
  Picture2.Cls
  For i = 0 To UBound(PicData)
    If PicData(i) Then SetPixelV Picture2.hDC, i Mod W, i \ W, QBColor(PicData(i))
  Next i
  'As you can see the Y axis has been inverted
End Sub
 
 
Private Sub Command2_Click()
 
Dim PicData() As Long, X As Long, Y As Long, UBY As Long
  'Get the pixel data very quickly
  PicData = RetDIBDataLong(Picture1, True)
  
  'Then a slow method to show how the Y axis is inverted and the Red and Blue bytes are swapped
  Picture2.Cls
  UBY = UBound(PicData, 2)
  For X = 0 To UBound(PicData, 1)
    For Y = 0 To UBY
      SetPixelV Picture2.hDC, X, Y, PicData(X, Y)
    Next Y
  Next X
End Sub

To copy the code, quote the post and copy from there.
Attached is the image I tested this with.

[Krass]

Hello.

I think I'm done optimizing my main loop. Using the method you guys suggested (user defined types) - and avoiding strings - significantly speeds up the process.

I don't think the code can be done better, below is an idea of what it looks like... It's designed to find matching pixels (same X,Y from my sub-array (from 1 millions record array - about 500 records each times) as the X,Y from the small image I'm comparing it to).

Do While xSmall <= intSmallUBound - 1 And xHuge <= HugeType(i).Length - 1
    If HugeType(i).Coords(xHuge).x < (arrSmallSubArray(0, xSmall) + xAdd) Then
        xHuge = xHuge + 1
    ElseIf HugeType(i).Coords(xHuge).x > (arrSmallSubArray(0, xSmall) + xAdd) Then
        xSmall = xSmall + 1
    ElseIf HugeType(i).Coords(xHuge).y < (arrSmallSubArray(1, xSmall) + yAdd) Then
        xHuge = xHuge + 1
    ElseIf HugeType(i).Coords(xHuge).y > (arrSmallSubArray(1, xSmall) + yAdd) Then
        xSmall = xSmall + 1
    Else
        xSmall = xSmall + 1
        xHuge = xHuge + 1
        MatchCount = MatchCount + 1
    End If
Loop

My next step is to read, understand and implement Milk's piece of code. Btw thank you, that seems to be pretty complete. That's the last portion slowing down my application with those .pset and .point calls. I'm hoping to have time testing this next week.

I've got a (maybe a little off-topic) question. When populating a recordset, why must I use .movelast to be able to retrieve .recordcount? If I just populate it and check the .recordcount it will always show "0". Not a big problem, but I find it weird to have to use .movelast and .movefirst to retrieve that info.

Thank you!

[Ellis Dee]

When populating a recordset, why must I use .movelast to be able to retrieve .recordcount? If I just populate it and check the .recordcount it will always show "0". Not a big problem, but I find it weird to have to use .movelast and .movefirst to retrieve that info.

It's an optimization; the server doesn't send the entire recordset until it has to.

If you have some time, I've always been curious if the With operator speeds up UDT array access. If you change the code you posted to the following, is it any faster?

With HugeType(i)
    Do While xSmall <= intSmallUBound - 1 And xHuge <= .Length - 1
        If .Coords(xHuge).x < (arrSmallSubArray(0, xSmall) + xAdd) Then
            xHuge = xHuge + 1
        ElseIf .Coords(xHuge).x > (arrSmallSubArray(0, xSmall) + xAdd) Then
            xSmall = xSmall + 1
        ElseIf .Coords(xHuge).y < (arrSmallSubArray(1, xSmall) + yAdd) Then
            xHuge = xHuge + 1
        ElseIf .Coords(xHuge).y > (arrSmallSubArray(1, xSmall) + yAdd) Then
            xSmall = xSmall + 1
        Else
            xSmall = xSmall + 1
            xHuge = xHuge + 1
            MatchCount = MatchCount + 1
        End If
    Loop
End With

Also, I see couple tweaks you could do to squeeze a little more speed out of the posted code.

With HugeType(i)
    Do While xSmall < intSmallUBound And xHuge < .Length ' removing the two subtractions should help a bit
        Select Case arrSmallSubArray(0, xSmall) + xAdd
            Case Is > .Coords(xHuge).x: xHuge = xHuge + 1
            Case Is < .Coords(xHuge).x: xSmall = xSmall + 1
            Case Else
                Select Case arrSmallSubArray(1, xSmall) + yAdd
                    Case Is > .Coords(xHuge).y: xHuge = xHuge + 1
                    Case Is < .Coords(xHuge).y: xSmall = xSmall + 1
                    Case Else
                        xSmall = xSmall + 1
                        xHuge = xHuge + 1
                        MatchCount = MatchCount + 1
                End Select
        End Select
    Loop
End With

While I concede that this logic is much less readable, it should be perceptibly more efficient. Every iteration of the Do...Loop has at least 2 fewer arithmetic operations, and each match saves another two operations. Given the huge number of passes this loop is making, this could add up to a fairly decent speed boost.