VB6 : Color a bitmap - how ??

[Guest_imported]

I run sites of free play-by-email wargames (check them out at

http://www.kaomaris.com,

new blood always welcome). I have been programming the so-called "Manager" for the games that generates the Turns for the Players and then sends them the results. What Im still not able to do is the following :
>> when the Manager starts it loads up an INI File with information on the Map used for the current game. I would like to add X/Y coordinates to that INI File and then have a routine that checks which Player owns which territories and colors the bitmap accordingly.

Is there any function that allows me to FILL a bitmap at given coordinates with a specified color ? How can I achieve this ? Also once I got a colored bitmap, is there an easy way WITHIN VB6 to transform (and save) that Map as JPG ?

Thank you all for your help !

 

[TimLarkin]

You haven't been forgotten here. This was rather intriguing. I've been playing with this for a couple of days, and came up with a beautiful recursive procedure to do the fill color. Unfortunately, it runs out of stack space if the fill area is too big. Working on a different approach......(I think it will work)

 

[TimLarkin]

weel, don't know if this will help, but here it is. By the way, let me know!
This runs sort of slow, and the larger the fill area, the slower it runs(but it works)! There's probably an API call that does this, but I wanted to do it in VB for the fun of it.
Here Goes:
1) Create a folder for the project.
2) Copy following code to notepadI don't know where V5 came from, I use v6):
VERSION 5.00
Begin VB.Form frmMain
Caption = "Form1"
ClientHeight = 6090
ClientLeft = 60
ClientTop = 345
ClientWidth = 8160
LinkTopic = "Form1"
LockControls = -1 'True
ScaleHeight = 6090
ScaleWidth = 8160
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdLoadPicture
Caption = "Load Picture"
Height = 495
Left = 150
TabIndex = 11
Top = 225
Width = 1215
End
Begin VB.HScrollBar hscPic
Height = 210
LargeChange = 1000
Left = 2685
SmallChange = 100
TabIndex = 10
Top = 5415
Width = 5115
End
Begin VB.VScrollBar vscPic
Height = 5115
LargeChange = 1000
Left = 7800
SmallChange = 100
TabIndex = 9
Top = 300
Width = 195
End
Begin VB.PictureBox picContainer
Appearance = 0 'Flat
BackColor = &H00C0C0FF&
BorderStyle = 0 'None
ForeColor = &H80000008&
Height = 5115
Left = 2685
ScaleHeight = 341
ScaleMode = 3 'Pixel
ScaleWidth = 341
TabIndex = 7
Top = 300
Width = 5115
Begin VB.PictureBox picMap
Appearance = 0 'Flat
AutoRedraw = -1 'True
AutoSize = -1 'True
BackColor = &H00FFFFC0&
BorderStyle = 0 'None
ForeColor = &H80000008&
Height = 3720
Left = 0
ScaleHeight = 248
ScaleMode = 3 'Pixel
ScaleWidth = 232
TabIndex = 8
Top = 0
Width = 3480
End
End
Begin VB.Label Label2
BackColor = &H00C0E0FF&
Caption = "Gina the Geek"
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Index = 6
Left = 480
TabIndex = 19
Top = 3660
Width = 1890
End
Begin VB.Label Label2
BackColor = &H00C0E0FF&
Caption = "Frank the Frank"
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Index = 5
Left = 480
TabIndex = 18
Top = 3255
Width = 1890
End
Begin VB.Label Label2
BackColor = &H00C0E0FF&
Caption = "Erol the EggHead"
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Index = 4
Left = 480
TabIndex = 17
Top = 2850
Width = 1890
End
Begin VB.Label Label2
BackColor = &H00C0E0FF&
Caption = "David the DoorStop"
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Index = 3
Left = 480
TabIndex = 16
Top = 2445
Width = 1890
End
Begin VB.Label Label2
BackColor = &H00C0E0FF&
Caption = "Candy the Crude"
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Index = 2
Left = 480
TabIndex = 15
Top = 2040
Width = 1890
End
Begin VB.Label Label2
BackColor = &H00C0E0FF&
Caption = "Bob the Benevolent"
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Index = 1
Left = 480
TabIndex = 14
Top = 1635
Width = 1890
End
Begin VB.Label Label2
BackColor = &H00C0E0FF&
Caption = "Alice the Allmighty"
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Index = 0
Left = 480
TabIndex = 13
Top = 1230
Width = 1890
End
Begin VB.Label Label1
Caption = "Select Player:"
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 225
Left = 150
TabIndex = 12
Top = 900
Width = 1845
End
Begin VB.Label lblColor
Alignment = 2 'Center
BackColor = &H00FF00FF&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "MS Sans Serif"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Index = 6
Left = 165
TabIndex = 6
Top = 3660
Width = 300
End
Begin VB.Label lblColor
Alignment = 2 'Center
BackColor = &H00FF0000&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "MS Sans Serif"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Index = 5
Left = 165
TabIndex = 5
Top = 3255
Width = 300
End
Begin VB.Label lblColor
Alignment = 2 'Center
BackColor = &H00FFFF00&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "MS Sans Serif"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Index = 4
Left = 165
TabIndex = 4
Top = 2850
Width = 300
End
Begin VB.Label lblColor
Alignment = 2 'Center
BackColor = &H0000FF00&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "MS Sans Serif"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Index = 3
Left = 165
TabIndex = 3
Top = 2445
Width = 300
End
Begin VB.Label lblColor
Alignment = 2 'Center
BackColor = &H0000FFFF&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "MS Sans Serif"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Index = 2
Left = 165
TabIndex = 2
Top = 2040
Width = 300
End
Begin VB.Label lblColor
Alignment = 2 'Center
BackColor = &H000080FF&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "MS Sans Serif"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Index = 1
Left = 165
TabIndex = 1
Top = 1635
Width = 300
End
Begin VB.Label lblColor
Alignment = 2 'Center
BackColor = &H000000FF&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "MS Sans Serif"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Index = 0
Left = 165
TabIndex = 0
Top = 1230
Width = 300
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim colPix As New Collection
Dim cpxWork As New clsPix
Dim cpxNew As clsPix
Dim sglX As Single
Dim sglY As Single
Dim lngFillColor As Long
Dim booInUse As Boolean
Const lngBorderColor As Long = 0 'I made this a const here, but could be a variable
Dim lngL_Color As Long
Dim lngT_Color As Long
Dim lngR_Color As Long
Dim lngB_Color As Long

Private Sub cmdLoadPicture_Click()
picMap.Picture = LoadPicture(App.Path & "/WOK400.gif&quot
If picMap.ScaleWidth <= picContainer.ScaleWidth Then
hscPic.Visible = False
Else
hscPic.Max = (picMap.ScaleWidth - picContainer.ScaleWidth)
End If
If picMap.ScaleHeight <= picContainer.ScaleHeight Then
vscPic.Visible = False
Else
vscPic.Max = (picMap.ScaleHeight - picContainer.ScaleHeight)
End If
End Sub


Private Sub Form_Activate()
lngFillColor = lblColor(0).BackColor
End Sub

Private Sub Form_Terminate()
On Error Resume Next
Set cpxWork = Nothing
Set colPix = Nothing
Set cpxWork = Nothing
Set cpxNew = Nothing

End Sub


Private Sub hscPic_Change()
picMap.Left = hscPic.Value * -1

End Sub


Private Sub lblColor_Click(Index As Integer)
Dim intCtr As Integer
Dim objTemp As Control

If Not booInUse Then
lngFillColor = lblColor(Index).BackColor
For Each objTemp In Me.Controls
If TypeOf objTemp Is Label Then
objTemp.Caption = &quot;&quot;
End If
Next
lblColor(Index).Caption = &quot;X&quot;
End If
End Sub

Private Sub picMap_Click()
Dim lngIndex As Long
If Not booInUse Then
Screen.MousePointer = 11
booInUse = True
'set 1st objPic
Set cpxNew = New clsPix
cpxNew.PixelX = sglX
cpxNew.PixelY = sglY
colPix.Add cpxNew
picMap.PSet (sglX, sglY), lngFillColor
Set cpxNew = Nothing

Do Until colPix.Count = 0
DoEvents

Set cpxWork = colPix(colPix.Count)
lngIndex = colPix.Count
lngL_Color = picMap.Point(cpxWork.PixelX - 1, cpxWork.PixelY)
lngT_Color = picMap.Point(cpxWork.PixelX, cpxWork.PixelY - 1)
lngR_Color = picMap.Point(cpxWork.PixelX + 1, cpxWork.PixelY)
lngB_Color = picMap.Point(cpxWork.PixelX, cpxWork.PixelY + 1)
Debug.Print colPix.Count
If lngL_Color <> lngBorderColor And _
lngL_Color <> lngFillColor And _
lngL_Color <> -1 Then
'new pixel to Left
Set cpxNew = New clsPix
cpxNew.PixelX = cpxWork.PixelX - 1
cpxNew.PixelY = cpxWork.PixelY
colPix.Add cpxNew
picMap.PSet (cpxNew.PixelX, cpxNew.PixelY), lngFillColor
Set cpxNew = Nothing
ElseIf lngT_Color <> lngBorderColor And _
lngT_Color <> lngFillColor And _
lngT_Color <> -1 Then
'new pixel to Top
Set cpxNew = New clsPix
cpxNew.PixelX = cpxWork.PixelX
cpxNew.PixelY = cpxWork.PixelY - 1
colPix.Add cpxNew
picMap.PSet (cpxNew.PixelX, cpxNew.PixelY), lngFillColor
Set cpxNew = Nothing
ElseIf lngB_Color <> lngBorderColor And _
lngB_Color <> lngFillColor And _
lngB_Color <> -1 Then
'new pixel to Bottom
Set cpxNew = New clsPix
cpxNew.PixelX = cpxWork.PixelX
cpxNew.PixelY = cpxWork.PixelY + 1
colPix.Add cpxNew
picMap.PSet (cpxNew.PixelX, cpxNew.PixelY), lngFillColor
Set cpxNew = Nothing
Else
If lngR_Color <> lngBorderColor And _
lngR_Color <> lngFillColor And _
lngR_Color <> -1 Then
'new pixel to Right
Set cpxNew = New clsPix
cpxNew.PixelX = cpxWork.PixelX + 1
cpxNew.PixelY = cpxWork.PixelY
colPix.Add cpxNew
picMap.PSet (cpxNew.PixelX, cpxNew.PixelY), lngFillColor
Set cpxNew = Nothing



End If
colPix.Remove (lngIndex)
End If
Loop
booInUse = False

Screen.MousePointer = 0
End If
End Sub
Private Sub SetPixel(sglMyX As Single, sglMyY As Single, lngBorderColor As Long, lngFillColor As Long)
Dim lngNextDoor As Long

picMap.PSet (sglMyX, sglMyY), lngFillColor
'get left pixel
lngNextDoor = picMap.Point(sglMyX - 1, sglMyY)
If lngNextDoor <> lngBorderColor And lngNextDoor <> lngFillColor Then
DoEvents
SetPixel sglMyX - 1, sglMyY, lngBorderColor, lngFillColor
End If
'get Top pixel
lngNextDoor = picMap.Point(sglMyX, sglMyY - 1)
If lngNextDoor <> lngBorderColor And lngNextDoor <> lngFillColor Then
DoEvents
SetPixel sglMyX, sglMyY - 1, lngBorderColor, lngFillColor
End If
'get Right pixel
lngNextDoor = picMap.Point(sglMyX + 1, sglMyY)
If lngNextDoor <> lngBorderColor And lngNextDoor <> lngFillColor Then
DoEvents
SetPixel sglMyX + 1, sglMyY, lngBorderColor, lngFillColor
End If
'get Bottom pixel
lngNextDoor = picMap.Point(sglMyX, sglMyY + 1)
If lngNextDoor <> lngBorderColor And lngNextDoor <> lngFillColor Then
DoEvents
SetPixel sglMyX, sglMyY + 1, lngBorderColor, lngFillColor
End If
End Sub

Private Sub picMap_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
sglX = X
sglY = Y
End Sub


Private Sub vscPic_Change()
picMap.Top = vscPic.Value * -1
End Sub

3)Save notepad as &quot;frmMain.frm&quot; in folder.
4)Repeat with following code and save as &quot;clsPix.cls&quot;:
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = &quot;clsPix&quot;
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Private sglMyX As Single
Private sglMyY As Single


Public Property Get PixelX() As Single
PixelX = sglMyX
End Property

Public Property Let PixelX(ByVal sglYourX As Single)
sglMyX = sglYourX
End Property
Public Property Get PixelY() As Single
PixelY = sglMyY
End Property

Public Property Let PixelY(ByVal sglYourY As Single)
sglMyY = sglYourY
End Property


4) Open a VB project, ADD frmMain and clsPix to it and set frmMain as the start-up.

5) Put one of your Maps (make sure it's a .gif) in the folder. Rename it &quot;WOK400.gif&quot;(I downloaded WOK400.gif from your site. Nice Site, by the way). This program assumes that the borders are drawn in &quot;BLACK&quot; (Color=0)

6) Run it.
Click &quot;Load Picture&quot;.
Select a Player.
click on a territory.

Notes:
Avoid clicking on the background. Could take a LOOOOOOOOOOOOng time!!!
This won't color the ID squares inside the map, unless you click IN the ID square.
I didn't write the &quot;Save&quot; routine, but it's simple. If you need help, holler! Also, as to saving, I only know how to save it as a bit-map, so you might have to find some kind of software to convert to .jpeg, such as MS Photo Editor or whatever.
You can reach me at jtlarkin@reachme.net
Like I said, I don't know if you can use this, but I had fun writing it!
GL, Tim Larkin