# Visual Basic > Games and Graphics Programming > Game Demos >  [VB6 ]World War 3 points game Source + EXE

## Nightwalker83

Hi,

This is a little game I have been working on over the past couple of days.


vb Code:
'You need' 4 CommandButtons "cmdAbout", "cmdHow", "cmdAdd" and "cmd Subtract"' A listbox called "lstCountries" set to style "Checkbox". 'The form codeOption ExplicitDim index As Integer, holder As String, var(20) As Variant, country As String, zero As Boolean Private Sub cmdAbout_Click()MsgBox ("World War 3 Forum Game"& vbCrLf & "Based on the Forum game [url]http://www.gtaforums.com/index.php?[/url] showtopic=566787&st=0" & vbCrLf & Please visit either [url]http://aaronspehr.net/[/url] or [url]http://www.vbforums.com/showthread.php?728099-World-War-3-points-game&p=4465297#post4465297[/url] to download the lastest version. & vbCrLf & "Copyright 2013 by Nightwalker83")End Sub Private Sub cmdAdd_Click() Call addpointEnd Sub Private Sub cmdHow_Click()MsgBox ("How to play " & "World War 3 Forum Game" & vbCrLf & "Select a country then select either add or subtract a vote if a country reaches 0 votes they lose the game.")End Sub Private Sub cmdSubtract_Click()Call subtractpointEnd Sub Private Sub Form_Load()    'Subclass the "Form", to Capture the Listbox Notification Messages ...    lPrevWndProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf SubClassedList)    var(0) = 5    lstCountries.AddItem "Australia   - " & var(0), 0     var(1) = 5    lstCountries.AddItem "France  - " & var(1), 1     var(2) = 5    lstCountries.AddItem "Germany  - " & var(2), 2End Sub Private Sub Form_Unload(Cancel As Integer)    'Release the SubClassing, Very Important to Prevent Crashing!    Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevWndProc)End Sub Private Sub lstCountries_Click()   holder = lstCountries.Text   country = (Replace(holder, Right(holder, 3), ""))End Sub Private Sub varcheck(pos As Integer)If pos = 0 ThenlstCountries.RemoveItem (lstCountries.ListIndex)cmdSubtract.Enabled = Falsezero = TrueElsezero = FalseEnd IfEnd Sub Private Sub addpoint()If holder = "" Then Exit Sub      lstCountries.RemoveItem (lstCountries.ListIndex)        Select Case Trim(country)        Case "Australia"         varcheck (var(0))         var(0) = var(0) + 1         lstCountries.AddItem country & var(0), lstCountries.ListIndex         lstCountries.ItemData(lstCountries.NewIndex) = QBColor(10)        Case "France"         varcheck (var(1))         var(1) = var(1) + 1         lstCountries.AddItem country & var(1), lstCountries.ListIndex         lstCountries.ItemData(lstCountries.NewIndex) = QBColor(10)        Case "Germany"         varcheck (var(2))         var(2) = var(2) + 1         lstCountries.AddItem country & var(2), lstCountries.ListIndex         lstCountries.ItemData(lstCountries.NewIndex) = QBColor(10)        End Select        MsgBox (country & " point added")        cmdSubtract.Enabled = TrueEnd Sub Private Sub subtractpoint()If holder = "" Then Exit Sub        Select Case Trim(country)        Case "Australia"         varcheck (var(0))         If zero Then Exit Sub            lstCountries.RemoveItem lstCountries.ListIndex         var(0) = var(0) - 1         lstCountries.AddItem country & var(0), lstCountries.ListIndex         lstCountries.ItemData(lstCountries.NewIndex) = QBColor(12)        Case "France"        varcheck (var(1))        If zero Then Exit Sub            lstCountries.RemoveItem lstCountries.ListIndex        var(1) = var(1) - 1         lstCountries.AddItem country & var(1), lstCountries.ListIndex         lstCountries.ItemData(lstCountries.NewIndex) = QBColor(12)        Case "Germany"        varcheck (var(2))           If zero Then Exit Sub            lstCountries.RemoveItem lstCountries.ListIndex        var(2) = var(2) - 1       lstCountries.AddItem country & var(2), lstCountries.ListIndex       lstCountries.ItemData(lstCountries.NewIndex) = QBColor(12)        End Select        MsgBox (country & " point subtracted")End Sub 'The module code' from thevbprogrammer.com Option Explicit Public Type RECT        Left As Long        Top As Long        Right As Long        Bottom As LongEnd Type Public Type DRAWITEMSTRUCT        CtlType As Long        CtlID As Long        itemID As Long        itemAction As Long        itemState As Long        hwndItem As Long        hdc As Long        rcItem As RECT        ItemData As LongEnd Type Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPublic Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongPublic Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongPublic Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPublic Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As LongPublic Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As LongPublic Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As LongPublic Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As LongPublic Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As LongPublic Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As LongPublic Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long Public Const COLOR_HIGHLIGHT = 13Public Const COLOR_HIGHLIGHTTEXT = 14Public Const COLOR_WINDOW = 5Public Const COLOR_WINDOWTEXT = 8Public Const LB_GETTEXT = &H189Public Const WM_DRAWITEM = &H2BPublic Const GWL_WNDPROC = (-4)Public Const ODS_FOCUS = &H10Public Const ODT_LISTBOX = 2 Public lPrevWndProc As Long Public Function SubClassedList(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long    Dim tItem As DRAWITEMSTRUCT    Dim sBuff As String * 255    Dim sItem As String    Dim lBack As Long     If Msg = WM_DRAWITEM Then        'Redraw the listbox        'This function only passes the Address of the DrawItem Structure, so we need to        'use the CopyMemory API to Get a Copy into the Variable we setup:        Call CopyMemory(tItem, ByVal lParam, Len(tItem))        'Make sure we're dealing with a Listbox        If tItem.CtlType = ODT_LISTBOX Then            'Get the Item Text            Call SendMessage(tItem.hwndItem, LB_GETTEXT, tItem.itemID, ByVal sBuff)            sItem = Left(sBuff, InStr(sBuff, Chr(0)) - 1)            If (tItem.itemState And ODS_FOCUS) Then                'Item has Focus, Highlight it, I'm using the Default Focus                'Colors for this example.                lBack = CreateSolidBrush(GetSysColor(COLOR_HIGHLIGHT))                Call FillRect(tItem.hdc, tItem.rcItem, lBack)                Call SetBkColor(tItem.hdc, GetSysColor(COLOR_HIGHLIGHT))                Call SetTextColor(tItem.hdc, GetSysColor(COLOR_HIGHLIGHTTEXT))                TextOut tItem.hdc, tItem.rcItem.Left, tItem.rcItem.Top, ByVal sItem, Len(sItem)                DrawFocusRect tItem.hdc, tItem.rcItem            Else                'Item Doesn't Have Focus, Draw it's Colored Background                'Create a Brush using the Color we stored in ItemData                lBack = CreateSolidBrush(tItem.ItemData)                'Paint the Item Area                Call FillRect(tItem.hdc, tItem.rcItem, lBack)                'Set the Text Colors                Call SetBkColor(tItem.hdc, tItem.ItemData)                Call SetTextColor(tItem.hdc, IIf(tItem.ItemData = vbBlack, vbWhite, vbBlack))                'Display the Item Text                TextOut tItem.hdc, tItem.rcItem.Left, tItem.rcItem.Top, ByVal sItem, Len(sItem)            End If            Call DeleteObject(lBack)            'Don't Need to Pass a Value on as we've just handled the Message ourselves            SubClassedList = 0            Exit Function         End If     End If    SubClassedList = CallWindowProc(lPrevWndProc, hwnd, Msg, wParam, lParam)End Function

The first version is only single player but I am thinking of making it multi-player maybe through the use of a database.

Nightwalker

----------


## kivisoft@

Nightwalker my man! where is the download link?!!!!

----------


## Nightwalker83

> Nightwalker my man! where is the download link?!!!!


Unfortunately, It won't let me compile the project saying there are errors in the code! Yet no errors appear when running the code in the IDE. I will post the EXE as soon as I can figure out which lines are causing the problem.

----------


## techgnome

"I will post the EXE as soon as I can" --- Ummm.... I know this can't be your first time to the rodeo, so I'm sure you know that you're not allowed to post compiled binaries here... plus, no offence, but I think people would rather the source code be posted and people cna compile it themselves... 

-tg

----------


## si_the_geek

In this section we sometimes allow executables (even tho it is clearly unwise to run them, as we don't know if the poster has a virus on their system, etc), as long as the code is provided too.

----------


## Nightwalker83

> "I will post the EXE as soon as I can" --- Ummm.... I know this can't be your first time to the rodeo, so I'm sure you know that you're not allowed to post compiled binaries here... plus, no offence, but I think people would rather the source code be posted and people cna compile it themselves...


Yes, I know! I was planning on hosting the executable here so I could link to it on another forum I'm a member of (a non-programming forum).

Edit:




> Nightwalker my man! where is the download link?!!!!


I have now included the download link in the first post.

----------

