Option Explicit
'Demonstration of generating a black-and-white XBM graphics file
'under VBS control. Draw a winking happy face by filling a 15x15 array.
Dim MyArray()
Dim intRow, intCol
Dim strXbm, strImageData
Const IMAGE_HEIGHT = 15
Const IMAGE_WIDTH = 15
	'Create the image data in an easy to manipulate string format
	strImageData = ""
	strImageData = strImageData & "000000111000000"
	strImageData = strImageData & "000111000111000"
	strImageData = strImageData & "001000000000100"
	strImageData = strImageData & "001000000000100"
	strImageData = strImageData & "010010000000010"
	strImageData = strImageData & "010111000111010"
	strImageData = strImageData & "100010000000001"
	strImageData = strImageData & "100000000000001"
	strImageData = strImageData & "100000000000001"
	strImageData = strImageData & "010000000000010"
	strImageData = strImageData & "010011101110010"
	strImageData = strImageData & "010000111000010"
	strImageData = strImageData & "001100000001100"
	strImageData = strImageData & "000011000110000"
	strImageData = strImageData & "000000111000000"
	'Stuff the image data into an array
	ReDim MyArray(IMAGE_WIDTH, IMAGE_HEIGHT)
	For intRow = 0 To IMAGE_HEIGHT - 1
		For intCol = 0 To IMAGE_WIDTH - 1
			MyArray(intRow, intCol) = Mid(strImageData, (intCol + 1) + (intRow * IMAGE_WIDTH) , 1)
		Next
	Next
	'Now call the ArrayToXbm function to generate an XBM string
	strXbm = ArrayToXbm(MyArray)
	'Now save the string as a file so we can view it later.
	String2File strXbm, FileNameLikeMine("xbm")



Function ArrayToXbm(vArray)
'vArray must be a two dimensional array of ones and zeros 
'vArray is arranged in row, col. For example, in a 255x255 graphic, 
'top left of picture will be vArray(0,0) and top right is vArray(0,254) 
Dim intWidth
Dim intHeight
Dim strBuffer
Dim intBuffer
Dim intBitCount
Dim intRowCount
Dim intColCount
	intHeight = UBound(vArray, 1)
	intWidth = UBound(vArray, 2)
	strBuffer = "#define xbm_width " & ubound(vArray,1) & vbLf
	strBuffer = strBuffer & "#define xbm_height " & ubound(vArray,2) & vbLf
	strBuffer = strBuffer & "static char xbm_bits[] = {"
	For intRowCount = 0 To intHeight - 1
		For intColCount = 0 To intWidth - 1 Step 8
			intBuffer = 0
			For intBitCount = 0 To 7
				If ((intColCount + intBitCount) < intWidth) Then
					intBuffer = intBuffer + vArray(intRowCount, intColCount + intBitCount) * (2^intBitCount)
				End If
			Next
			strBuffer = strBuffer & "0x" & Right("00" & Hex(intBuffer), 2) & ", "
		Next
	Next
	'Remove the trailing comma and space
	strBuffer = Left(strBuffer, Len(strBuffer) - 2)
	strBuffer = strBuffer & "};"
	ArrayToXbm = strBuffer
End Function 

Function FileNameLikeMine(strFileExtension) 'As String
'Returns a file name the same as the script name except
'for the file extension. 
Dim fs 'As Object
Dim strExtension 'As String
	Set fs = CreateObject("Scripting.FileSystemObject")
	strExtension = strFileExtension
	If Len(strExtension) < 1 Then strExtension = "txt"
	If strExtension = "." Then strExtension = "txt"
	If Left(strExtension,1) = "." Then strExtension = Mid(strExtension, 2)
	FileNameLikeMine = Left(Wscript.ScriptFullName, InstrRev(Wscript.ScriptFullName, ".")) & strExtension
End Function

Sub String2File(strData, strFileName)
'Writes a string to a file
Dim fs 'As Scripting.FileSystemObject
Dim ts 'As Scripting.TextStream
Const ForWriting = 2
	Set fs = CreateObject("Scripting.FileSystemObject")
	Set ts = fs.OpenTextFile(strFileName, ForWriting, True)
	ts.Write(strData)
	ts.Close
End Sub