Results 1 to 6 of 6

Thread: [VB6 ]World War 3 points game Source + EXE

  1. #1

    Thread Starter
    PowerPoster Nightwalker83's Avatar
    Join Date
    Dec 2001
    Location
    Adelaide, Australia
    Posts
    13,344

    [VB6 ]World War 3 points game Source + EXE

    Hi,

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

    vb Code:
    1. 'You need
    2. ' 4 CommandButtons "cmdAbout", "cmdHow", "cmdAdd" and "cmd Subtract"
    3. ' A listbox called "lstCountries" set to style "Checkbox".
    4.  
    5. 'The form code
    6. Option Explicit
    7. Dim index As Integer, holder As String, var(20) As Variant, country As String, zero As Boolean
    8.  
    9. Private Sub cmdAbout_Click()
    10. 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")
    11. End Sub
    12.  
    13. Private Sub cmdAdd_Click()
    14.  Call addpoint
    15. End Sub
    16.  
    17. Private Sub cmdHow_Click()
    18. 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.")
    19. End Sub
    20.  
    21. Private Sub cmdSubtract_Click()
    22. Call subtractpoint
    23. End Sub
    24.  
    25. Private Sub Form_Load()
    26.     'Subclass the "Form", to Capture the Listbox Notification Messages ...
    27.     lPrevWndProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf SubClassedList)
    28.     var(0) = 5
    29.     lstCountries.AddItem "Australia   - " & var(0), 0
    30.      var(1) = 5
    31.     lstCountries.AddItem "France  - " & var(1), 1
    32.      var(2) = 5
    33.     lstCountries.AddItem "Germany  - " & var(2), 2
    34. End Sub
    35.  
    36. Private Sub Form_Unload(Cancel As Integer)
    37.     'Release the SubClassing, Very Important to Prevent Crashing!
    38.     Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevWndProc)
    39. End Sub
    40.  
    41. Private Sub lstCountries_Click()
    42.    holder = lstCountries.Text
    43.    country = (Replace(holder, Right(holder, 3), ""))
    44. End Sub
    45.  
    46. Private Sub varcheck(pos As Integer)
    47. If pos = 0 Then
    48. lstCountries.RemoveItem (lstCountries.ListIndex)
    49. cmdSubtract.Enabled = False
    50. zero = True
    51. Else
    52. zero = False
    53. End If
    54. End Sub
    55.  
    56. Private Sub addpoint()
    57. If holder = "" Then Exit Sub
    58.       lstCountries.RemoveItem (lstCountries.ListIndex)
    59.         Select Case Trim(country)
    60.         Case "Australia"
    61.          varcheck (var(0))
    62.          var(0) = var(0) + 1
    63.          lstCountries.AddItem country & var(0), lstCountries.ListIndex
    64.          lstCountries.ItemData(lstCountries.NewIndex) = QBColor(10)
    65.         Case "France"
    66.          varcheck (var(1))
    67.          var(1) = var(1) + 1
    68.          lstCountries.AddItem country & var(1), lstCountries.ListIndex
    69.          lstCountries.ItemData(lstCountries.NewIndex) = QBColor(10)
    70.         Case "Germany"
    71.          varcheck (var(2))
    72.          var(2) = var(2) + 1
    73.          lstCountries.AddItem country & var(2), lstCountries.ListIndex
    74.          lstCountries.ItemData(lstCountries.NewIndex) = QBColor(10)
    75.         End Select
    76.         MsgBox (country & " point added")
    77.         cmdSubtract.Enabled = True
    78. End Sub
    79.  
    80. Private Sub subtractpoint()
    81. If holder = "" Then Exit Sub
    82.         Select Case Trim(country)
    83.         Case "Australia"
    84.          varcheck (var(0))
    85.          If zero Then Exit Sub
    86.             lstCountries.RemoveItem lstCountries.ListIndex
    87.          var(0) = var(0) - 1
    88.          lstCountries.AddItem country & var(0), lstCountries.ListIndex
    89.          lstCountries.ItemData(lstCountries.NewIndex) = QBColor(12)
    90.         Case "France"
    91.         varcheck (var(1))
    92.         If zero Then Exit Sub
    93.             lstCountries.RemoveItem lstCountries.ListIndex
    94.         var(1) = var(1) - 1
    95.          lstCountries.AddItem country & var(1), lstCountries.ListIndex
    96.          lstCountries.ItemData(lstCountries.NewIndex) = QBColor(12)
    97.         Case "Germany"
    98.         varcheck (var(2))
    99.            If zero Then Exit Sub
    100.             lstCountries.RemoveItem lstCountries.ListIndex
    101.         var(2) = var(2) - 1
    102.        lstCountries.AddItem country & var(2), lstCountries.ListIndex
    103.        lstCountries.ItemData(lstCountries.NewIndex) = QBColor(12)
    104.         End Select
    105.         MsgBox (country & " point subtracted")
    106. End Sub
    107.  
    108. 'The module code
    109. ' from thevbprogrammer.com
    110.  
    111. Option Explicit
    112.  
    113. Public Type RECT
    114.         Left As Long
    115.         Top As Long
    116.         Right As Long
    117.         Bottom As Long
    118. End Type
    119.  
    120. Public Type DRAWITEMSTRUCT
    121.         CtlType As Long
    122.         CtlID As Long
    123.         itemID As Long
    124.         itemAction As Long
    125.         itemState As Long
    126.         hwndItem As Long
    127.         hdc As Long
    128.         rcItem As RECT
    129.         ItemData As Long
    130. End Type
    131.  
    132. Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    133.  
    134. Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    135. Public 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 Long
    136. Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    137. Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    138. Public Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
    139. Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    140. Public Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
    141. Public Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
    142. Public 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 Long
    143. Public Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
    144. Public Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    145.  
    146. Public Const COLOR_HIGHLIGHT = 13
    147. Public Const COLOR_HIGHLIGHTTEXT = 14
    148. Public Const COLOR_WINDOW = 5
    149. Public Const COLOR_WINDOWTEXT = 8
    150. Public Const LB_GETTEXT = &H189
    151. Public Const WM_DRAWITEM = &H2B
    152. Public Const GWL_WNDPROC = (-4)
    153. Public Const ODS_FOCUS = &H10
    154. Public Const ODT_LISTBOX = 2
    155.  
    156. Public lPrevWndProc As Long
    157.  
    158. Public Function SubClassedList(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    159.     Dim tItem As DRAWITEMSTRUCT
    160.     Dim sBuff As String * 255
    161.     Dim sItem As String
    162.     Dim lBack As Long
    163.  
    164.     If Msg = WM_DRAWITEM Then
    165.         'Redraw the listbox
    166.         'This function only passes the Address of the DrawItem Structure, so we need to
    167.         'use the CopyMemory API to Get a Copy into the Variable we setup:
    168.         Call CopyMemory(tItem, ByVal lParam, Len(tItem))
    169.         'Make sure we're dealing with a Listbox
    170.         If tItem.CtlType = ODT_LISTBOX Then
    171.             'Get the Item Text
    172.             Call SendMessage(tItem.hwndItem, LB_GETTEXT, tItem.itemID, ByVal sBuff)
    173.             sItem = Left(sBuff, InStr(sBuff, Chr(0)) - 1)
    174.             If (tItem.itemState And ODS_FOCUS) Then
    175.                 'Item has Focus, Highlight it, I'm using the Default Focus
    176.                 'Colors for this example.
    177.                 lBack = CreateSolidBrush(GetSysColor(COLOR_HIGHLIGHT))
    178.                 Call FillRect(tItem.hdc, tItem.rcItem, lBack)
    179.                 Call SetBkColor(tItem.hdc, GetSysColor(COLOR_HIGHLIGHT))
    180.                 Call SetTextColor(tItem.hdc, GetSysColor(COLOR_HIGHLIGHTTEXT))
    181.                 TextOut tItem.hdc, tItem.rcItem.Left, tItem.rcItem.Top, ByVal sItem, Len(sItem)
    182.                 DrawFocusRect tItem.hdc, tItem.rcItem
    183.             Else
    184.                 'Item Doesn't Have Focus, Draw it's Colored Background
    185.                 'Create a Brush using the Color we stored in ItemData
    186.                 lBack = CreateSolidBrush(tItem.ItemData)
    187.                 'Paint the Item Area
    188.                 Call FillRect(tItem.hdc, tItem.rcItem, lBack)
    189.                 'Set the Text Colors
    190.                 Call SetBkColor(tItem.hdc, tItem.ItemData)
    191.                 Call SetTextColor(tItem.hdc, IIf(tItem.ItemData = vbBlack, vbWhite, vbBlack))
    192.                 'Display the Item Text
    193.                 TextOut tItem.hdc, tItem.rcItem.Left, tItem.rcItem.Top, ByVal sItem, Len(sItem)
    194.             End If
    195.             Call DeleteObject(lBack)
    196.             'Don't Need to Pass a Value on as we've just handled the Message ourselves
    197.             SubClassedList = 0
    198.             Exit Function
    199.  
    200.         End If
    201.  
    202.     End If
    203.     SubClassedList = CallWindowProc(lPrevWndProc, hwnd, Msg, wParam, lParam)
    204. 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
    Attached Files Attached Files
    Last edited by Nightwalker83; Jul 22nd, 2013 at 09:15 PM. Reason: Adding more!
    when you quote a post could you please do it via the "Reply With Quote" button or if it multiple post click the "''+" button then "Reply With Quote" button.
    If this thread is finished with please mark it "Resolved" by selecting "Mark thread resolved" from the "Thread tools" drop-down menu.
    https://get.cryptobrowser.site/30/4111672

  2. #2
    Lively Member kivisoft@'s Avatar
    Join Date
    Jul 2011
    Location
    Iran
    Posts
    96

    Re: [VB6 ]World War 3 points game Source + EXE

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

  3. #3

    Thread Starter
    PowerPoster Nightwalker83's Avatar
    Join Date
    Dec 2001
    Location
    Adelaide, Australia
    Posts
    13,344

    Re: [VB6 ]World War 3 points game Source + EXE

    Quote Originally Posted by kivisoft@ View Post
    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.
    when you quote a post could you please do it via the "Reply With Quote" button or if it multiple post click the "''+" button then "Reply With Quote" button.
    If this thread is finished with please mark it "Resolved" by selecting "Mark thread resolved" from the "Thread tools" drop-down menu.
    https://get.cryptobrowser.site/30/4111672

  4. #4
    Smooth Moperator techgnome's Avatar
    Join Date
    May 2002
    Posts
    34,531

    Re: [VB6 ]World War 3 points game Source + EXE

    "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
    * I don't respond to private (PM) requests for help. It's not conducive to the general learning of others.*
    * I also don't respond to friend requests. Save a few bits and don't bother. I'll just end up rejecting anyways.*
    * How to get EFFECTIVE help: The Hitchhiker's Guide to Getting Help at VBF - Removing eels from your hovercraft *
    * How to Use Parameters * Create Disconnected ADO Recordset Clones * Set your VB6 ActiveX Compatibility * Get rid of those pesky VB Line Numbers * I swear I saved my data, where'd it run off to??? *

  5. #5
    Super Moderator si_the_geek's Avatar
    Join Date
    Jul 2002
    Location
    Bristol, UK
    Posts
    41,929

    Re: [VB6 ]World War 3 points game Source + EXE

    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.

  6. #6

    Thread Starter
    PowerPoster Nightwalker83's Avatar
    Join Date
    Dec 2001
    Location
    Adelaide, Australia
    Posts
    13,344

    Re: [VB6 ]World War 3 points game Source + EXE

    Quote Originally Posted by techgnome View Post
    "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:

    Quote Originally Posted by kivisoft@ View Post
    Nightwalker my man! where is the download link?!!!!
    I have now included the download link in the first post.
    Last edited by Nightwalker83; Jul 22nd, 2013 at 09:14 PM. Reason: Adding more!
    when you quote a post could you please do it via the "Reply With Quote" button or if it multiple post click the "''+" button then "Reply With Quote" button.
    If this thread is finished with please mark it "Resolved" by selecting "Mark thread resolved" from the "Thread tools" drop-down menu.
    https://get.cryptobrowser.site/30/4111672

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width