Option Explicit 'Demonstration of generating a black-and-white PBM (portable bitmap) graphics file 'under VBS control. Draw a winking happy face by filling a 15x15 array. Dim MyArray() Dim intRow, intCol Dim strPbm, 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 strPbm = ArrayToPbm(MyArray) 'Now save the string as a file so we can view it later. String2File strPbm, FileNameLikeMine("pbm") Function ArrayToPbm(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) 'PBM string generated will be of the "P1" (text black and white) type. Dim intWidth Dim intHeight Dim strBuffer Dim intBuffer Dim intRowCount Dim intColCount intHeight = UBound(vArray, 1) intWidth = UBound(vArray, 2) strBuffer = "P1 " & intWidth & " " & intHeight & " " & vbCrLf For intRowCount = 0 To intHeight - 1 For intColCount = 0 To intWidth - 1 strBuffer = strBuffer & vArray(intRowCount, intColCount) & " " Next strBuffer = strBuffer & vbCrLf Next ArrayToPbm = 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