is there a way to use VBA to export values of variables into an image file? Specifically, I have for each x and y position on a 2 dimensional map a value of either 0 or 1 and want to visualize this as a simple black and white image.
The only way I can think of that might somehow work (I'm pretty new to VBA programming) is to write the data in a worksheet and use conditionally formating, so if the value is 0 then the cell is black, if 1 then white and then after making the individual cells quadratic in size save the range using something like Range.CopyPicture. But I hope there's a better way to do this.
Yes, this is possible.
I don't quite know how your data is laid out, but I wrote some Subs that will write a bitmap file based on two-dimensional arrays. I chose bitmap because it has a very simple binary layout and you can then proceed to work with it with almost any image editing/processing software.
Pass a two-dimensional Boolean array to this Sub:
Option Explicit
Private Type BITMAPFILEHEADER
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Sub CreateBWBitmap(arr() As Boolean, fileName As String)
Dim width As Long, height As Long
height = UBound(arr, 1) + 1
width = UBound(arr, 2) + 1
Dim bmpFileHeader As BITMAPFILEHEADER
Dim bmpInfoHeader As BITMAPINFOHEADER
'Initialize BITMAPFILEHEADER
bmpFileHeader.bfType = &H4D42 ' "BM" in hexadecimal
bmpFileHeader.bfOffBits = 62 ' 14 for file header, 40 for info header, 8 for color table
bmpFileHeader.bfSize = bmpFileHeader.bfOffBits + ((((width + 31) \ 32) * 4) * height)
'Initialize BITMAPINFOHEADER
bmpInfoHeader.biSize = 40
bmpInfoHeader.biWidth = width
bmpInfoHeader.biHeight = height
bmpInfoHeader.biPlanes = 1
bmpInfoHeader.biBitCount = 1 ' Black and white
bmpInfoHeader.biCompression = 0 ' Uncompressed
bmpInfoHeader.biSizeImage = 0
bmpInfoHeader.biXPelsPerMeter = 0
bmpInfoHeader.biYPelsPerMeter = 0
bmpInfoHeader.biClrUsed = 2
bmpInfoHeader.biClrImportant = 2
'Create color table (black and white)
Dim colorTable(1) As Long
colorTable(0) = vbBlack
colorTable(1) = vbWhite
'Create the pixel data
Dim rowData As Long
rowData = (((width + 31) \ 32) * 4)
Dim pixelData() As Byte
ReDim pixelData(rowData * height - 1)
Dim i As Long, j As Long, bit As Long, bytePos As Long, bitPos As Long
For i = 0 To height - 1
For j = 0 To width - 1
bit = IIf(arr(height - 1 - i, j), 1, 0)
bytePos = (rowData * i) + (j \ 8)
bitPos = 7 - (j Mod 8)
pixelData(bytePos) = pixelData(bytePos) Or (bit * (2 ^ bitPos))
Next j
Next i
'Write the data to the file
Dim f As Integer
f = FreeFile
Open fileName For Binary Access Write As #f
Put #f, , bmpFileHeader
Put #f, , bmpInfoHeader
Put #f, , colorTable(0)
Put #f, , colorTable(1)
Put #f, , pixelData
Close #f
End Sub
This example sub will create a 10 * 10 checkboard pattern .bmp file on your desktop:
Sub TestCreateBWBitmap()
Dim arr(9, 9) As Boolean
Dim i As Long, j As Long
'Fill with checkboard pattern
For i = 0 To 9
For j = 0 To 9
arr(i, j) = ((i + j) Mod 2 = 0)
Next j
Next i
CreateBWBitmap arr, CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & "test.bmp"
End Sub
To create a full-color BMP, pass a two-dimensional Long array containing RGB values to this function: (again with the private types for faster copy-paste)
Private Type BITMAPFILEHEADER
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Sub CreateColorBitmap(arr() As Long, fileName As String)
Dim height As Long: height = UBound(arr, 1) + 1
Dim width As Long: width = UBound(arr, 2) + 1
Dim bmpFileHeader As BITMAPFILEHEADER
Dim bmpInfoHeader As BITMAPINFOHEADER
'Initialize BITMAPFILEHEADER
bmpFileHeader.bfType = &H4D42 '"BM" in hexadecimal
bmpFileHeader.bfOffBits = 54 '14 for file header, 40 for info header
bmpFileHeader.bfSize = bmpFileHeader.bfOffBits + (width * height * 3)
'Initialize BITMAPINFOHEADER
bmpInfoHeader.biSize = 40
bmpInfoHeader.biWidth = width
bmpInfoHeader.biHeight = height
bmpInfoHeader.biPlanes = 1
bmpInfoHeader.biBitCount = 24 'True color (24-bit)
bmpInfoHeader.biCompression = 0 'Uncompressed
bmpInfoHeader.biSizeImage = 0
bmpInfoHeader.biXPelsPerMeter = 0
bmpInfoHeader.biYPelsPerMeter = 0
bmpInfoHeader.biClrUsed = 0
bmpInfoHeader.biClrImportant = 0
'Create the pixel data
Dim rowData As Long: rowData = width * 3
'Add padding for DWORD alignment
If rowData Mod 4 <> 0 Then rowData = rowData + 4 - (rowData Mod 4)
Dim pixelData() As Byte: ReDim pixelData(rowData * height - 1)
Dim i As Long, j As Long
For i = 0 To height - 1
For j = 0 To width - 1
Dim color As Long: color = arr(height - 1 - i, j)
Dim bytePos As Long: bytePos = rowData * i + j * 3
pixelData(bytePos) = (color And &HFF0000) \ &H10000 'Blue
pixelData(bytePos + 1) = (color And &HFF00&) \ &H100 'Green
pixelData(bytePos + 2) = color And &HFF 'Red
Next j
Next i
'Write the data to the file
Dim f As Integer: f = FreeFile
Open fileName For Binary Access Write As #f
Put #f, , bmpFileHeader
Put #f, , bmpInfoHeader
Put #f, , pixelData
Close #f
End Sub
I created an example sub that makes a BMP containing a color-, brightness- and saturation gradient:
Sub CreateRainbowGradientBitmap()
Const width As Long = 1000
Const height As Long = 1000
Dim arr() As Long
ReDim arr(height - 1, width - 1)
Dim i As Long, j As Long
Dim h As Double, s As Double, l As Double
For i = 0 To height - 1
For j = 0 To width - 1
h = 360# * (j / (width - 1)) ' Hue ranges from 0 to 360
s = 100 ' Saturation is fixed at 100 for a full gradient
l = i / (height - 1) * 100 ' Lightness ranges from 0 to 100
arr(i, j) = hslToRgb(h, s, l)
Next j
Next i
CreateColorBitmap arr, CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & "test.bmp"
End Sub
'adapted from: http://www.easyrgb.com/
Public Function hslToRgb(ByVal hue As Double, _
ByVal saturation As Double, _
ByVal lightness As Double) As Long
Dim h As Double: h = hue / 360
Dim s As Double: s = saturation / 100
Dim l As Double: l = lightness / 100
If h < 0 Or h > 1 Then Err.Raise 5, "hueToRgb", "Invalid hue value."
If s < 0 Or s > 1 Then Err.Raise 5, "hueToRgb", "Invalid saturation value."
If l < 0 Or l > 1 Then Err.Raise 5, "hueToRgb", "Invalid lightness value."
If s = 0 Then
Dim red As Double: red = l * 255
Dim green As Double: green = l * 255
Dim blue As Double: blue = l * 255
Else
Dim x2 As Double
If l < 0.5 Then
x2 = l * (1 + s)
Else
x2 = (l + s) - (l * s)
End If
Dim x1 As Double: x1 = 2 * l - x2
red = 255 * hueToRgb(x1, x2, h + (1 / 3))
green = 255 * hueToRgb(x1, x2, h)
blue = 255 * hueToRgb(x1, x2, h - (1 / 3))
End If
hslToRgb = RGB(red, green, blue)
End Function
'Helper function for hslToRgb.
'adapted from: http://www.easyrgb.com/
Private Function hueToRgb(a As Double, b As Double, h As Double) As Double
If h < 0 Then h = h + 1
If h > 1 Then h = h - 1
If (6 * h < 1) Then
hueToRgb = a + (b - a) * 6 * h
ElseIf (2 * h < 1) Then
hueToRgb = b
ElseIf (3 * h < 2) Then
hueToRgb = a + (b - a) * ((2 / 3) - h) * 6
Else
hueToRgb = a
End If
End Function