* * *    
Главная » Статьи » Код PB

Просмотров: 2002 | Дата: 28.03.2024 | Коментарии (0)

Конвертор bmp jpg png tiff в код



Перетащить изображение на окно...

Code
;**************************************************************  
; Program: PicPak  
; Author: netmaestro  
; Date: April 15, 2006  
; Target OS: Microsoft Windows All  
; Target Compiler: PureBasic 4.xx  
; License: Free, unrestricted, credit appreciated  
; but not required  
;**************************************************************  

Declare CreateDataSection(picin.s)  

Procedure.s GetDroppedFile()  
buf.s=Space(DragQueryFile_(EventwParam(),0,0,0))  
DragQueryFile_(EventwParam(), 0, buf, Len(buf)+1)  
DragFinish_(EventwParam())  
ProcedureReturn buf  
EndProcedure  

line$=Chr(10)  
line$+ " Written in PureBasic by netmaestro, April 2006"+Chr(10)+Chr(10)  
line$+ " 100% free to use, distribute, reverse-engineer,"+Chr(10)  
line$+ " repackage and say you wrote it, anything you want"+Chr(10)  
line$+ " to do with it is A-OK with me"+Chr(10)  

use$=""+Chr(10)  
use$ + Space(3) + "1. Перетащите сюда файл изображения."+Chr(13)+Chr(10)+Chr(10)  
use$ + Space(3) + "2. Введите метку (несколько букв)"+Chr(13)+Chr(10)+Chr(10)  
use$ + Space(3) + "3. Получите Temp.pbi "+Chr(13)+Chr(10)+Chr(10)  
use$ + Space(3) + "4. #image img0 готов к использованию!"+Chr(13)+Chr(10)+Chr(10)  

CreateImage(0, 512,512,32)  
StartDrawing(ImageOutput(0))  
Box(0,0,512,512,GetSysColor_(#COLOR_BTNFACE))  
Circle(256,256,256,#Red)  
Circle(256,256,200,#White)  
Circle(256,256,145,#Red)  
Circle(256,256,80,#White)  
Circle(256,256,40,#Red)  
StopDrawing()  
ResizeImage(0,120,120)  

OpenWindow(0,0,0,150,170,"PicPak",#PB_Window_SystemMenu|#PB_Window_ScreenCentered)  
;CreateGadgetList(WindowID(0))  
ImageGadget(0,15,15,0,0,ImageID(0))  
DisableGadget(0,1)  
DragAcceptFiles_ (WindowID(0), #True)  
StickyWindow(0,#True)  

If CreateMenu(0, WindowID(0))  
MenuTitle("Menu")  
MenuItem( 1, "Как сделать.")  
MenuItem( 2, "About...")  
EndIf  

source.s = ProgramParameter()  
If source  
CreateDataSection(source)  
EndIf  

Repeat  
ev=WaitWindowEvent()  
Select ev  
Case #WM_DROPFILES  
Source.s = GetDroppedFile()  
ext.s = GetExtensionPart(source)  
If FindString("BMP JPG TIF PNG", UCase(ext),1)  
CreateDataSection(source)  
Else  
StickyWindow(0,#False)  
MessageRequester("Ошибка в выборе формата","Файл должен быть только: BMP, JPG, PNG или TIF",#MB_ICONERROR)  
StickyWindow(0,#True)  
EndIf  
Case #PB_Event_Menu  
Select EventMenu()  
Case 1  
StickyWindow(0,#False)  
MessageRequester("Как пользоваться",use$,$C0)  
StickyWindow(0,#True)  
Case 2  
StickyWindow(0,#False)  
MessageRequester("About PicPak",line$, $C0)  
StickyWindow(0,#True)  
EndSelect  
EndSelect  
Until ev=#WM_CLOSE  

Procedure CreateDataSection(picin.s)  
Pattern$ = "BMP (*.bmp)|*.bmp|JPEG (*.jpg)|*.jpg|PNG (*.png)|*.png|TIFF (*.tif)|*.tif"  
If picin = " "  
picin.s = OpenFileRequester("Выберите файл изображения", "", pattern$, 0)  
EndIf  
ext.s = GetExtensionPart(picin)  
If ReadFile(0,picin)  
FileLength = Lof(0)  
*Source = AllocateMemory(FileLength)  
*Target = AllocateMemory(FileLength+8)  
If FileLength And *Source And *Target  
ReadData(0, *Source, FileLength)  
CompressedLength = 0;PackMemory(*Source, *Target, FileLength, 9)  
If CompressedLength  
DecompressedLength = UnpackMemory(*Target, *Source)  
If DecompressedLength = FileLength  
StickyWindow(0,#False)  
MessageRequester("Информация", "Сжато успешно:"+Chr(10)+Chr(10)+"Старый размер: "+Str(FileLength)+Chr(10)+"Новый размер: "+Str(CompressedLength), #MB_ICONINFORMATION)  
StickyWindow(0,#True)  
FreeMemory(*source)  
*Source = AllocateMemory(compressedLength)  
CopyMemory(*target,*source,compressedlength)  
EndIf  
Else  
compressedlength=filelength  
StickyWindow(0,#False)  
MessageRequester("Итак...", "Сжатие не нужно", #MB_ICONINFORMATION)  
StickyWindow(0,#True)  
EndIf  
StickyWindow(0,#False)  
label.s = InputRequester("Ввести метку","Несколько букв для DataSection: ","PicPak:")  
If Trim(label)=""  
label="picpak"  
EndIf  
label=" "+label  
StickyWindow(0,#True)  
label=RemoveString(label,":")  
endlabel.s = label+"end:"  
label+":"  
If CreateFile(1,GetCurrentDirectory()+"temp.pbi")  
WriteStringN(1,""):clip$=Chr(10)  
Select ext  
Case "jpg"  
WriteStringN(1,"UseJPEGImageDecoder()"):clip$+"UseJPEGImageDecoder()"+Chr(10)  
Case "png"  
WriteStringN(1,"UsePNGImageDecoder()"):clip$+"UsePNGImageDecoder()"+Chr(10)  
Case "tif"  
WriteStringN(1,"UseTIFFImageDecoder()"):clip$+"UseTIFFImageDecoder()"+Chr(10)  
EndSelect  
If compressedlength<>filelength  
WriteStringN(1,"*unpacked = AllocateMemory("+Str(Filelength)+")")  
WriteStringN(1,"UnpackMemory(?"+Trim(RemoveString(label,":"))+", *unpacked)")  
WriteStringN(1,"img0 = CatchImage(#PB_Any, *unpacked, "+Str(Filelength)+")")  
clip$+"*unpacked = AllocateMemory("+Str(Filelength)+")"+Chr(10)  
clip$+"UnpackMemory(?"+Trim(RemoveString(label,":"))+", *unpacked)"+Chr(10)  
clip$+"img0 = CatchImage(#PB_Any, *unpacked, "+Str(Filelength)+")"+Chr(10)  
Else  
WriteStringN(1,"img0 = CatchImage(#PB_Any, ?" + Trim(RemoveString(label,":")) + ", "+Str(Filelength)+")")  
clip$+"img0 = CatchImage(#PB_Any, ?" + Trim(RemoveString(label,":")) + ", "+Str(Filelength)+")"+Chr(10)  
EndIf  
clip$+Chr(10)  
SetClipboardText(clip$)  
WriteStringN(1,"")  
WriteStringN(1,"Datasection")  
WriteStringN(1,label)  
WriteString(1," Data.b ")  
c=0  
For i = 0 To compressedlength-1  
If i=compressedlength-1  
lastbyte=#True  
Else  
lastbyte=#False  
EndIf  
c+1  
If c >= 20 Or lastbyte  
c = 0  
WriteStringN(1, "$"+RSet(Hex(PeekC(*source+i)),2,"0"))  
If Not lastbyte  
WriteString(1," Data.b ")  
EndIf  
Else  
WriteString(1, "$"+RSet(Hex(PeekC(*source+i)),2,"0")+",")  
EndIf  
Next  
WriteStringN(1,endlabel)  
WriteStringN(1,"EndDatasection")  
CloseFile(1)  
FreeMemory(*Source)  
FreeMemory(*Target)  
CloseFile(0)  
MessageRequester("Удачно!","Temp.pbi успешно создан: "+GetCurrentDirectory()+"temp.pbi")  
Else  
MessageRequester("Проблемы","Невозможно открыть файл")  
EndIf  
Else  
MessageRequester("Проблемы..","Невозможно обработать память. Возможно слишком большой файл.")  
EndIf  
Else  
MessageRequester("Проблемы","Невозможно открыть файл")  
EndIf  
EndProcedure










Сайт посвящён языку программирования PureBasic — коммерческий компилятор языка программирования, использующего синтаксис BASIC. Предназначен для создания кроссплатформенных приложений для AmigaOS, Linux, Microsoft Windows, Windows NT и Mac OS X. Разработан компанией Fantaisie Software.