Недавно на работе возникла необходимость перелопатить несколько тысяч изображений, находящихся в БД из JPEGa в GIF с целью уменьшения занимаемого ими места. Но, если просто пересохранять с полной цветовой палитрой формата GIF (т.е. 256 цветов), то толка никакого не будет, т.е. размер не уменьшится. В связи с этим необходимо изменять цветовую палитру на более простую - монохромную и малоцветную, т.е. 2-10 цветов. В MSDN как раз есть статья на эту тему - How to save a .gif file with a new color table by using Visual C# (спасибо bazile за подсказку). Все бы в этой статье хорошо, да вот только пример написан на C# и комменты на английском. После небольшого обдумывания и разбора решил перевести ее на VB.NET. Ниже следует получившийся код. Производительность что на VB, что на C# - абсолютно одинаковая. И еще. Если запускать из IDE, то будут жуткие тормоза (приблизительно в 10-15 раз). В релизе же, при запуске ЕХЕшника, работает достаточно быстро. Не фотошоп, конечно, но вполне приемлемо. К примеру, картинка размером 1024*768 обрабатывается в течение 2 секунд.
Imports System.Drawing.Imaging
Module mdlGIF
Function GetColorPalette(ByVal nColors As UInteger) As ColorPalette
Dim bitscolordepth As PixelFormat = PixelFormat.Format1bppIndexed
Dim pal As ColorPalette 'Палитру мы своруем чуть ниже
Dim bmp As Bitmap 'Воровать будем отсюда
'Устанавливаем количество цветов
If (nColors > 2) Then bitscolordepth = PixelFormat.Format4bppIndexed
If (nColors > 16) Then bitscolordepth = PixelFormat.Format8bppIndexed
'Создаем новую картинку, чтобы своровать с нее палитру
bmp = New Bitmap(1, 1, bitscolordepth)
pal = bmp.Palette 'Воруем
bmp.Dispose() 'Заметаем следы
Return pal 'Отдаем палитру
End Function
Sub SaveGIFWithNewColorTable( _
ByVal img As Image, _
ByVal FileName As String, _
ByVal nColors As UInteger, _
ByVal fTransparent As Boolean _
)
'кодек GIF поддерживает от 2 до 256 цветов
If (nColors > 256) Then nColors = 256
If (nColors < 2) Then nColors = 2
'создаем новый индексированый bitmap такого же размера, как и исходная картинка
'в нем мы будем рисовать наш монохромный гиф с заданным количеством цветов
Dim Width As Integer = img.Width
Dim Height As Integer = img.Height
'всегда используйте PixelFormat8bppIndexed потому как
'именно этот формат нужен для GIF
Dim bmp As Bitmap = New Bitmap(Width, _
Height, _
PixelFormat.Format8bppIndexed)
'Получаем палитру с заданным количеством цветов
Dim pal As ColorPalette = GetColorPalette(nColors)
'Инициализируем палитру, т.е. задаем ей цвета.
'Для примера используется градация серого, но можно использовать любой
'другой алгоритм для задания цветов палитры
Dim Alpha As UInteger, Intensity As UInteger
For i As UInteger = 0 To nColors - 1
'непрозрачность
Alpha = &HFF
'равномерно распределяем интенсивность (серость)
Intensity = i * &HFF / (nColors - 1)
'если нужно, сделаем первый цвет прозрачным
If (i = 0 And fTransparent) Then Alpha = 0
'задаем цвет
pal.Entries(i) = Color.FromArgb(CInt(Alpha), CInt(Intensity), CInt(Intensity), CInt(Intensity))
Next
'присваиваем палитру битмэпу
bmp.Palette = pal
'Далее будем использовать GetPixel для узнавания цвета
'пикселя в нужных координатах на исходной картинке,
'чтобы потом преобразовать его в соответствующий оттенок серого.
'Для этих операций содадим копию исходной картинки в битмэпе
'с форматом PixelFormat32BppARGB
Dim BmpCopy As Bitmap = New Bitmap(Width, _
Height, _
PixelFormat.Format32bppArgb)
Dim g As Graphics = Graphics.FromImage(BmpCopy)
g.PageUnit = GraphicsUnit.Pixel
'копируем исходную картинку в новый битмэп
g.DrawImage(img, 0, 0, Width, Height)
'уничтожаем Graphics
g.Dispose()
'далее самая интересная часть - прорисовка GIF
'для начала получим объект BitmapData, точкам которого будем указывать
'индексы цветов
Dim bmd As BitmapData = _
bmp.LockBits(New Rectangle(0, 0, Width, Height), System.Drawing.Imaging.ImageLockMode.WriteOnly, bmp.PixelFormat)
'в pixel будем класть цвет на текущих координатах
Dim pixel As Color
'luminance - некий коэффициент (а точнее - оттенок серого),
'рассчитываемый по определенной формуле для правильного цвета в оттенок серого.
Dim luminance As Double
'указатель на начало данных в пямяти
Dim ip As IntPtr = bmd.Scan0
'Stride - свойство, показывающее длину одной строки, увеличеное до кратности 4
'Если оно положительное, то картинка расположена сверху вниз,
'в противном случае - снизу вверх. Для учета проделываем небольшую проверку:
If (bmd.Stride > 0) Then
ip = bmd.Scan0
Else
ip = New IntPtr(bmd.Scan0.ToInt64 + bmd.Stride * (Height - 1))
End If
'В эту переменную мы положим абсолютную величину Stride
Dim Stride As UInteger = Math.Abs(bmd.Stride)
'Бегаем по картинке, сверху-вниз слева-направо
For row As UInteger = 0 To BmpCopy.Height - 1
For col As UInteger = 0 To BmpCopy.Width - 1
'получаем цвет текущего пикселя
pixel = BmpCopy.GetPixel(col, row)
'с помощью нехитрой формулы преобразовываем его в серый цвет
luminance = (pixel.R * 0.299) + _
(pixel.G * 0.587) + _
(pixel.B * 0.114)
'записываем в BitmapData вычесленный индекс цвета
'Параметры функции: Адрес начала области памяти, Отступ,
'Вычеслинный индекс цвета в нашей ранее заданной палитре
'Индекс так вычисляется именно для ЧБ палитры!
'Если же Вы хотите использовать другой алгоритм -
'не забудьте заменить эту строку
Runtime.InteropServices.Marshal.WriteByte(ip, _
CInt(Stride * row + col), _
CByte(Int(luminance * (nColors - 1) / 255 + 0.5)))
Next col
Next row
'Сохраняем изменения
bmp.UnlockBits(bmd)
'Сохраняем
bmp.Save(FileName, ImageFormat.Gif)
'Убиваем объекты
BmpCopy.Dispose()
bmp.Dispose()
End Sub
End Module