Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 2107
  • Last Modified:

How do I take a screenshot and crop it using vb6?

My overall objective is to create a bitmap file containing a screenshot of a section of a window from another application (the other application is a 3D CAD tool, but that really makes no difference to this problem). I have already written most of the code and I currently have it working to create a bitmap file containing a screenshot of the correct window, but now I need to crop it.

Note: The project works without any forms so that it can be called from the other application. I know my problem can be solved by using PictureBox controls on a form, but I do not want to go down that route.

The code to grab the screenshot and create the file is shown below. This code was taken from http://www.rnsoftech.com/Training/WindowScreenshot.aspx and it works very well. However, I have tried many ways of editing this code to perform the cropping, but I cannot get it to work.

The cropping needs to work by identifying the white background around the outside of the multicoloured image in the centre of the window. Then crop off all sides so that the image now fills the whole of the bitmap and there is no white background surrounding the image. I've attached sample images showing what this code currently produces and what I want to produce.

So, how do I modify this code to achieve this?

Thanks in advance.
Ian
Public Function GetWindowScreenshot(WndHandle As Long, SavePath As String, Optional BringFront As Integer = 1) As Long
'
' Function to create screeenshot of specified window and store at specified path
'
    On Error GoTo ErrorHandler
 
    Dim hDCSrc As Long
    Dim hDCMemory As Long
    Dim hBmp As Long
    Dim hBmpPrev As Long
    Dim WidthSrc As Long
    Dim HeightSrc As Long
    Dim Pic As PicBmp
    Dim IPic As IPicture
    Dim IID_IDispatch As guid
    Dim rc As RECT
    Dim pictr As PictureBox
    
    
    'Bring window on top of all windows if specified
    If BringFront = 1 Then BringWindowToTop WndHandle
    
    'Get Window Size
    GetWindowRect WndHandle, rc
    WidthSrc = rc.Right - rc.Left
    HeightSrc = rc.Bottom - rc.Top
    
    'Get Window  device context
    hDCSrc = GetWindowDC(WndHandle)
    
    'create a memory device context
    hDCMemory = CreateCompatibleDC(hDCSrc)
    
    'create a bitmap compatible with window hdc
    hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
    
    'copy newly created bitmap into memory device context
    hBmpPrev = SelectObject(hDCMemory, hBmp)
    
    
    'copy window window hdc to memory hdc
    Call BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, _
                hDCSrc, 0, 0, vbSrcCopy)
      
    'Get Bmp from memory Dc
    hBmp = SelectObject(hDCMemory, hBmpPrev)
    
    'release the created objects and free memory
    Call DeleteDC(hDCMemory)
    Call ReleaseDC(WndHandle, hDCSrc)
    
    'fill in OLE IDispatch Interface ID
    With IID_IDispatch
       .data1 = &H20400
       .data4(0) = &HC0
       .data4(7) = &H46
     End With
    
    'fill Pic with necessary parts
    With Pic
       .Size = Len(Pic)         'Length of structure
       .Type = vbPicTypeBitmap  'Type of Picture (bitmap)
       .hBmp = hBmp             'Handle to bitmap
       .hPal = 0&               'Handle to palette (may be null)
     End With
    
    'create OLE Picture object
    Call OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
    
    'return the new Picture object
    SavePicture IPic, SavePath
    GetWindowScreenshot = 1
    Exit Function
    
ErrorHandler:
    GetWindowScreenshot = 0
End Function

Open in new window

test-image-orig.png
test-image-crop.png
0
ian_ff1
Asked:
ian_ff1
  • 2
  • 2
1 Solution
 
ExcelGuideConsultantCommented:
I hope the following link will help you out:
http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=1755&lngWId=10

its auto crop, good luck
0
 
VKCommented:
Hello,

the code below crops an image. I haven't spend much time to find a perfect solution to crop
an image in minimum effort as possible, but it works. Take care of the bound.
They could be inexact (-/+ 1).

The attached file APIBitmap.txt is a useful class to handle bitmaps. There is a reference to that file
in the code below!
Option Explicit
 
'This Code does not work for PNG-Files!
'It's not optimized an demonstrates a possible solution for cropping
 
Private BMP As clsAPIBitmap
Private Const CROP_COLOR = &HFFFFFF
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
 
Public Sub main()
    Set BMP = New clsAPIBitmap
    Call BMP.LoadBitmap(App.Path & "\test-image-orig.bmp", IMAGE_BITMAP, InPixels)
End Sub
 
Private Sub CropBMP()
    Dim x(0 To 2) As Long
    Dim y(0 To 2) As Long
    '
    y(0) = GetVerticalBound(0, BMP.Height - 1)
    y(1) = GetVerticalBound(BMP.Height - 1, 0)
    x(0) = GetHorizontalBound(0, BMP.Width - 1)
    x(1) = GetHorizontalBound(BMP.Width - 1, 0)
    '
    Call BMP.Paint(Form1.picDest.hdc, 0, 0, 1 + y(1) - y(0), 1 + x(1) - x(0), x(0), y(0))
End Sub
 
Private Function GetVerticalBound(Y0 As Long, Y1 As Long) As Long
    Dim x As Long
    Dim y As Long
    '
    For y = Y0 To Y1 Step Sgn(Y1 - Y0)
        For x = 0 To BMP.Width - 1
            If GetPixel(BMP.hdc, x, y) <> CROP_COLOR Then
                GetVerticalBound = y
                Exit Function
            End If
        Next
    Next
    GetVerticalBound = y
End Function
 
Private Function GetHorizontalBound(X0 As Long, X1 As Long) As Long
    Dim x As Long
    Dim y As Long
    '
    For x = X0 To X1 Step Sgn(X1 - X0)
        For y = 0 To BMP.Height - 1
            If GetPixel(BMP.hdc, x, y) <> CROP_COLOR Then
                GetHorizontalBound = x
                Exit Function
            End If
        Next
    Next
    GetHorizontalBound = x
End Function

Open in new window

APIBitmap.txt
0
 
VKCommented:
In the case you have no image (e. g. all Pixels have a white color) CropBMP would fail.
But it shouldn't be diffucult to catch this case by additional coding.
0
 
ian_ff1Author Commented:
Thanks for your responses.

Psychotec:
The link you provided is for vb.net, so it won't work for me as I'm using vb6.

VK:
The code you supplied looks good for cropping an image. The attached APIbitmap class has a lot of useful code in it also, but I certainly don't need all the functions in it, so I'd rather just continue using the memory handles in my sample.

Based on VK's code, I have modified my code to do exactly what I asked, plus an additional resize operation after cropping. See below.

However, the code is far too slow. The CAD system is iterating over a large amount of files. It only displays each one for a short period, then calls my program and moves on to the next file. The screenshots are capturing the CAD system's 'file > open' dialog box on top of the required image, which indicates that my program is not capturing the screenshot quickly enough.

The code is iterating through each pixel to get the crop region before the screenshot is captured. So I tried loading the screenshot into an IPicture object immediately, then working with that. The problem is that the GetPixel function needs the pixel to be displayed, otherwise it just returns -1. Does anyone have a solution for this?

If I get no further responses, I'll award all the points to VK as his solution dis answer my original question.
' ##################################################
' This module is used to do a screen capture in VB6
' Written by Ian Eldred
' Original code copied from www.rnsoftech.com
' Modifications to add cropping and resize functionality
' ##################################################
 
'''''''
'Types
'''''''
Private Type guid
   data1 As Long
   data2 As Integer
   data3 As Integer
   data4(7) As Byte
End Type
 
Private Type PicBmp
   Size As Long
   Type As Long
   hBmp As Long
   hPal As Long
   Reserved As Long
End Type
 
Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
 
'''''''''
'Windows API Declarations
'''''''''
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDCDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" (PicDesc As PicBmp, RefIID As guid, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function BringWindowToTop Lib "user32" (ByVal hwnd As Long) As Long
 
'### Added by Ian Eldred ###
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
'###########################
 
Public Function GetWindowScreenshot(WndHandle As Long, SavePath As String, Optional BringFront As Integer = 1) As Long
'
' Function to create screeenshot of specified window and store at specified path
'
    On Error GoTo ErrorHandler
 
    Dim hDCSrc As Long
    Dim hDCMemory As Long
    Dim hBmp As Long
    Dim hBmpPrev As Long
    Dim widthSrc As Long
    Dim HeightSrc As Long
    Dim Pic As PicBmp
    Dim IPic As IPicture
    Dim IID_IDispatch As guid
    Dim rc As RECT
    Dim pictr As PictureBox
    Dim cropRect As RECT
    Dim hBmpResize As Long
    Dim hBmpResizePrev As Long
    Dim hDCResize As Long
    Dim P As Long
    Dim cropWidth As Long
    Dim cropHeight As Long
    Dim resizeWidth As Long
    Dim resizeHeight As Long
        
    'Bring window on top of all windows if specified
    If BringFront = 1 Then BringWindowToTop WndHandle
    
    'Get Window Size
    GetWindowRect WndHandle, rc
    widthSrc = rc.Right - rc.Left
    HeightSrc = rc.Bottom - rc.Top
       
    'Get Window  device context
    hDCSrc = GetWindowDC(WndHandle)
        
    '### Get the cropped size of the Bmp
    cropRect = GetCropRect(hDCSrc, rc)
    cropWidth = cropRect.Right - cropRect.Left
    cropHeight = cropRect.Bottom - cropRect.Top
    
    'create a memory device context
    hDCMemory = CreateCompatibleDC(hDCSrc)
    
    'create a bitmap compatible with window hdc
    'hBmp = CreateCompatibleBitmap(hDCSrc, widthSrc, HeightSrc)
    hBmp = CreateCompatibleBitmap(hDCSrc, cropWidth, cropHeight)
    
    'copy newly created bitmap into memory device context
    hBmpPrev = SelectObject(hDCMemory, hBmp)
    
    'copy window window hdc to memory hdc
    'Call BitBlt(hDCMemory, 0, 0, widthSrc, HeightSrc, hDCSrc, 0, 0, vbSrcCopy)
    Call BitBlt(hDCMemory, 0, 0, cropWidth, cropHeight, hDCSrc, cropRect.Left, cropRect.Top, vbSrcCopy)
     
    '### Resize
    Dim thumbnail As Integer
    thumbnail = 200 'the size of the new thumbnail
    If cropWidth > cropHeight Then
        resizeWidth = thumbnail
        resizeHeight = CInt(thumbnail * cropHeight / cropWidth)
    Else
        resizeHeight = thumbnail
        resizeWidth = CInt(thumbnail * cropWidth / cropHeight)
    End If
    'Create a new device context to copy the resized image into
    hDCResize = CreateCompatibleDC(hDCSrc)
    hBmpResize = CreateCompatibleBitmap(hDCSrc, resizeWidth, resizeHeight)
    hBmpResizePrev = SelectObject(hDCResize, hBmpResize)
    'resize the image into the new DC
    Call StretchBlt(hDCResize, 0, 0, resizeWidth, resizeHeight, hDCMemory, 0, 0, cropWidth, cropHeight, vbSrcCopy)
    '### End resize
      
    'Get Bmp from memory Dc
    'hBmp = SelectObject(hDCMemory, hBmpPrev)
    hBmp = SelectObject(hDCResize, hBmpResizePrev)
    
    '### Clean up
    'release the created objects and free memory
    Call DeleteDC(hDCMemory)
    Call DeleteDC(hDCResize)
    Call ReleaseDC(WndHandle, hDCSrc)
        
    '### Save bitmap file
    'fill in OLE IDispatch Interface ID
    With IID_IDispatch
       .data1 = &H20400
       .data4(0) = &HC0
       .data4(7) = &H46
     End With
    
    'fill Pic with necessary parts
    With Pic
       .Size = Len(Pic)         'Length of structure
       .Type = vbPicTypeBitmap  'Type of Picture (bitmap)
       .hBmp = hBmp             'Handle to bitmap
       .hPal = 0&               'Handle to palette (may be null)
     End With
    
    'create OLE Picture object
    Call OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
    
    'return the new Picture object
    SavePicture IPic, SavePath
    
    '### Set return value
    GetWindowScreenshot = 1
    Exit Function
    
ErrorHandler:
    GetWindowScreenshot = 0
End Function
 
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 
Public Function GetCropRect(hWindow As Long, rSrc As RECT) As RECT
 
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Function written by Ian Eldred
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' This function returns a rectangle to which an image can be cropped,
' based on a background of the same colour as pixel 1,1.
' For example, this 20x8 image
' ####################
' ####################
' ######OOOOO#########
' #####OOOOO##########
' #####OOOOOO#########
' ######OOOOO#########
' ########O###########
' ####################
 
' could be cropped to this 6x5 image
' #OOOOO
' OOOOO#
' OOOOOO
' #OOOOO
' ###O##
 
' and the returned RECT object would look like this
' crop.left = 6
' crop.right = 12
' crop.top = 3
' crop.bottom = 8
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 
    Dim x As Long
    Dim y As Long
    Dim P As Long
    Dim cropTop As Long
    Dim cropLeft As Long
    Dim cropBottom As Long
    Dim cropRight As Long
    Dim blnFoundPixel As Boolean
    Dim pixelBG As Long
    
    'Get the colour of the first pixel to compare all other pixels against.
    'This colour is treated as the background colour.
    pixelBG = GetPixel(hWindow, rSrc.Left, rSrc.Top)
    
    'From the left
    blnFoundPixel = False
    'Loop from left to right
    For x = rSrc.Left To rSrc.Right
        'Loop from top to bottom
        For y = rSrc.Top To rSrc.Bottom
            'Get the colour of the pixel
            P = GetPixel(hWindow, x, y)
            If P = -1 Then
                'If the pixel is outside of the bounds of the DC, do nothing.
            ElseIf P <> pixelBG Then
                'The first time we encounter a pixel of a different colour,
                'record the x position, then exit the loop.
                cropLeft = x
                blnFoundPixel = True
                Exit For
            End If
        Next y
        'Exit loop if we've already found a coloured pixel
        If blnFoundPixel Then Exit For
    Next x
    
    'From the Right
    blnFoundPixel = False
    For x = rSrc.Right To rSrc.Left Step -1
        For y = rSrc.Top To rSrc.Bottom
            P = GetPixel(hWindow, x, y)
            If P = -1 Then
            ElseIf P <> pixelBG Then
                cropRight = x + 1
                blnFoundPixel = True
                Exit For
            End If
        Next y
        If blnFoundPixel Then Exit For
    Next x
    
    'From the Top
    blnFoundPixel = False
    For y = rSrc.Top To rSrc.Bottom
        For x = cropLeft To cropRight
            P = GetPixel(hWindow, x, y)
            If P = -1 Then
            ElseIf P <> pixelBG Then
                cropTop = y
                blnFoundPixel = True
                Exit For
            End If
        Next x
        If blnFoundPixel Then Exit For
    Next y
    
    'From the Bottom
    blnFoundPixel = False
    For y = rSrc.Bottom To rSrc.Top Step -1
        For x = cropLeft To cropRight
            P = GetPixel(hWindow, x, y)
            If P = -1 Then
            ElseIf P <> pixelBG Then
                cropBottom = y + 1
                blnFoundPixel = True
                Exit For
            End If
        Next x
        If blnFoundPixel Then Exit For
    Next y
        
    'Set the return values
    GetCropRect.Left = cropLeft
    GetCropRect.Right = cropRight
    GetCropRect.Top = cropTop
    GetCropRect.Bottom = cropBottom
    
End Function

Open in new window

0
 
ian_ff1Author Commented:
Here is my final solution. It has been built up using snipets of code from all over the web, but the most useful site was http://www.tannerhelland.com/vb6/vb-graphics-programming-3/

I no longer use the screen capture part of the code because I could not pause the CAD software for long enough to take the screenshot when it was iterating over 100's of CAD models. Instead, the CAD software now saves a jpeg image of each model (functionality that was built in to the CAD software) and my code runs on the folder full of jpeg images instead.

The code uses a form that never gets displayed and opens each image in a hidden picturebox. It then calculates the crop area and bitblt's that area on to a second hidden picturebox. It then resizes the image according to a specified max width/height by using stretchblt on to a third picturebox. The final image is saved by simply using savepicture.

The function that returns the crop area now uses memory arrays and is EXTREMELY fast! It was very difficult to get my head around, but once I did, the speed increase was amazing.
'---------------------------
' Form code
'---------------------------
Private Declare Function BitBlt Lib "gdi32" (ByVal hDCDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function GetStretchBltMode Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Integer) As Integer
Private Const HALFTONE = 4
 
Private Sub Form_Load()
    
    Dim strFileType As String
    Dim strPath As String
    Dim strFile As String
    Dim strCommand As String
    Dim i As Long
    
    strCommand = GetCommand
    
    strFileType = "*.jpg"
    If Len(strCommand) > 0 Then
        strPath = strCommand
    Else
        strPath = App.Path & "\ProEPictures\"
    End If
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    strFile = Dir(strPath & strFileType, vbNormal)
    If strFile = "" Then MsgBox "No jpeg images were found in '" & strPath & "'.", vbExclamation, "Proe Pics"
    
    Do While strFile <> ""   ' Start the loop.
        CropResize strPath & strFile
        strFile = Dir   ' Get next entry.
        i = i + 1
    Loop
    MsgBox "ProePics.exe has generated " & i & " cropped bitmap images in '" & strPath & "'.", vbInformation, "ProePics - Completed"
    End
End Sub
 
Private Function GetCommand() As String
    On Error GoTo GetCommand_error
    If Len(Command) <> 0 Then
        If Asc(Command) = 34 Then
            GetCommand = Mid(Command, 2, Len(Command) - 2)
        Else
            GetCommand = Command
        End If
    Else
        GetCommand = ""
    End If
 
GetCommand_exit:
    Exit Function
GetCommand_error:
    MsgBox Err.Description, vbExclamation, App.Title
End Function
 
Private Sub CropResize(strFileName As String)
    Dim rOrig As RECT
    Dim rCrop As RECT
    Dim lCropWidth As Long
    Dim lCropHeight As Long
    Dim lResizeWidth As Long
    Dim lResizeHeight As Long
    Dim strNewFile As String
    Dim thumbnail As Long
    thumbnail = 200 'the size of the new thumbnail
        
    Picture1.Picture = LoadPicture(strFileName)
    
    With rOrig
        .Top = 0
        .Left = 0
        .Bottom = Picture1.Height
        .Right = Picture1.Width
    End With
    
    rCrop = GetCropRect2(Picture1, rOrig)
    If rCrop.Left = 0 And rCrop.Right = 0 And rCrop.Bottom = 0 And rCrop.Top = 0 Then
        'It is a completely white image
        'So do not generate a new image
        Exit Sub
    End If
    lCropWidth = rCrop.Right - rCrop.Left
    lCropHeight = rCrop.Bottom - rCrop.Top
    
    Picture2.Width = lCropWidth
    Picture2.Height = lCropHeight
    
    Call BitBlt(Picture2.hdc, 0, 0, lCropWidth, lCropHeight, Picture1.hdc, rCrop.Left, rCrop.Top, vbSrcCopy)
    Picture2.Refresh
    
    '### Resize
    If lCropWidth > lCropHeight Then
        lResizeWidth = thumbnail
        lResizeHeight = CLng(thumbnail * lCropHeight / lCropWidth)
    Else
        lResizeHeight = thumbnail
        lResizeWidth = CLng(thumbnail * lCropWidth / lCropHeight)
    End If
    
    Picture3.Width = lResizeWidth
    Picture3.Height = lResizeHeight
    
    'check if the current StretchMode is set to HALFTONE
    If GetStretchBltMode(Picture3.hdc) <> HALFTONE Then
        'if it's not, set it to HALFTONE
        SetStretchBltMode Picture3.hdc, HALFTONE
    End If
    
    'resize the image into the new DC
    Call StretchBlt(Picture3.hdc, 0, 0, lResizeWidth, lResizeHeight, Picture2.hdc, 0, 0, lCropWidth, lCropHeight, vbSrcCopy)
    '### End resize
    
    Picture3.Refresh
    Picture3.Picture = Picture3.Image
    strNewFile = Left(strFileName, Len(strFileName) - 4) & ".bmp"
    SavePicture Picture3, strNewFile
End Sub
 
'---------------------------
' Module code
'---------------------------
Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Type Bitmap
   bmType As Long
   bmWidth As Long
   bmHeight As Long
   bmWidthBytes As Long
   bmPlanes As Integer
   bmBitsPixel As Integer
   bmBits As Long
End Type
 
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, ByRef lpBits As Any) As Long
Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, ByRef lpBits As Any) As Long
 
Public Function GetCropRect2(PictureBox As PictureBox, rSrc As RECT) As RECT
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Function written by Ian Eldred
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' This function returns a rectangle to which an image can be cropped,
' based on a background of the same colour as pixel 1,1.
' For example, this 20x8 image
' ####################
' ####################
' ######OOOOO#########
' #####OOOOO##########
' #####OOOOOO#########
' ######OOOOO#########
' ########O###########
' ####################
 
' could be cropped to this 6x5 image
' #OOOOO
' OOOOO#
' OOOOOO
' #OOOOO
' ###O##
 
' and the returned RECT object would look like this
' crop.left = 6
' crop.right = 12
' crop.top = 3
' crop.bottom = 8
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 
    Dim bm As Bitmap
    
    GetObject PictureBox.Image, Len(bm), bm
    
    Dim ImageData() As Byte
    
    ReDim ImageData(0 To (bm.bmBitsPixel / 8) - 1, 0 To bm.bmWidth - 1, 0 To bm.bmHeight - 1)
    GetBitmapBits PictureBox.Image, bm.bmWidthBytes * bm.bmHeight, ImageData(0, 0, 0)
        
    Dim x As Long, y As Long
    Dim cropTop As Long
    Dim cropLeft As Long
    Dim cropBottom As Long
    Dim cropRight As Long
    Dim blnFoundPixel As Boolean
            
    'From the left
    blnFoundPixel = False
    'Loop from left to right
    For x = 0 To PictureBox.ScaleWidth - 1
        'Loop from top to bottom
        For y = 0 To PictureBox.ScaleHeight - 1
            If ImageData(2, x, y) = 255 And ImageData(1, x, y) = 255 And ImageData(0, x, y) = 255 Then
            Else
                'The first time we encounter a pixel of a different colour,
                'record the x position, then exit the loop.
                cropLeft = x - 10
                blnFoundPixel = True
                Exit For
            End If
        Next y
        'Exit loop if we've already found a coloured pixel
        If blnFoundPixel Then Exit For
    Next x
    
    If Not blnFoundPixel Then
        'This is a completely white image
        GetCropRect2.Left = 0
        GetCropRect2.Right = 0
        GetCropRect2.Top = 0
        GetCropRect2.Bottom = 0
        Exit Function
    End If
    
    'From the Right
    blnFoundPixel = False
    For x = PictureBox.ScaleWidth - 1 To rSrc.Left Step -1
        For y = 0 To PictureBox.ScaleHeight - 1
            If ImageData(2, x, y) = 255 And ImageData(1, x, y) = 255 And ImageData(0, x, y) = 255 Then
            Else
                cropRight = x + 20
                blnFoundPixel = True
                Exit For
            End If
        Next y
        If blnFoundPixel Then Exit For
    Next x
    
    'From the Top
    blnFoundPixel = False
    For y = 0 To PictureBox.ScaleHeight - 1
        For x = cropLeft To cropRight
            If ImageData(2, x, y) = 255 And ImageData(1, x, y) = 255 And ImageData(0, x, y) = 255 Then
            Else
                cropTop = y - 10
                blnFoundPixel = True
                Exit For
            End If
        Next x
        If blnFoundPixel Then Exit For
    Next y
    
    'From the Bottom
    blnFoundPixel = False
    For y = PictureBox.ScaleHeight - 1 To 0 Step -1
        For x = cropLeft To cropRight
            If ImageData(2, x, y) = 255 And ImageData(1, x, y) = 255 And ImageData(0, x, y) = 255 Then
            Else
                cropBottom = y + 20
                blnFoundPixel = True
                Exit For
            End If
        Next x
        If blnFoundPixel Then Exit For
    Next y
        
    'Set the return values
    GetCropRect2.Left = cropLeft
    GetCropRect2.Right = cropRight
    GetCropRect2.Top = cropTop
    GetCropRect2.Bottom = cropBottom
 
End Function

Open in new window

0

Featured Post

Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 2
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now