Merry xmas
And i made it myself
always the best kind of gift.
p.s. my dome has xmas lights on it
Code:
Private Function Bmp2Raw(BmpPath$, RawPath$)
BmpNum = FreeFile
Open BmpPath$ For Binary As BmpNum
'''''''''''''''''''''File header'''''''''''''''''''''''
'this is the file type: must be BM
bfType$ = String(2, 0)
Get #BmpNum, , bfType$
If bfType$ <> "BM" Then
MsgBox "Invalid Bin Type", , "Error..."
Exit Function
End If
'Specifys the size of the bmp file
FourSize$ = String(4, 0)
Get #BmpNum, , FourSize$
bfSize = FourByteNumber(FourSize$)
'these are two 2byte things that must be 0
Get #BmpNum, , FourSize$
'This tells the offset of the bitmap data : usually 1078
Get #BmpNum, , FourSize$
bfOffBits = FourByteNumber(FourSize$)
''''''''''''''Info'Header'''''''''''''''''''''''''''''
'size of this second header - the info of the bmp
Get #BmpNum, , FourSize$
biSize = FourByteNumber(FourSize$)
'Width of the image in pixles
Get #BmpNum, , FourSize$
biWidth = FourByteNumber(FourSize$)
If biWidth Mod 4 <> 0 Then
MsgBox "BMP Width not multipul of four.", , "Error"
Exit Function
End If
'Height of the image in pixles
Get #BmpNum, , FourSize$
biHeight = FourByteNumber(FourSize$)
If biHeight Mod 4 <> 0 Then
MsgBox "BMP Height not multipul of four.", , "Error"
Exit Function
End If
If biHeight <> biWidth Then
MsgBox "BMP is not square.", , "Error"
Exit Function
End If
'number of planes in the target device, must be 0
TwoSize$ = String(2, 0)
Get #BmpNum, , TwoSize$
biPlanes = TwoByteNumber(TwoSize$)
If biPlanes <> 1 Then
MsgBox "Number of planes not one.", , "Error"
Exit Function
End If
'Bit count per pixle 8 is 256
Get #BmpNum, , TwoSize$
biBitCount = TwoByteNumber(TwoSize$)
If biBitCount <> 8 Then
MsgBox "Bits per pixle not 8. In other words this is not a 256 color BMP.", , "Error"
Exit Function
End If
'Compression Type
Get #BmpNum, , FourSize$
biCompression = FourByteNumber(FourSize$)
If biCompression <> 0 Then
MsgBox "A compressed BMP? Are you crazy?", , "Error"
Exit Function
End If
'Specifys the size of the bmp data 0 is ok if no compression
'65536 for a 256x256
'256 for a 16x16
Get #BmpNum, , FourSize$
biSizeImage = FourByteNumber(FourSize$)
If biSizeImage <> 0 And biSizeImage <> biWidth * biHeight Then
MsgBox "Somthing is screwy here...The height*width*8/8 isnt equal to the image size!", , "Error"
Exit Function
End If
'specifies the the horizontal pixels per meter on the designated targer device, usually set to zero.
Get #BmpNum, , FourSize$
biXPelsPerMeter = FourByteNumber(FourSize$)
'specifies the the vertical pixels per meter on the designated targer device, usually set to zero.
Get #BmpNum, , FourSize$
biYPelsPerMeter = FourByteNumber(FourSize$)
'specifies the number of colors used in the bitmap, if set to zero the number of colors is calculated using the biBitCount member.
Get #BmpNum, , FourSize$
biClrUsed = FourByteNumber(FourSize$)
'specifies the number of color that are 'important' for the bitmap, if set to zero, all colors are important.
Get #BmpNum, , FourSize$
biClrImportant = FourByteNumber(FourSize$)
'Ok, here's the first fun part - write the ACT :)
ActPath$ = Left(RawPath$, Len(RawPath$) - 3) & "ACT"
If Dir$(ActPath$) <> "" Then Kill ActPath$
ActNum = FreeFile
Open ActPath$ For Binary As ActNum
For Colour = 1 To 256
Red$ = String(1, 0)
Get #BmpNum, , Red$
Green$ = String(1, 0)
Get #BmpNum, , Green$
Blue$ = String(1, 0)
Get #BmpNum, , Blue$
Reserved$ = String(1, 0)
Get #BmpNum, , Reserved$
Put #ActNum, , Blue$
Put #ActNum, , Green$
Put #ActNum, , Red$
Next Colour
Close ActNum
'Ok, here's the second fun part - write the RAW :)
For Rows = 1 To biHeight
Row$ = String(biWidth, 0)
Get #BmpNum, , Row$
RowSum$ = Row$ & RowSum$
Next Rows
If Dir$(RawPath$) <> "" Then Kill RawPath$
RawNum = FreeFile
Open RawPath$ For Binary As RawNum
Put #RawNum, , RowSum$
Close ActNum
Close BmpNum
End Function
Private Function Raw2Bmp(RawPath$, ActPath$, BmpPath$)
DoEvents
'This function will take:
' a raw file RawPath$ and a
' an adobe color table (act) file ActPath$
' and export a bmp to BmpPath$
'A RAW file is an image file with no dimensions or color info
' it is assumed to be square, so we take the len of the file
' and squarert it to get the height and width. Each byte in a RAW
' is a pixle, it's color is the nth color in the ACT - n being
' the value of the byte. I believe that the pixles go from left
' to right and then top to bottom.
'An ACT file has 255 sets of 3 bytes - 1 set for each color, RGB
' therefor the first set will start at 0 (1 in vb) and the last
' will start with 765 (766 in vb), So to figure out the number
' of colors do the len of the file divided by 3 and subtract 1
'-------Loading ACT Colors:
Dim ActRed(255) 'Holds 256 Red Values from the ACT (locations: 0,3,6,9...765 in act (1,4,7,10,767 in vb))
Dim ActGreen(255) 'Holds 256 Green Values from the ACT(locations: 0,3,6,9...765 in act (1,4,7,10,767 in vb))
Dim ActBlue(255) 'Holds 256 Blue Values (locations: 0,3,6,9...765 in act (1,4,7,10,767 in vb))
StatusBar1.SimpleText = "Reading ACT..."
'Opens ACT file for Binary :)
ActFileNum = FreeFile
Open ActPath$ For Binary As #ActFileNum
'Since there are 3 bytes per color - This should usually be 256.
NumOfColors = LOF(ActFileNum) / 3
'One time through loop for each color in table.
'Store in 0-255 instad of 1-256
For Ind = 0 To NumOfColors - 1
ActRed(Ind) = Asc(Input$(1, #ActFileNum)) 'get red
ActGreen(Ind) = Asc(Input$(1, #ActFileNum)) 'and green
ActBlue(Ind) = Asc(Input$(1, #ActFileNum)) 'and blue
Next Ind
Close #ActFileNum
'Uncomment this to have it print a msgbox with all the act values.
'Message = "ACT Values: "
'For i = 0 To NumOfColors - 1
' Message = Message & "Index: " & i
' Message = Message & Str$(ActRed(i)) & ","
' Message = Message & Str$(ActGreen(i)) & ","
' Message = Message & Str$(ActBlue(i)) & " "
'Next i
'MsgBox (Message)
'-------Loading RAW Index Table
StatusBar1.SimpleText = "Reading RAW..."
'Dim PixelIndex(262144) 'Stores the index numbers (with values of 0-255)
' (one per pixel)
'Make enough room for a 512x512 Raw!
NumOfPixels = FileLen(RawPath$)
If Sqr(NumOfPixels) <> Int(Sqr(NumOfPixels)) Then
MsgBox ("RAW is not square, quitting operation.")
Raw2Bmp = 0
Exit Function
End If
If NumOfPixels / 4 <> Int(NumOfPixels / 4) Then
MsgBox ("Width of RAW not evenly divisable by four, quitting operation.")
Exit Function
End If
RawPathNum = FreeFile
Open RawPath$ For Binary As #RawPathNum
NumOfPixels = LOF(RawPathNum) 'So we can use that latter
For i = 1 To LOF(RawPathNum) / Sqr(NumOfPixels)
'PixelIndex(i) = Asc(Input$(1, #RawPathNum)) 'Get that pixel
ThisData$ = Input$(Sqr(NumOfPixels), #RawPathNum) & ThisData$
Next i
'ThisData$ = ThisData$ & Input$(256, #RawPathNum)
Close #RawPathNum
MyHeight = Sqr(NumOfPixels)
MyWidth = Sqr(NumOfPixels)
'Prints a msgbox with the pixel indicies:
'Message = "RAW Indicies: "
'For i = 1620 To 1700
' Message = Message & Str$(PixelIndex(i)) & ","
'Next i
'MsgBox (Message)
StatusBar1.SimpleText = "Writing BMP..."
'-------Save the BMP!!!!!!!!
'Heres where i got my BMP File Format info:
' http://www.fortunecity.com/skyscraper/windows/364/bmpffrmt.html
RowLength = MyWidth 'this is used for storing the DBI later.
RowExtra = 0 'keeping trck of how many 00's are added
Do While RowLength / 4 <> Int(RowLength / 4) 'has to be multipul of 4
RowLength = RowLength + 1 'you'll undertand later
RowExtra = RowExtra + 1
Loop
If Dir$(BmpPath$) <> "" Then Kill BmpPath$
BmpFileNum = FreeFile
Open BmpPath$ For Binary As #BmpFileNum
Dim FourLong As String * 4
Dim TwoLong As String * 2
'The BITMAPFILEHEADER:
'start size name stdvalue purpose
' 1 2 bfType 19778 must always be set to 'BM' to declare that this is a .bmp-file.
' 3 4 bfSize ?? specifies the size of the file in bytes.
' 7 2 bfReserved1 0 must always be set to zero.
' 9 2 bfReserved2 0 must always be set to zero.
' 11 4 bfOffBits 1078 specifies the offset from the beginning of the file to the bitmap data.
Dim bfType As String * 2
bfType$ = "BM" 'BMP ID
Put #BmpFileNum, , bfType$
bfSize = 14 'File Header
bfSize = bfSize + 40 'Info Header
bfSize = bfSize + 4 * (NumOfColors) 'rgbQuad
bfSize = bfSize + MyHeight * (RowLength) 'DBI
FourLong = Make4ByteString$(bfSize) 'PUT CODE HERE TO CONVERT TO 4 BYTE STRING!!!!!!!!
Put #BmpFileNum, , FourLong
bfReserved1 = String$(2, Chr$(0)) 'must always be set to zero
TwoLong = bfReserved1
Put #BmpFileNum, , TwoLong
bfReserved2 = String$(2, Chr$(0)) 'must always be set to zero
TwoLong = bfReserved2
Put #BmpFileNum, , TwoLong
bfOffBits = 1078 'specifies the offset from the beginning of the file to the bitmap data
' 1078 works for 8bit bmp files
bfOffBits = Make4ByteString$(bfOffBits) 'PUT CODE HERE TO CONVERT TO 4 BYTE STRING!!!!!!!!
FourLong = bfOffBits
Put #BmpFileNum, , FourLong
'The BITMAPINFOHEADER:
'start size name stdvalue purpose
' 15 4 biSize 40 specifies the size of the BITMAPINFOHEADER structure, in bytes.
' 19 4 biWidth 100 specifies the width of the image, in pixels.
' 23 4 biHeight 100 specifies the height of the image, in pixels.
' 27 2 biPlanes 1 specifies the number of planes of the target device, must be set to zero.
' 29 2 biBitCount 8 specifies the number of bits per pixel.
' 31 4 biCompression 0 Specifies the type of compression, usually set to zero (no compression).
' 35 4 biSizeImage 0 specifies the size of the image data, in bytes. If there is no compression, it is valid to set this member to zero.
' 39 4 biXPelsPerMeter 0 specifies the the horizontal pixels per meter on the designated targer device, usually set to zero.
' 43 4 biYPelsPerMeter 0 specifies the the vertical pixels per meter on the designated targer device, usually set to zero.
' 47 4 biClrUsed 0 specifies the number of colors used in the bitmap, if set to zero the number of colors is calculated using the biBitCount member.
' 51 4 biClrImportant 0 specifies the number of color that are 'important' for the bitmap, if set to zero, all colors are important.
biSize = 40 'specifies the size of the BITMAPINFOHEADER structure, in bytes.
biSize = Make4ByteString$(biSize) 'PUT CODE HERE TO CONVERT TO 4 BYTE STRING!!!!!!!!
FourLong = biSize
Put #BmpFileNum, , FourLong
biWidth = MyWidth 'specifies the width of the image, in pixels.
biWidth = Make4ByteString$(biWidth) 'PUT CODE HERE TO CONVERT TO 4 BYTE STRING!!!!!!!!
FourLong = biWidth
Put #BmpFileNum, , FourLong
biHeight = MyHeight 'specifies the height of the image, in pixels.
biHeight = Make4ByteString$(biHeight) 'PUT CODE HERE TO CONVERT TO 4 BYTE STRING!!!!!!!!
FourLong = biHeight
Put #BmpFileNum, , FourLong
biPlanes = 1 'specifies the number of planes of the target device, must be set to zero.
biPlanes = Make2ByteString(biPlanes) 'PUT CODE HERE TO CONVERT TO 2 BYTE STRING!!!!!!!!
TwoLong = biPlanes
Put #BmpFileNum, , TwoLong
biBitCount = 8 'specifies the number of bits per pixel.
biBitCount = Make2ByteString(biBitCount) 'PUT CODE HERE TO CONVERT TO 2 BYTE STRING!!!!!!!!
TwoLong = biBitCount
Put #BmpFileNum, , TwoLong
biCompression = String$(4, Chr$(0)) '<
FourLong = biCompression
Put #BmpFileNum, , FourLong
biSizeImage = String$(4, Chr$(0)) '< See above for
FourLong = biSizeImage
Put #BmpFileNum, , FourLong
biXPelsPerMeter = String$(4, Chr$(0)) '< why these have
FourLong = biXPelsPerMeter
Put #BmpFileNum, , FourLong
biYPelsPerMeter = String$(4, Chr$(0)) '< values of 0
FourLong = biYPelsPerMeter
Put #BmpFileNum, , FourLong
biClrUsed = NumOfColors 'Number of colors
biClrUsed = Make4ByteString$(biClrUsed) 'PUT CODE HERE TO CONVERT TO 4 BYTE STRING!!!!!!!!
FourLong = biClrUsed
Put #BmpFileNum, , FourLong
biClrImportant = String$(4, Chr$(0)) '<
FourLong = biClrImportant
Put #BmpFileNum, , FourLong
'The RGBQUAD array:
'start size name stdvalue purpose
' 1 1 rgbBlue - specifies the blue part of the color.
' 2 1 rgbGreen - specifies the green part of the color.
' 3 1 rgbRed - specifies the red part of the color.
' 4 1 rgbReserved - must always be set to zero.
Dim OneLong As String * 1
For Colour = 0 To NumOfColors - 1
rgbBlue = ActBlue(Colour)
rgbBlue = Chr$(rgbBlue)
OneLong = rgbBlue
Put #BmpFileNum, , OneLong
rgbGreen = ActGreen(Colour)
rgbGreen = Chr$(rgbGreen)
OneLong = rgbGreen
Put #BmpFileNum, , OneLong
rgbRed = ActRed(Colour)
rgbRed = Chr$(rgbRed)
OneLong = rgbRed
Put #BmpFileNum, , OneLong
rgbReserved = String$(4, Chr$(0))
OneLong = rgbReserved
Put #BmpFileNum, , OneLong
Next Colour
'Now the bitmap data! Finaly!
'Some notes on the way it's stored:
'In 8-bit mode every byte represents a pixel.
' The value points to an entry in the color table
' which contains 256 entries
'It is important to know that the rows of a DIB are stored
' upside down. That means that the uppest row which appears
' on the screen actually is the lowest row stored in the bitmap
'Another important thing is that the number of bytes in one row
' must always be adjusted to fit into the border of a multiple
' of four. You simply append zero bytes until the number of
' bytes in a row reaches a multiple of four, an example:
' 6 bytes that represent a row in the bitmap: A0 37 F2 8B 31 C4
' must be saved as: A0 37 F2 8B 31 C4 00 00
' to reach the multiple of four which is the next higher after six (eight).
'ThisData$ = ""
'StatusBar1.SimpleText = "Writing Pixels..."
'Progress.Max = NumOfPixels
'Progress.Value = 0
'For Row = MyHeight - 1 To 0 Step -1
' For Col = 0 To MyWidth - 1
' StatusBar1.SimpleText = "Writing Pixel:" & Str$(Progress.Value) & " of" & Str$(Progress.Max)
' Progress.Value = Progress.Value + 1
' ThisData$ = ThisData$ & Chr$(PixelIndex(Row * MyWidth + Col))
' Next Col
' For X = 1 To RowExtra
' ThisData$ = ThisData$ & Chr$(0)
' Next X
'Next Row
'Progress.Value = 0
Put #BmpFileNum, , ThisData$
Close #BmpFileNum
StatusBar1.SimpleText = "Ready."
gPicContent$ = ""
Raw2Bmp = MyHeight
End Function
Private Function Make4ByteString$(MyNumber)
Hexa = Hex$(MyNumber)
Do While Len(Hexa) < 8
Hexa = "0" & Hexa
Loop
LittleEndien = Mid$(Hexa, 7, 2) & Mid$(Hexa, 5, 2) & Mid$(Hexa, 3, 2) & Mid$(Hexa, 1, 2)
Data$ = Chr(Val("&H" & Mid$(Hexa, 7, 2))) & Chr(Val("&H" & Mid$(Hexa, 5, 2))) & Chr(Val("&H" & Mid$(Hexa, 3, 2))) & Chr(Val("&H" & Mid$(Hexa, 1, 2)))
Make4ByteString$ = Data$
End Function
Public Function FourByteNumber(InputData$)
outputdata = 0
For X = 1 To 4
outputdata = outputdata + Asc(Mid$(InputData$, X, 1)) * 256 ^ (X - 1)
Next X
If outputdata > 2147483648# Then
outputdata = -1 * (4294967296# - outputdata)
End If
FourByteNumber = outputdata
End Function