This simple routine will create an image of a hex grid and save it to disk as a Windows bitmap. The file will be saved in the program's folder under the name "HexGrid.bmp". You can specify hexes of any size, with any number of rows and columns, in either horizontal or vertical orientation. You can choose to show the hex numbering, which will be in "xxyy" format starting with hex 0101 in the top left (the classic board war game format). The image will contain black hex outlines and numbering on a white background. The program has virtually no error-checking and is offered "as is".
[pbcode]
Constant white = RGB(255, 255, 255)
Constant black = RGB(8, 8, 8)
OpenScreen 500, 180, 16, 1
CenterScreen
TitleScreen "Draw Hex Grid"
RenderToScreen
Cls white
Ink black
ScreenFont = GetFreeFont()
LoadFont "Arial", ScreenFont, 21, 0
SetFont ScreenFont
; get parameters from user:
request$ = "length in pixels of 1 hex side: "
answer$ = GetInputLine(30, 30, request$)
HexSide# = Val(answer$)
; horizontal orientation = flat hex sides are vertical
; vertical orientation = flat hex sides are horizontal
request$ = "hex orientation (H or V): "
answer$ = GetInputLine(30, 50, request$)
HexOrientation$ = Lower$(answer$)
; the following refers to a FULL row or column, i.e., one which is not offset
; from the map edge
request$ = "no. of hexes in 1 row: "
answer$ = GetInputLine(30, 70, request$)
NumHexesInRow = Val(answer$)
request$ = "no. of hexes in 1 column: "
answer$ = GetInputLine(30, 90, request$)
NumHexesInColumn = Val(answer$)
request$ = "show hex numbering (Y or N): "
answer$ = GetInputLine(30, 110, request$)
HexNumbering$ = Lower$(answer$)
; ------------------------------------------------------------------------------
Cls white
CenterText GetScreenWidth() / 2, 65, "Working ..."
Sync
hexnumFont = GetFreeFont()
LoadFont "Arial", hexnumFont, 12, 0
SetFont hexnumFont
HexApothem# = Cos(30) * HexSide#
HexCutoff# = Sin(30) * HexSide#
RemStart
NOTE that for a regular hexagon created by CreateConvexShape the GetShapeVertexX,Y
commands produce the HexCutoff# & HexApothem# respectively. That is the position
of the upper right vertex in relation to the center on a Cartesian grid.
The convex shape's handle is its center.
RemEnd
HexShape = GetFreeShape()
CreateConvexShape HexShape, HexSide#, 6
If HexOrientation$ = "h"
; HORIZONTAL ORIENTATION:
; PB draws hexes in Vertical Orientation
RotateShape HexShape, 90, 1
x = NumHexesInRow * (HexApothem# * 2) + 1
y = NumHexesInColumn * (HexSide# + HexCutoff#) + HexCutoff# + 1
CreateImage 1, x, y
RenderToImage 1
DrawGFXImmediate
Cls white
startX# = HexApothem#
startY# = HexCutoff# + HexSide# / 2
OffsetY# = HexCutoff# + HexSide#
col = 1 : row = 1 : hexnum = 101
Repeat
If Even(row)
; remember - the shape's handle is its center
OffsetX# = HexApothem#
Else
OffsetX# = 0
EndIf
x# = startX# + (col - 1) * (HexApothem# * 2) + OffsetX#
y# = startY# + (row - 1) * OffsetY#
DrawShape HexShape, x#, y#, 1
If HexNumbering$ = "y"
CenterText x#, y# - HexApothem# / 1.5, Digits$(hexnum, 4)
EndIf
Inc col : hexnum = hexnum + 100
If (col > NumHexesInRow) Or (Even(row) And col = NumHexesInRow)
; every second row has 1 less hex
col = 1 : hexnum = 100 + row
Inc row : Inc hexnum
EndIf
Until row > NumHexesInColumn
Else
; vertical orientation
x = NumHexesInRow * (HexSide# + HexCutoff#) + HexCutoff# + 1
y = NumHexesInColumn * (HexApothem# * 2) + 1
CreateImage 1, x, y
RenderToImage 1
DrawGFXImmediate
Cls white
startX# = HexCutoff# + HexSide# / 2
startY# = HexApothem#
OffsetX# = HexCutoff# + HexSide#
col = 1 : row = 1 : hexnum = 101
Repeat
If Even(col)
OffsetY# = HexApothem#
Else
OffsetY# = 0
EndIf
x# = startX# + (col - 1) * OffsetX#
y# = startY# + (row - 1) * (HexApothem# * 2) + OffsetY#
DrawShape HexShape, x#, y#, 1
If HexNumbering$ = "y"
CenterText x#, y# - HexApothem# / 1.5, Digits$(hexnum, 4)
EndIf
Inc row : hexnum = hexnum + 1
If (row > NumHexesInColumn) Or (Even(col) And row = NumHexesInColumn)
; every second column has 1 less hex
row = 1 : hexnum = col * 100 + 1
Inc col : hexnum = hexnum + 100
EndIf
Until col > NumHexesInRow
EndIf
f$ = CurrentDir$() + "\HexGrid.bmp"
Save_Image_As_BitMap(f$, 1)
RenderToScreen
Cls white
Ink black
SetFont ScreenFont
Text 30, 30, "Done."
Text 30, 60, "The blank hex grid is saved in"
Text 30, 90, CurrentDir$() + "\HexGrid.bmp"
Sync
WaitAllInput Off, 7, On
End
; ------------------------------------------------------------------------------
Psub GetInputLine(xPos, yPos, request$)
RemStart
get 1 line of text input from user; <ENTER> ends the routine
xPos yPos are screen pixel positions; request$ = the text prompt
answer$ = the user input
RemEnd
RenderToScreen
DrawGFXImmediate
CaptureDepth 0
SetCursor xPos, yPos
Print request$
w = GetTextWidth(request$)
answer$ = ""
FlushKeys
Repeat
SetCursor xPos + w, yPos
x$ = Inkey$()
x = Asc(x$)
If x > 31 And x < 128
; check for a displayable character
answer$ = answer$ + x$
Print answer$
EndIf
FlushKeys
Sync
WaitKey
Until EnterKey()
FlushKeys
EndPsub answer$
; ------------------------------------------------------------------------------
Function Save_Image_As_BitMap(File$,ThisImage)
RemStart
This Function Saves an image buffer as a 32bit bitmap file.
If the 2nd param = 0, this saves a bitmap image of the screen.
RemEnd
If ThisImage=0
Status=True
Else
Status=GetImageStatus(ThisIMage)
EndIf
If Status
BmpWidth=GetImageWidth(ThisImage)
BmpHeight=GetImageHeight(ThisIMage)
If FileExist(file$)=1 Then DeleteFile file$
BmpWidth2=BmpWidth-1
BitDepth=32
Bytes=Bitdepth/8
ImageSize=BmpWidth*BmpHeight*Bytes
InfoHeaderSize=40
AbsFileSize=14+InfoHeaderSize+ImageSize
ThisFile=GetFreeFile()
WriteFile file$,ThisFile
WriteWord ThisFile,19778
WriteInt ThisFile,AbsFileSize
WriteInt ThisFile,UseLess
WriteInt ThisFile,54 : Rem START of GFX data (offset)
WriteInt ThisFile,InfoHeaderSize
WriteInt ThisFile,BmpWidth
WriteInt ThisFile,BmpHeight
WriteWord ThisFile,1 : Rem Planes
WriteWord ThisFile,BitDepth
WriteInt ThisFile,0 : Rem Compression (0=raw)
WriteInt ThisFile,ImageSize
WriteInt ThisFile,HPpM
WriteInt ThisFile,VPpM
WriteInt ThisFile,UsedColors
WriteInt ThisFile,ImportantColors
` -----------------
` Dump 32bit Bitmap
` -----------------
oldsurface=GetSurface()
RenderToImage ThisIMage
LockBuffer
For ylp=BmpHeight-1 To 0 Step -1
For xlp=0 To Bmpwidth2
WriteInt ThisFile,Point(xlp,ylp)
Next Xlp
Next Ylp
UnLockBuffer
RenderToImage OldSurface
CloseFile ThisFile
EndIf
EndFunction
; ==============================================================================
[/pbcode]
Hello,
It's working very well. Thank you Alex777 for your effort.
Have a nice day,
Tomaz
Thanks, Tomaz! Actually, I had to correct a bug and have reposted it, so if you need to use it you should d/l again.