| 'Properties
' Width
' Height
'
'Methods
' PiSet - Sets the value of a given pixel
' LoadImageAndData - Loads an existing image, along with extra
' data embedded in the file
' SaveImage - Saves image, optionally as 16-bit, and/or embedding
' extra data into the file
Option Explicit
Private m_nWidth As Long
Private m_nHeight As Long
Private m_nBMP() As Byte
Public Sub PiSet(x As Long, y As Long, R As Byte, G As Byte, B As Byte)
If Not (x >= 0 And x < m_nWidth) Then
Exit Sub
End If
If Not (y >= 0 And y < m_nHeight) Then
Exit Sub
End If
m_nBMP(0, x, y) = B
m_nBMP(1, x, y) = G
m_nBMP(2, x, y) = R
End Sub
Public Sub LoadImageAndData(sFilename As String, _
sExtraData As String, nExtraLen As Long)
Dim nFN As Long
Dim x As Long, y As Long
Dim sTemp As String
Dim nColor As Long
Dim nPos As Long
Dim nPadding As Long
nFN = FreeFile
Open sFilename For Binary As #nFN
sTemp = Input(FileLen(sFilename), #nFN)
Close #nFN
m_nWidth = AscV(Mid(sTemp, 19, 4))
m_nHeight = AscV(Mid(sTemp, 23, 4))
nPadding = (AscV(Mid(sTemp, 35, 4)) / 3 / m_nHeight) - m_nWidth
SetupBuffer
sExtraData = Mid(sTemp, 55, nExtraLen)
nPos = AscV(Mid(sTemp, 11, 4)) + 1
For y = m_nHeight - 1 To 0 Step -1
For x = 0 To m_nWidth - 1
For nColor = 0 To 2
m_nBMP(nColor, x, y) = Asc(Mid(sTemp, nPos, 1))
nPos = nPos + 1
Next
Next
For x = 1 To nPadding
nPos = nPos + 3
Next
DoEvents
Next
End Sub
Public Sub SaveImage(sFilename As String, Optional b16 As Boolean = _
False, Optional sExtraData As String = "")
Dim x As Long, y As Long
Dim nColor As Long
Dim sTemp As String
Dim nPadding As Long
Dim nPos As Long
Do While ((m_nWidth + nPadding) * 3) / 4 <> _
((m_nWidth + nPadding) * 3) \ 4
nPadding = nPadding + 1
Loop
sTemp = "BM" '1
sTemp = sTemp & ChrV(0, 4) ' Size of file '3
sTemp = sTemp & ChrV(0, 4) ' Reserved '7
sTemp = sTemp & ChrV(0, 4) ' Offset to data '11
sTemp = sTemp & ChrV(40, 4) ' Size of structure '15
sTemp = sTemp & ChrV(m_nWidth, 4) ' Width '19
sTemp = sTemp & ChrV(m_nHeight, 4) ' Height '23
sTemp = sTemp & ChrV(1, 2) ' Planes '27
sTemp = sTemp & ChrV(24, 2) ' Bitcount '29
sTemp = sTemp & ChrV(0, 4) ' Compression '31
sTemp = sTemp & ChrV(m_nHeight * (m_nWidth + nPadding) * 3, 4)
' Size Image '35
sTemp = sTemp & ChrV(0, 4) ' XPels '39
sTemp = sTemp & ChrV(0, 4) ' YPels '43
sTemp = sTemp & ChrV(0, 4) ' ClrUsed '47
sTemp = sTemp & ChrV(0, 4) ' ClrImportant '51
If sExtraData <> "" Then
sTemp = sTemp & sExtraData
End If
Mid(sTemp, 11, 4) = ChrV(Len(sTemp), 4) ' Offset to Data
nPos = Len(sTemp) + 1
sTemp = sTemp & String(m_nHeight * (m_nWidth + nPadding) * 3, Chr(0))
If b16 Then
For y = m_nHeight - 1 To 0 Step -1
For x = 0 To m_nWidth - 1
For nColor = 0 To 2
Mid(sTemp, nPos, 1) = Chr(RC(m_nBMP(nColor, x, y)))
nPos = nPos + 1
Next
Next
For x = 1 To nPadding
nPos = nPos + 3
Next
DoEvents
Next
Else
For y = m_nHeight - 1 To 0 Step -1
For x = 0 To m_nWidth - 1
For nColor = 0 To 2
Mid(sTemp, nPos, 1) = Chr(m_nBMP(nColor, x, y))
nPos = nPos + 1
Next
Next
For x = 1 To nPadding
nPos = nPos + 3
Next
DoEvents
Next
End If
Mid(sTemp, 3, 4) = ChrV(Len(sTemp), 4) 'Size of File
If Dir(sFilename) <> "" Then
Kill sFilename
End If
Dim nFN As Byte
nFN = FreeFile
Open sFilename For Output As #nFN
Print #nFN, sTemp;
Close #nFN
End Sub
Private Function ChrV(ByVal nNum As Long, nBytes As Long) As String
Dim i As Long
For i = 1 To nBytes
ChrV = ChrV & Chr(nNum And &HFF&)
nNum = nNum \ &H100&
Next
End Function
Private Function AscV(ByVal sString As String) As Long
Do Until Len(sString) = 0
AscV = AscV * &H100&
AscV = AscV + Asc(Right(sString, 1))
sString = Mid(sString, 1, Len(sString) - 1)
Loop
End Function
Public Property Let Height(nNewHeight As Long)
m_nHeight = nNewHeight
SetupBuffer
End Property
Public Property Get Height() As Long
Height = m_nHeight
End Property
Public Property Let Width(nNewWidth As Long)
m_nWidth = nNewWidth
SetupBuffer
End Property
Public Property Get Width() As Long
Width = m_nWidth
End Property
Private Sub SetupBuffer()
If m_nWidth = 0 Then
Exit Sub
End If
If m_nHeight = 0 Then
Exit Sub
End If
ReDim m_nBMP(0 To 3, 0 To m_nWidth - 1, 0 To m_nHeight - 1)
End Sub
Private Function RC(nColor As Byte) As Byte
Static nWhole As Byte
Static nPart As Byte
nWhole = nColor And &HF8&
nPart = nColor And &H7&
RC = nWhole + IIf(Rnd < (nPart / 8), IIf(nWhole = 248, 7, 8), 0)
End Function
|