Один бит на пиксель
Это дает наименьший возможный PNG только из .Net. Обратите внимание, что это ч / б - даже не в градациях серого. Полезно для документов.
Код потребителя:
Dim src = (the original bitmap)
Using img = New Bitmap(src.Width, src.Height, PixelFormat.Format16bppRgb555) ' Provided Make1bpp function requires this
img.SetResolution(src.HorizontalResolution, src.VerticalResolution)
Using g = Graphics.FromImage(img)
g.Clear(Color.White) ' remove transparancy
g.DrawImage(src, 0, 0, src.Width, src.Height)
End Using
Using img2 As Bitmap = Make1bpp(img)
img2.SetResolution(src.HorizontalResolution, src.VerticalResolution)
Dim myencoder = (From parm In ImageCodecInfo.GetImageEncoders() Where parm.MimeType = "image/png").First()
Dim encoderParams = New EncoderParameters(1)
encoderParams.Param(0) = New EncoderParameter(Encoder.ColorDepth, 8L)
If IO.File.Exists(pngName) Then
IO.File.Delete(pngName)
End If
img2.Save(pngName, myencoder, encoderParams)
End Using
End Using
Make1bpp
Об этом заботится кодировщик PNG
Function Make1bpp(ByVal bmpIN As Bitmap) As Bitmap
Dim bmpOUT As Bitmap
bmpOUT = NewBitmap(bmpIN.Width, bmpIN.Height, PixelFormat.Format1bppIndexed)
bmpOUT.SetResolution(bmpIN.HorizontalResolution, bmpIN.VerticalResolution)
' seems like I've got this crap in this program about 100x.
If bmpIN.PixelFormat <> PixelFormat.Format16bppRgb555 Then
Throw New ApplicationException("hand-coded routine can only understand image format of Format16bppRgb555 but this image is " & _
bmpIN.PixelFormat.ToString & ". Either change the format or code this sub to handle that format, too.")
End If
' lock image bytes
Dim bmdIN As BitmapData = bmpIN.LockBits(New Rectangle(0, 0, bmpIN.Width, bmpIN.Height), _
Imaging.ImageLockMode.ReadWrite, bmpIN.PixelFormat)
' lock image bytes
Dim bmdOUT As BitmapData = bmpOUT.LockBits(New Rectangle(0, 0, bmpOUT.Width, bmpOUT.Height), _
Imaging.ImageLockMode.ReadWrite, bmpOUT.PixelFormat)
' Allocate room for the data.
Dim bytesIN(bmdIN.Stride * bmdIN.Height) As Byte
Dim bytesOUT(bmdOUT.Stride * bmdOUT.Height) As Byte
' Copy the data into the PixBytes array.
Marshal.Copy(bmdIN.Scan0, bytesIN, 0, CInt(bmdIN.Stride * bmpIN.Height))
' > this val = white pix. (each of the 3 pix in the rgb555 can hold 32 levels... 2^5 huh.)
Dim bThresh As Byte = CByte((32 * 3) * 0.66)
' transfer the pixels
For y As Integer = 0 To bmpIN.Height - 1
Dim outpos As Integer = y * bmdOUT.Stride
Dim instart As Integer = y * bmdIN.Stride
Dim byteval As Byte = 0
Dim bitpos As Byte = 128
Dim pixval As Integer
Dim pixgraylevel As Integer
For inpos As Integer = instart To instart + bmdIN.Stride - 1 Step 2
pixval = 256 * bytesIN(inpos + 1) + bytesIN(inpos) ' DEPENDANT ON Format16bppRgb555
pixgraylevel = ((pixval) And 31) + ((pixval >> 5) And 31) + ((pixval >> 10) And 31)
If pixgraylevel > bThresh Then ' DEPENDANT ON Format16bppRgb555
byteval = byteval Or bitpos
End If
bitpos = bitpos >> 1
If bitpos = 0 Then
bytesOUT(outpos) = byteval
byteval = 0
bitpos = 128
outpos += 1
End If
Next
If bitpos <> 0 Then ' stick a fork in any unfinished busines.
bytesOUT(outpos) = byteval
End If
Next
' unlock image bytes
' Copy the data back into the bitmap.
Marshal.Copy(bytesOUT, 0, _
bmdOUT.Scan0, bmdOUT.Stride * bmdOUT.Height)
' Unlock the bitmap.
bmpIN.UnlockBits(bmdIN)
bmpOUT.UnlockBits(bmdOUT)
' futile attempt to free memory.
ReDim bytesIN(0)
ReDim bytesOUT(0)
' return new bmp.
Return bmpOUT
End Function