; srod
; https://www.purebasic.fr/english/viewtopic.php?t=23387
!!!уже модернизировал, это не оригинал !!!

; SaveIcon.
; By Stephen Rodriguez 2006 (Обновлено 2010).
; Purebasic 4.5

; Этот небольшой include-файл позволяет сохранить один значок/курсор в файле .ico/.cur.
; Расширение, чтобы включить несколько значков/курсоров в один файл было бы простым.

; СИНТАКСИС: SaveIcon(hIcon, filename$)
; где hIcon — это дескриптор значка/курсора, загруженного из файла ресурсов или с помощью LoadImage_() и т. д.

; ПРИМЕЧАНИЕ.

; i) Эту библиотеку можно использовать только со значками/курсорами, которые уже хранятся в памяти.
; (либо загруженный с диска, либо созданный с помощью CreateIconIndirect_() и т. д.) и
; сохраняет значок/курсор в файл в том же формате (глубина и т. д.), что и хранящийся внутри Windows.

; Однако этот код можно "легко" адаптировать для создания значков/курсоров с нуля,
; используя Purebasic (где изображения хранятся в любом формате), а затем,
; используя адаптированный из этой библиотеки код, сохранять в формат .ico/.cur.
; Это просто вопрос возни с таблицами цветов и т. д.

;   ii) Если вы используете эту библиотеку для сохранения значка/курсора, загруженного с помощью LoadImage_(),
; может показаться, что новый значок/курсор имеет другой размер. Это произойдет потому, что исходный
; файл .ico/.cur содержит несколько значков разных размеров.
; Проводник Windows может сообщать об одном размере, пока вы загружаете другой и т. д.

; TODO (возможно!)
; -Расширьте код, чтобы сохранить несколько значков/курсоров в одном файле .ico.
; -Расширить до файлов .cur курсора (ГОТОВО!)
; **************************************************************************************************


; Результат = ненулевой, если нет ошибок.
Procedure.i SaveIcon(hIcon, filename$)
	Protected result, iconinfo.ICONINFO, hbmMask, hbmColor
	Protected cbitmap.BITMAP, cwidth, cheight, cbitsperpixel, colorcount, colorplanes
	Protected mbitmap.BITMAP, mwidth, mheight
	Protected file, imagebytecount, hdc, oldbitmap, mem, bytesinrow, temp
	Protected *bitmapinfo.BITMAPINFO
	; Получите информацию об иконке.
	If Not GetIconInfo_(hIcon, iconinfo)
    Debug 1
    ProcedureReturn 0
	EndIf ; Недопустимый дескриптор значка.
	; Выделите память для структуры BITMAPINFO + таблицы цветов на 256 записей.
	*bitmapinfo = AllocateMemory(SizeOf(BITMAPINFO) + SizeOf(RGBQUAD) << 8)
	If *bitmapinfo = 0
    ProcedureReturn 0
	EndIf
	; Получите растровое изображение маски (И), которое, если значок черно-белый монохромный, содержит цветное растровое изображение.
	hbmMask = iconinfo\hbmMask
	GetObject_(hbmMask, SizeOf(BITMAP), mbitmap)
	mwidth = mbitmap\bmWidth
	mheight = mbitmap\bmHeight
	; Получите цвет (XOR) bitmap.
	hbmColor = iconinfo\hbmColor
	If hbmColor
    GetObject_(hbmColor, SizeOf(BITMAP), cbitmap)
    cwidth = cbitmap\bmWidth
    cheight = cbitmap\bmHeight
    cbitsperpixel = cbitmap\bmBitsPixel
    If cbitsperpixel = 0
    	cbitsperpixel = 1
    EndIf
    If cbitsperpixel < 8
    	colorcount = Pow(2, cbitsperpixel) ; colorcount = 0, если 8 или более бит на пиксель (bpp).
    EndIf
    colorplanes = cbitmap\bmplanes
	Else ; Монохромный значок (2 цвета, чёрный и белый или другие, то есть 0 и 1).
    cwidth = mwidth
    cheight = mheight / 2
    cbitsperpixel = 1
    colorcount = 2
    colorplanes = 1
    mheight = cheight
	EndIf
	; Все готово для создания файла.
	file = CreateFile(#PB_Any, filename$)
	If file
    ; Записывает данные.
    ; word = 0
    WriteWord(file, 0) ; (резервный)
    ; word = 1 для значка, 2 для курсора.
    WriteWord(file, 1) ; (тип) 1 - значок, 2 - курсор.
            	  ; word = количество иконок в файле.
    WriteWord(file, 1)   ; (число иконок) ***ИЗМЕНИТЕ ЕСЛИ КОД ПОДДЕРЖИВАЕТ БОЛЬШЕЕ ЧИСЛО ЗНАЧКОВ***
            	  ; 16-байтовая структура ICONDIRENTRY, по одному на каждый значок.
    WriteByte(file, cwidth) ; ширина
    WriteByte(file, cheight) ; высота
    WriteByte(file, colorcount) ; цветов в палитре
    WriteByte(file, 0) ; резервный .
;     If ficon = 1     ; иконка.
    	WriteWord(file, colorplanes) ; (число плоскостей: 0 или 1) Должно быть равно 1, - но на всякий случай!
    	WriteWord(file, cbitsperpixel) ; bpp - бит на пиксель
;     EndIf
    WriteLong(file, 0) ; (размер растра, см FileSeek на 14 далее) ВРЕМЕННО! НАМ НУЖНО ВЕРНУТЬ, КОГДА МЫ ЗНАЕМ ТОЧНОЕ КОЛИЧЕСТВО.
              ;  Размер (InfoHeader + ANDbitmap + XORbitmap)
    WriteLong(file, Loc(file) + 4)  ; (позиция BITMAPINFOHEADER) FilePos, где начинается InfoHeader
                    ; Теперь данные изображения в виде BITMAPINFOHEADER (40 байт) + карта цветов для цветового растрового изображения.
                    ; + биты цветного растрового изображения + биты растрового изображения маски. Глоток! По одному на каждую иконку.
                    ; 40-байтовая структура BITMAPINFOHEADER.
    imagebytecount = SizeOf(BITMAPINFOHEADER)
    WriteLong(file, imagebytecount) ; Should be 40.
    WriteLong(file, cwidth)
    WriteLong(file, cheight + mheight) ; Комбинированные высоты цвета + изображения маски.
    WriteWord(file, colorplanes)  ; Должно быть равно 1, - но на всякий случай!
    WriteWord(file, cbitsperpixel)
    WriteLong(file, 0) ; Сжатие.
    WriteLong(file, 0) ; Размер изображения. Допустимо установить нулевое значение, если сжатие отсутствует.
    WriteLong(file, 0) ; Неиспользуется.
    WriteLong(file, 0) ; Неиспользуется.
    WriteLong(file, 0) ; Неиспользуется.
    WriteLong(file, 0) ; Неиспользуется.
               ; Цветовая карта. Применяется только для <= 8 бит на пиксель.
    hdc = CreateCompatibleDC_(0) ; Нужен для того, чтобы получить таблицу цветов.
    If hbmColor = 0      ; Монохромный значок.
    	WriteLong(file, #Black)
    	WriteLong(file, #White)
    	imagebytecount + SizeOf(rgbquad) * 2
    ElseIf cbitsperpixel <= 8 ; Включает 1-битные немонохромные значки.
                ; Получите таблицу цветов.
    	temp = Pow(2, cbitsperpixel)
    	bytesinrow = SizeOf(rgbquad) * temp
    	mem = AllocateMemory(bytesinrow)
    	oldbitmap = SelectObject_(hdc, hbmColor)
    	GetDIBColorTable_(hdc, 0, temp, mem)
    	WriteData(file, mem, bytesinrow) ; Напишите таблицу цветов.
    	FreeMemory(mem)
    	SelectObject_(hdc, oldbitmap)
    	imagebytecount + bytesinrow
    EndIf
    ; Теперь биты цветного изображения. Для этого мы используем GetDiBits_().
    bytesinrow = (cwidth * cbitsperpixel + 31) / 32 * 4  ; Выровнено по границе 4 байта.
    bytesinrow * cheight
    mem = AllocateMemory(bytesinrow)
    *bitmapinfo\bmiHeader\biSize = SizeOf(BITMAPINFOHEADER)
    *bitmapinfo\bmiHeader\biWidth = cwidth
    *bitmapinfo\bmiHeader\biPlanes = colorplanes
    *bitmapinfo\bmiHeader\biBitCount = cbitsperpixel
    If hbmColor
    	*bitmapinfo\bmiHeader\biHeight = cheight
    	GetDIBits_(hdc, hbmColor, 0, cheight, mem, *bitmapinfo, #DIB_RGB_COLORS)
    Else ; Монохромное цветное изображение — это нижняя половина изображения маски.
    	*bitmapinfo\bmiHeader\biHeight = 2*cheight
    	GetDIBits_(hdc, hbmMask, 0, cheight, mem, *bitmapinfo, #DIB_RGB_COLORS)
    EndIf
    WriteData(file, mem, bytesinrow)
    FreeMemory(mem)
    imagebytecount + bytesinrow
    ; Теперь биты изображения маски. Для этого мы используем GetDiBits_().
    bytesinrow = (mwidth + 31) / 32 * 4  ; Выровнено по границе 4 байта.
    bytesinrow * mheight
    mem = AllocateMemory(bytesinrow)
    *bitmapinfo\bmiHeader\biWidth = mwidth
    *bitmapinfo\bmiHeader\biPlanes = 1
    *bitmapinfo\bmiHeader\biBitCount = 1
    If hbmColor
    	*bitmapinfo\bmiHeader\biHeight = mheight
    	GetDIBits_(hdc, hbmMask, 0, mheight, mem, *bitmapinfo, #DIB_RGB_COLORS)
    Else
    	*bitmapinfo\bmiHeader\biHeight = 2*mheight
    	GetDIBits_(hdc, hbmMask, mheight, mheight, mem, *bitmapinfo, #DIB_RGB_COLORS)
    EndIf
    WriteData(file, mem, bytesinrow)
    FreeMemory(mem)
    imagebytecount + bytesinrow
    DeleteDC_(hdc)
    ; Наконец, возвращение на поле, которое мы пропустили.
    FileSeek(file, 14)
    WriteLong(file, imagebytecount)
    CloseFile(file)
    result = 1 ; Сигнал, что все в порядке.
	Else
    result = 0
	EndIf
	DeleteObject_(hbmMask) ; Это копии, созданные в результате GetIconInfo_(), и поэтому их необходимо удалить.
	DeleteObject_(hbmColor)
	FreeMemory(*bitmapinfo)
	ProcedureReturn result
EndProcedure