As frivolous as it seems, this program ties together several useful techniques. It calls the EnumWindows API function to look for a window whose title begins with "FreeCell." Subroutine ActivateFreeCell uses the ShowWindow API function to restore the FreeCell application in case it's minimized. It then uses the SetForegroundWindow API function to give FreeCell the focus.

Subroutine GetFreeCellPosition uses the GetWindowPlacement API function to see where the FreeCell program's window is.

The IdentifyCards subroutine calls subroutine GetFreeCellImage to capture an image of the FreeCell application.(GetFreeCellImage uses the keybd_event API function to simulate Alt-PrintScreen to copy the FreeCell window's image to the clipboard. It then pastes the clipboard image into a PictureBox.)

IdentifyCards then loops through locations in the FreeCell image using the ImageMatches subroutine to compare each location to a saved image of the top of a card. When it finds a match, the program has identified a card.

There's a pretty impressive trick here. If you look closely at FreeCell, you'll notice that you cannot tell what suit an ace has because the suit marks are hidden behind the following card. (Yes, you can interactively right click on a card to make it pop to the top. You could simulate a right click/screen capture/release click and then process the images to see which ace is which. This trick is easier, however, because it requires only one screen capture and no key press simulation.)

If you look really closely, you'll see that the letter for one red ace and one black ace start shifted 1 pixel to the left of the letters for the other two aces. Once you know that the aces of diamonds and spades are the ones shifted left, the program can tell which ace is which just by looking at the top area of the cards.

So why did Microsoft make the aces slightly different? This may go down in history as the greatest mystery of our day! Or perhaps not since no one really cares.

It is an amazing coincidence that this little "flaw" in the aces lets you tell them apart. Does Microsoft have an application that plays FreeCell just as this one will? It's possible. That would be a very good way to debug FreeCell. Just have the automated FreeCell player run a few thousand games and see if anything crashes. You must admit, FreeCell is one of the more stable Microsoft applications these days.

One bit of evidence that this is just a weird coincidence is that the 5's have similar differences even though they are not needed to tell the 5's apart.

Anyway, subroutine IdentifyCards makes a collection for each column of cards and fills it with Card objects representing the cards in that column. The routine finishes by printing the cards' values to the Debug window so you can verify that they are correct.

Private Sub cmdGo_Click()
    ' Examine the window names.
    g_FreeCellHwnd = 0
    EnumWindows AddressOf WindowEnumerator, 0

    ' See if we got an hwnd.
    If g_FreeCellHwnd = 0 Then
        MsgBox "Error finding FreeCell."
        Exit Sub
    End If

    ' Activate FreeCell.
    ActivateFreeCell

    ' Get the FreeCell window's position.
    GetFreeCellPosition

    ' Identify
    IdentifyCards

    ' Take back the focus.
    Me.SetFocus

    ' Play.
    
If WindowState = vbNormal Then
    Width = picFreeCell.Left + picFreeCell.Width + Width - _
        ScaleWidth
    Height = picFreeCell.Top + picFreeCell.Height + Height _
        - ScaleHeight
End If

End Sub

' Restore FreeCell and activate it.
Private Sub ActivateFreeCell()
    ' Restore FreeCell if minimized.
    ShowWindow g_FreeCellHwnd, SW_RESTORE

    ' Make this the foreground window.
    SetForegroundWindow g_FreeCellHwnd
End Sub

' Get the FreeCell window's position.
Private Sub GetFreeCellPosition()
Dim wp As WINDOWPLACEMENT

    wp.length = Len(wp)
    GetWindowPlacement g_FreeCellHwnd, wp
    m_FreeCellX0 = wp.rcNormalPosition.Left
    m_FreeCellY0 = wp.rcNormalPosition.Top
End Sub

' Identify the cards.
Private Sub IdentifyCards()
#Const DEBUG_SHOW_CARDS = True

Dim r As Integer
Dim c As Integer
Dim i As Integer
Dim X0 As Integer
Dim Y0 As Integer
Dim X As Integer
Dim Y As Integer
Dim got_match As Boolean
Dim new_card As Card

    ' Capture the window's image.
    GetFreeCellImage -1, -1

    ' Prepare picHidden.
    picHidden.AutoRedraw = True
    picHidden.BorderStyle = vbBSNone
    picHidden.Width = ScaleX(m_CellWid, vbPixels, vbTwips)
    picHidden.Height = ScaleY(m_CellHgt, vbPixels, vbTwips)
    picHidden.ScaleMode = vbPixels

    ' Figure out which cards are where.
    For c = 0 To 7
        ' Allocate the column collection.
        Set m_Columns(c) = New Collection

        For r = 0 To 6
            If r * 8 + c > 51 Then Exit For

            X0 = m_OriginX + c * m_OffsetX
            Y0 = m_OriginY + r * m_OffsetY

            ' See which card this is.
            For i = 1 To imlNumbers.ListImages.Count
                ' See if the board image matches
                ' the stored number image.
                picHidden.Picture = _
                    imlNumbers.ListImages(i).Picture
                got_match = ImageMatches( _
                    picHidden, 0, 0, _
                    picFreeCell, X0, Y0, _
                    m_CellWid, m_CellHgt)

                ' See if this picture matched.
                If got_match Then Exit For
            Next i

            ' Add the card.
            Set new_card = New Card
            m_Columns(c).Add new_card

            ' See if we got a match.
            If got_match Then
                ' We know this card.
                ' Record the number.
                new_card.Value = 1 + ((i - 1) Mod 13)

                ' Record the suit.
                Select Case i
                    Case 1 To 13
                        new_card.Suit = "S"
                    Case 14 To 26
                        new_card.Suit = "H"
                    Case 27 To 39
                        new_card.Suit = "C"
                    Case 40 To 52
                        new_card.Suit = "D"
                End Select
            Else
                ' Unknown card.
                new_card.Value = 0
                new_card.Suit = "?"
            End If
        Next r
    Next c

    ' Display the card values.
#If DEBUG_SHOW_CARDS Then
    For r = 0 To 6
        For c = 0 To 7
            If r < m_Columns(c).Count Then
                Select Case m_Columns(c).Item(r + 1).Value
                    Case 1
                        Debug.Print "  A";
                    Case 11
                        Debug.Print "  J";
                    Case 12
                        Debug.Print "  Q";
                    Case 13
                        Debug.Print "  K";
                    Case Else
                        Debug.Print _
                            Format$(m_Columns(c).Item(r + _
                            1).Value, "@@@");
                End Select
                Debug.Print m_Columns(c).Item(r + 1).Suit;
            End If
        Next c
        Debug.Print
    Next r
#End If
End Sub

' Capture an image of the FreeCell window with
' the indicated card right-clicked.
Private Sub GetFreeCellImage(ByVal r As Integer, ByVal c As _
    Integer)
#Const WINDOWS_VERSION = "Windows2000"

Dim alt_key As Long

    ' Clear the clipboard.
    Clipboard.Clear

    If r >= 0 Then
        ' Move the mouse over the cell.
        GenerateCellMouseEvent r, c, _
            MOUSEEVENTF_ABSOLUTE Or _
            MOUSEEVENTF_MOVE

        ' Press the right button down.
        GenerateCellMouseEvent 2, 1, _
            MOUSEEVENTF_ABSOLUTE Or _
            MOUSEEVENTF_RIGHTDOWN
    End If

    ' Capture an image of the form in the clipboard.
    ' Press Alt.
    alt_key = MapVirtualKey(VK_MENU, 0)
    keybd_event VK_MENU, alt_key, 0, 0
    DoEvents

    ' Press Print Scrn.
    #If WINDOWS_VERSION = "Windows2000" Then
        keybd_event VK_SNAPSHOT, 0, 0, 0
    #Else
        keybd_event VK_SNAPSHOT, 1, 0, 0
    #End If
    DoEvents

    ' Release Alt.
    keybd_event VK_MENU, alt_key, KEYEVENTF_KEYUP, 0
    DoEvents

    If r >= 0 Then
        ' Release the right mouse button.
        GenerateCellMouseEvent 2, 1, _
            MOUSEEVENTF_ABSOLUTE Or _
            MOUSEEVENTF_RIGHTUP
    End If

    ' Paste the image into picFreeCell.
    picFreeCell.AutoRedraw = True
    picFreeCell.ScaleMode = vbPixels
    picFreeCell.Picture = Clipboard.GetData(vbCFBitmap)

    ' Save card number images.
    #If SAVE_CARD_IMAGES Then
        SaveCardNumberImages
    #End If
End Sub

James Chaldecott found that there are seveal programs for solving FreeCell and other solitaire games. For more information, go to Freecell Solver.

These programs take their input from text files rather than from the screen. You could easily modify the example described here to generate an input file for one of these programs to use.