#Include Once "project.bi"
#Include Once "dialogs.bi"
#Include Once "clsOctree.bi"

Function GetEncoderClsid(format_ As WString Ptr , ByRef pClsid As CLSID Ptr ) As Integer

	Dim As UINT  num
	Dim As UINT  size

	Dim As ImageCodecInfo Ptr pImageCodecInfo

	GdipGetImageEncodersSize(@num, @size)
	If(size = 0) Then Return -1

	pImageCodecInfo = Allocate(size)
	If pImageCodecInfo = NULL Then Return -1


	GdipGetImageEncoders(num, size, pImageCodecInfo)

	For j As UInteger = 0 To num-1
		If wcscmp(pImageCodecInfo[j].MimeType, format_) = 0  Then
			*pClsid = pImageCodecInfo[j].Clsid
			DeAllocate(pImageCodecInfo)
			Return j
		EndIf
	Next

	DeAllocate(pImageCodecInfo)
	Return -1
End Function

Private Sub cmdSave_Click(szPathSave As ZString*max_path)
	Dim img As Any Ptr, i As Long, mimg As Any Ptr, cls_ As CLSID, ct As Long
	Dim PropItem(2) As PropertyItem, interval() As Long, enc As EncoderParameters, encvalue As Long, TrIdx As Long
	Dim IStream As IStream Ptr, pt As Byte Ptr, sz As Long, hMem As Long, hFile As HANDLE

	' Только если есть какие-либо элементы
	If ListCount = 0 Then Exit Sub
	' Если не выбрали ничего, то выходим
	If Len(szPathSave) = 0 Then Exit Sub
	' Запрос CLSID кодека
	If GetEncoderClsid(WStr("image/gif"), @cls_) = -1 Then
		MessageBox(0, "Codec not found","",0)
		Exit Sub
	End If
	' Формируем свойства GIF-анимации
	' Длительности кадров
	ReDim interval(ListCount - 1)
	PropItem(0).propId = PropertyTagFrameDelay
	PropItem(0).Length = ListCount * 4
	PropItem(0).type = PropertyTagTypeLong
	PropItem(0).Value = @interval(0)
	' Количество повторов

	PropItem(1).propId = PropertyTagLoopCount
	PropItem(1).Length = 2
	PropItem(1).type = PropertyTagTypeShort
	PropItem(1).Value = VarPtr(LastValidLoopCount)

	Dim As Integer pNull
	PropItem(2).propId = &H5103
	PropItem(2).Length = 1
	PropItem(2).type = PropertyTagTypeByte
	PropItem(2).Value = VarPtr(pNull)
	' Настройка кодека
	enc.Count = 1
	enc.Parameter(0).GUID = GuidEncoderSaveFlag
	enc.Parameter(0).NumberOfValues = 1
	enc.Parameter(0).type = EncoderParameterValueTypeLong
	enc.Parameter(0).Value = VarPtr(encvalue)
	' Собираемся сохранять многокадровое изображение
	encvalue = EncoderValueMultiFrame

	' Создаем объект потока, для записи данных
	If CreateStreamOnHGlobal(0, True, @IStream)<> S_OK Then
		MessageBox(0,"Error on creating IStream","",0)
		Exit Sub
	EndIf

	' Задаем значения интервалов , в данном случае для всех кадров 30
	For i = 0 To ListCount - 1
		interval(i) = 30
	Next

	' Проход по кадрам
	ct = ListCount

	For i = 0 To ListCount - 1
		' Грузим файл изображения
		Var blen = (Len(dimfiles(i))*2)+2 ' размер для строки Unicode
		Dim As WString Ptr wbuf ' буфер под строку Unicode
		wbuf  = Callocate( blen ) ' выделяем память для буфера
		MultiByteToWideChar(CP_ACP, 0, dimfiles(i), -1, wbuf, blen) ' конвертируем в Unicode
		
		If GdipLoadImageFromFile(*wbuf, @img) Then ' загружаем фотки
			MessageBox(0,"Error load frame",Str(i),0)
		Else
			DeAllocate(wbuf) ' освобождаем буфер
			Dim As Integer LastValidAlpha = 128
			' Перевод в 256 цветов с учетом альфа порога
			If Conv256(img, LastValidAlpha) = false Then
				MessageBox(0,"Error convert palette in frame ","",0)
			End If
			' Если не первый кадр, то ддобавляем к существующему
			If i<>0 Then
				' Сохраняем очередной кадр
				encvalue = EncoderValueFrameDimensionTime
				If GdipSaveAddImage(mimg, img, @enc) Then
					MessageBox(0,"Error save frame ","",0)
				End If
				' Удаляем изображение кадра
				GdipDisposeImage img
			Else
				' Если первый кадр
				mimg = img
				' Записываем длительность каждого кадра
				GdipSetPropertyItem (img, Cast(Any Ptr,@PropItem(0)))
				' Записываем кол-во повторов
				GdipSetPropertyItem (img, Cast(Any Ptr,@PropItem(1)))
				GdipSetPropertyItem (img, Cast(Any Ptr,@PropItem(2)))
				' Сохраняем в поток
				If GdipSaveImageToStream(img, IStream, @cls_, @enc) Then
					MessageBox(0,"Error save frame ","",0)
					GoTo EndProcess
				End If
			End If
		End If

	Next

	' Записать в файл
	encvalue = EncoderValueFlush
	' Сохраняем итог
	GdipSaveAdd mimg, @enc
	If GetHGlobalFromStream(IStream, Cast(Any Ptr,@hMem)) Then
		MessageBox(0,"Error query global memory","",0)
		GoTo EndProcess
	EndIf
	' Узнаем размер гифки
	sz = GlobalSize(Cast(Any Ptr,hMem))
	' Если не 0

	If sz > 0 Then
		' Получаем указатель на глобальную память
		pt = GlobalLock(Cast(Any Ptr,hMem))
		If pt = 0 Then
			MessageBox(0,"Error pointer","",0)
			GoTo EndProcess
		EndIf
		' Устанавливаем режим фона

		If Not SetDispMode(pt, sz) Then GoTo EndProcess

		' Создаем файл
		hFile = CreateFile(StrPtr(szPathSave), GENERIC_WRITE, FILE_SHARE_READ, 0, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
		If hFile = -1 Then
			MessageBox(0,"Error creating output file","",0)
		Else
			' Пишем измененные данные
			Dim buff As Integer
			If WriteFile(hFile, pt, sz, @buff, 0) = 0 Then
				MessageBox(0,"Error write data","",0)
			End If
			' Закрываем файл
			CloseHandle hFile
		End If
		' Отменяем фиксацию данных в памяти
		GlobalUnlock Cast(Any Ptr,hMem)
	Else
		MessageBox(0,"Null file size","",0)
		GoTo EndProcess
	End If

	EndProcess:
	' Удаляем 1-й кадр
	GdipDisposeImage mimg
	' освобождаем память 8-бит палитры
	DeAllocate pix8

End Sub
' Т.к. GDI+ не позволяет задавать свойство Disposable mode в GIF файлах нужно это делать вручную
' Функция выставляет для всех кадров режим восстановления фона, иначе кадры "ложатся" друг на друга
Private Function SetDispMode(ByVal pt As Byte Ptr, ByVal Count As Long) As Boolean
	Dim ed As Long, hdr As String * 6, B As Byte, IsGIF89 As Boolean

	ed = CInt(Count + pt)
	' Считываем заголовок
	lstrcpyn hdr, pt, 7
	If lstrcmp(LCase(hdr), LCase("GIF89a")) = 0 Then
		IsGIF89 = True
	ElseIf lstrcmp(LCase(hdr), LCase("GIF87a")) Then
		MessageBox(0,"Unsupported format","",0)
		Exit Function
	End If
	' Определяем наличие глобальной палитры
	B = *(pt + 10)
	If B And &H80 Then
		Dim As Integer pTemp = 3 * (2 ^ ((B And &H7) + 1)) + 13
		pt = pt +  pTemp
	Else
		pt = pt + 13
	EndIf
	Do
		B = *pt               'Получаем заголовок блока
		If B = &H21 And IsGIF89 = TRUE Then    'Необязательный
			B = *(pt + 1)      'Узнаем тип блока
			Select Case CUByte(B)
				Case &HFF                   'Дополнительный блок приложений
					pt = pt + 14
					Do
						B = *pt
						pt = pt + B + 1
					Loop While B<>0 ' Пропускаем все субблоки
				Case &HFE                   'Дополнительный блок комментария
					pt = pt + 2
					Do
						B = *pt
						pt = pt + B + 1
					Loop While B<>0 ' Пропускаем все субблоки
				Case &HF9                   'Дополнительный блок управления изображением
					B = *(pt + 3)  'Считываем флаги
					B = (B And &HE3) Or 8  'Восстановить картинку перед выводом
					*(pt + 3) = B
					pt = pt + 8
				Case &H1                    'Дополнительный блок с простым текстом
					pt = pt + 15
					Do
						B = *pt
						pt = pt + B + 1
					Loop While B<>0 ' Пропускаем все субблоки
				Case Else
					MessageBox(0,"Unsupported block in GIF file","",0)
					Exit Function
			End Select
		ElseIf B = &H2C Then            'Обязательный (дескриптор изображения)
			B = *(pt+9)     'Запрос локальной палитры
			If (B And &H80)<>0 Then          'Локальная палитра присутствует
				Dim As Integer pTemp = 3 * (2 ^ ((B And &H7) + 1)) + 11
				pt = pt + pTemp
			Else
				pt = pt + 11
			End If
			Do
				b =	*pt
				pt = pt + CUByte(B) + 1
			Loop While B<>0 ' Пропускаем все субблоки
		ElseIf B = &H3B Then            ' Завершающий
			SetDispMode = True
			Exit Function
		Else                            ' Ошибка
			MessageBox(0,"Unsupported block in GIF file","",0)
			Exit Function
		End If
	Loop While pt < ed
End Function

' Конвертировать в 256 цветов
Private Function Conv256(ByRef Bitmap As Any Ptr, ByRef Threshold As Long) As Boolean
	Dim w As Long, h As Long
	Dim img8 As Any Ptr, str8 As Long, Pal As ColorPalette
	Dim pix32 As UByte Ptr, img32 As Any Ptr, str32 As Long, buf As Any Ptr
	Dim I1 As Long, I2 As Long, p1 As Long, p2 As Long, Tree As clsOctree Ptr, Col As RGBTriple
	Dim x As Long, y As Long, a As Long

	#Macro ErrorLabel()
		If img8 Then GdipDisposeImage img8
		If img32 Then GdipDisposeImage img32
		If buf Then GdipDeleteGraphics buf
		DeAllocate pix32
		DeAllocate  pix8
		Return false
	#EndMacro

	' Получаем размеры рисунка
	GdipGetImageWidth Bitmap, @w
	GdipGetImageHeight Bitmap, @h
	' Создаем итоговый 8bbp битмап
	str8 = -Int(-w / 4) * 4

	pix8 = Callocate(str8 * h - 1)
	If GdipCreateBitmapFromScan0(w, h, str8, PixelFormat8bppIndexed, pix8, @img8) Then
		MessageBox(0,"Error create output bitmap","",0)
		Beep
		ErrorLabel()
	End If
	' Создаем промежуточный буферный битмап для конвертации исходного битмапа в 32bpp
	str32 = w * 4
	pix32 = Callocate (str32 * h - 1)
	If GdipCreateBitmapFromScan0(w, h, str32, PixelFormat32bppARGB, pix32, @img32) Then
		MessageBox(0,"Error create output bitmap","",0)
		ErrorLabel()
	End If
	' Получаем Graphics, который представляет буферный битмап
	If GdipGetImageGraphicsContext(img32, @buf) Then
		MessageBox(0,"Error create output graphics","",0)
		ErrorLabel()
	End If
	' Отрисовываем картинку на буфер
	If GdipDrawImageRectI(buf, Bitmap, 0, 0, w, h) Then
		MessageBox(0,"Error create output graphics","",0)
		ErrorLabel()
	End If
	' Считываем данные пикселей и вычисляем оптимальную палитру
	TreeSize = 0
	TreeReduceLevel = 7
	TreeLeafLevel = 8
	ReDim TreeReduceList(8) As clsOctree Ptr
	Tree = New clsOctree

	For I1 = 0 To str32 * h - 1 Step 4
		Col.rgbtBlue = pix32[I1]
		Col.rgbtGreen = pix32[I1 + 1]
		Col.rgbtRed = pix32[I1 + 2]
		Tree->AddTree @Col, 0
		If TreeSize > 255 Then Tree->ReduceTree
	Next

	' Если используется прозрачность то 1-й элемент таблицы, задает прозрачный цвет
	Pal.flags = PaletteFlagsHasAlpha
	' Получаем палитру
	Tree->GetPalette Pal.Entries(), 1
	Pal.Count = TreeSize + 1
	' Выбираем палитру в битмап
	If GdipSetImagePalette(img8, Cast(Any Ptr,@Pal)) Then
		MessageBox(0,"Error assign palette","",0)
		ErrorLabel()
	End If

	' Задаем индекс палитры результирующего рисунка
	I1 = 0
	I2 = 0
	For y = 0 To h - 1
		p1 = I1
		p2 = I2
		For x = 0 To w - 1
			Col.rgbtBlue = pix32[p1]
			Col.rgbtGreen = pix32[p1 + 1]
			Col.rgbtRed = pix32[p1 + 2]
			a = pix32[p1 + 3]
			If a < Threshold Then
				pix8[p2] = 0
			Else
				pix8[p2] = Tree->GetNearestPaletteIndex(Col)
			End If
			p2 = p2 + 1
			p1 = p1 + 4
		Next
		I1 = I1 + str32
		I2 = I2 + str8
	Next

	' Очистка ресурсов
	GdipDeleteGraphics buf
	GdipDisposeImage Bitmap
	GdipDisposeImage img32
	' Возвращаем результат
	Bitmap = img8
	DeAllocate pix32
	Return True
End Function


' Тест
Var sPath = OpenFileName("","C:\","Image files (*.png, *.bmp, *.jpg)"_
+Chr(0)+"*.png;*.bmp;*.jpg"+Chr(0)+Chr(0),OFN_ALLOWMULTISELECT)
If Len(sPath)<>0 Then
	Do
		sPath= NextSelectedFilename()
		If Len(sPath)=0 Then Exit Do
		dimfiles(ListCount)= sPath		
		ListCount+=1		
	Loop
	Var sPathSave = GetSaveFile("","C:\","Gif files (*.gif)"_
	+Chr(0)+"*.gif"+Chr(0),1)
	If Len(sPathSave)<>0 Then
		cmdSave_Click(sPathSave)
	EndIf
EndIf

GdiplusShutdown gdiplusToken