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

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

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.

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

Select allOpen in new window

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

Select allOpen in new window