Code:
#compile exe
#include "\pbwin80\winapi\win32api.inc"
#include "\pbwin80\winapi\ComDlg32.Inc"
#include "gdiplus.inc"
global hinstance&
declare function wndproc(byval long,byval long,byval long,byval long) as long
declare function getpicfilename(byval long) as string
declare function savepicfilename(byval long,byval string) as string
function winmain(byval hinst&,byval hprev&, _
byval szcmdline as asciiz ptr,byval cmdshow&) as long
hinstance&=hinst&
dim wmsg as tagmsg
dim wclass as wndclassex
dim wndrect as rect
dim szclassname as asciiz*32
dim sztitle as asciiz*256
szclassname="TestPicViewer"
wclass.cbsize=sizeof(wclass)
wclass.style=%cs_hredraw or %cs_vredraw
wclass.lpfnwndproc=codeptr(wndproc)
wclass.cbclsextra=0
wclass.cbwndextra=0
wclass.hinstance=hinstance&
wclass.hicon=%null
wclass.hcursor=loadcursor(%null,byval %idc_arrow)
wclass.hbrbackground=getstockobject(%gray_brush)
wclass.lpszmenuname=%null
wclass.lpszclassname=varptr(szclassname)
wclass.hiconsm=%null
registerclassex wclass
sztitle="Test Picture Viewer"
systemparametersinfo %spi_getworkarea,0,wndrect,0
xs&=wndrect.nleft
ys&=wndrect.ntop
xl&=(wndrect.nright-xs&)+1
yl&=(wndrect.nbottom-ys&)+1
style&=%ws_overlappedwindow or %ws_clipchildren or %ws_hscroll _
or %ws_vscroll
hwnd&=createwindowex(0, _ ''advanced style
szclassname, _ ''window class name
sztitle, _ ''window title
style&, _ ''window style
xs&, _ ''initial x position
ys&, _ ''initial y position
xl&, _ ''initial x size
yl&, _ ''initial y size
%null, _ ''parent window handle
%null, _ ''window menu handle
hinstance&, _ ''program instance handle
byval %null) ''creation parameters
showwindow hwnd&,cmdshow&
updatewindow hwnd&
while getmessage(wmsg, %null, 0, 0)
translatemessage wmsg
dispatchmessage wmsg
wend
function=wmsg.wparam
end function
function wndproc(byval hwnd&,byval msg&,byval wparam&,byval lparam&) as long
static hgdiplus&
static nohscroll&,novscroll&
static img&,imgwidth&,imgheight&
static xpos&,ypos&
static mult!,oldmult!
static imgname$
static six as scrollinfo
static siy as scrollinfo
dim ps as paintstruct
dim rc as rect
dim gpinput as gdiplusstartupinput
select case long msg&
case %wm_create
''create main menu
hmainmenu&=createmenu
hmenu&=createpopupmenu
appendmenu hmenu&,%mf_string,201,"Open Picture File"
appendmenu hmenu&,%mf_string,202,"Save As..."
appendmenu hmenu&,%mf_separator,0,""
appendmenu hmenu&,%mf_string,210,"Exit"
appendmenu hmainmenu&,%mf_popup,hmenu&,"File"
hmenu&=createpopupmenu
hsubmenu&=createpopupmenu
appendmenu hsubmenu&,%mf_string,301,"x .25"
appendmenu hsubmenu&,%mf_string,302,"x .5"
appendmenu hsubmenu&,%mf_string,303,"x .75"
appendmenu hsubmenu&,%mf_string,304,"x 1 (Original)"
appendmenu hsubmenu&,%mf_string,305,"x 1.25"
appendmenu hsubmenu&,%mf_string,306,"x 1.5"
appendmenu hsubmenu&,%mf_string,307,"x 1.75"
appendmenu hsubmenu&,%mf_string,308,"x 2"
appendmenu hsubmenu&,%mf_string,309,"x 2.25"
appendmenu hsubmenu&,%mf_string,310,"x 2.5"
appendmenu hsubmenu&,%mf_string,311,"x 2.75"
appendmenu hsubmenu&,%mf_string,312,"x 3"
appendmenu hmenu&,%mf_popup,hsubmenu&,"Resize"
appendmenu hmainmenu&,%mf_popup,hmenu&,"View"
setmenu hwnd&,hmainmenu&
drawmenubar hwnd&
''create scrollbars
six.cbsize=sizeof(six)
six.fmask=%sif_all or %sif_disablenoscroll
six.nmin=1
six.nmax=1
six.npage=1
six.npos=1
setscrollinfo hwnd&,%sb_horz,six,%true
siy.cbsize=sizeof(siy)
siy.fmask=%sif_all or %sif_disablenoscroll
siy.nmin=1
siy.nmax=1
siy.npage=1
siy.npos=1
setscrollinfo hwnd&,%sb_vert,siy,%true
nohscroll&=1
novscroll&=1
mult!=1
oldmult!=0
invalidaterect hwnd&,byval %null,%false
showwindow hwnd&,%sw_show
case %wm_paint
hdc&=beginpaint(hwnd&,ps)
getclientrect hwnd&,rc
xl&=imgwidth&*mult!
yl&=imgheight&*mult!
quality&=100
''test for scrollbars
oldnohscroll&=nohscroll&
oldnovscroll&=novscroll&
xsize&=(rc.nright-rc.nleft)+1
ysize&=(rc.nbottom-rc.ntop)+1
if mult!<>oldmult! then
if xl&>xsize& then ''need horz scroll
nohscroll&=0
six.nmax=(xl&-xsize&)
six.npage=1
else
nohscroll&=1
six.nmax=1
six.npage=1
end if
six.cbsize=sizeof(six)
six.fmask=%sif_all or %sif_disablenoscroll
six.nmin=1
six.npos=1
setscrollinfo hwnd&,%sb_horz,six,%true
if yl&>ysize& then ''need vert scroll
novscroll&=0
siy.nmax=(yl&-ysize&)
siy.npage=1
else
novscroll&=1
siy.nmax=1
siy.npage=1
end if
siy.cbsize=sizeof(siy)
siy.fmask=%sif_all or %sif_disablenoscroll
siy.nmin=1
siy.npos=1
setscrollinfo hwnd&,%sb_vert,siy,%true
end if
if (novscroll&=1 and nohscroll&=1 and mult!=oldmult!) _
or mult!<>oldmult! _
or (novscroll&<>oldnovscroll&) _
or (nohscroll&<>oldnohscroll&) then
fillrect hdc&,rc,getstockobject(%gray_brush)
end if
oldmult!=mult!
if img&=0 then
endpaint hwnd&,ps
function=0
exit function
end if
''initialize graphics class
if gdipcreatefromhdc(hdc&,graphics&) then
''error
endpaint hwnd&,ps
function=0
exit function
end if
call gdipsetinterpolationmode(graphics&,quality&)
call gdipdrawimagerecti(graphics&,img&,xpos&,ypos&,xl&,yl&)
call gdipdeletegraphics(graphics&)
endpaint hwnd&,ps
function=0
exit function
case %wm_vscroll
getscrollinfo hwnd&,%sb_vert,siy
oldsiynpos&=siy.npos
select case lowrd(wparam&)
case %sb_top
siy.npos=siy.nmin
case %sb_bottom
siy.npos=siy.nmax
case %sb_linedown
siy.npos=siy.npos+1
if siy.npos>siy.nmax then siy.npos=siy.nmax
case %sb_lineup
siy.npos=siy.npos-1
if siy.npos<siy.nmin then siy.npos=siy.nmin
case %sb_thumbtrack
siy.npos=siy.ntrackpos
case %sb_thumbposition
siy.npos=siy.ntrackpos
case %sb_endscroll
siy.npos=siy.ntrackpos
case else
exit function
end select
ypos&=-(siy.npos)
if siy.npos<>oldsiynpos& then
setscrollinfo hwnd&,%sb_vert,siy,%true
invalidaterect hwnd&,byval %null,%false
showwindow hwnd&,%sw_show
end if
exit function
case %wm_hscroll
getscrollinfo hwnd&,%sb_horz,six
oldsixnpos&=six.npos
select case lowrd(wparam&)
case %sb_left,%sb_lineleft
six.npos=six.npos-1
if six.npos<six.nmin then six.npos=six.nmin
case %sb_right,%sb_lineright
six.npos=six.npos+1
if six.npos>six.nmax then six.npos=six.nmax
case %sb_thumbposition
six.npos=six.ntrackpos
case %sb_endscroll
six.npos=six.ntrackpos
case %sb_thumbtrack
six.npos=six.ntrackpos
case else
exit function
end select
xpos&=-(six.npos)
if six.npos<>oldsixnpos& then
setscrollinfo hwnd&,%sb_horz,six,%true
invalidaterect hwnd&,byval %null,%false
showwindow hwnd&,%sw_show
end if
exit function
case %wm_syscommand
if (wparam& and &hfff0)<>%sc_close then exit select
destroywindow hwnd&
function=1
exit function
case %wm_command
select case lowrd(wparam&)
case 201 ''open
b$=getpicfilename(hwnd&)
if b$="" then exit function
imgname$=lcase$(b$)
mult!=1
oldmult!=0
xpos&=0
ypos&=0
lnf&=len(imgname$)
i&=instr(-1,imgname$,".")
if i&>0 then
if dir$(imgname$)="" then i&=0
end if
if i&<=0 then exit select
extns$=".dib.emf.gif.jpg.jpeg.png.tif.tiff.wmf.bmp."
imgtype$="."+mid$(imgname$,(i&+1),(lnf&-i&))+"."
imagetype&=instr(extns$,imgtype$)
if imagetype&=0 then
txt$="GDI+ is unable to read "+imgtype$+" files."
title$="File Format"
msgbox txt$,%mb_ok,title$
exit select
end if
gpinput.gdiplusversion=1
gdiplusstartup hgdiplus&,gpinput,byval %null
img&=0
imgwidth&=0
imgheight&=0
if gdiploadimagefromfile(ucode$(imgname$),img&)=0 then
call gdipgetimagewidth(img&,imgwidth&)
call gdipgetimageheight(img&,imgheight&)
end if
if imgwidth&=0 or imgheight&=0 then img&=0
if img&=0 then exit select
invalidaterect hwnd&,byval 0,1
updatewindow hwnd&
case 202 ''save as...
defnamefile$=imgname$
b$=savepicfilename(hwnd&,defnamefile$)
if b$="" then exit select
imgname$=lcase$(b$)
i&=instr(-1,imgname$,".")
if i&<=0 then
txt$="No format extension was given!"
title$="Error"
msgbox txt$,%mb_ok,title$
exit select
end if
lnf&=len(imgname$)
extns$=".bmp.jpg.jpeg.gif.tif.tiff."
imgtype$="."+mid$(imgname$,(i&+1),(lnf&-i&))+"."
imagetype&=instr(extns$,imgtype$)
imgtype$=ltrim$(rtrim$(imgtype$,"."),".")
if imagetype&=0 then
txt$="GDI+ is unable to save "+imgtype$+" files."
title$="File Format"
msgbox txt$,%mb_ok,title$
exit select
end if
select case imgtype$
case "jpg"
imgtype$="jpeg"
case "tif"
imgtype$="tiff"
end select
frmt$="image/"+imgtype$
saveimagetofile img&,imgname$,frmt$
''''to convert to different image type:
''convertimage fl1$,fl2$,frmt$
case 210 ''exit
postmessage hwnd&,%wm_syscommand,%sc_close,0
case 301 to 312 ''resize
lwa&=lowrd(wparam&)-300
mult!=lwa&*(.25)
xpos&=0
ypos&=0
invalidaterect hwnd&,byval 0,1
updatewindow hwnd&
end select
case %wm_destroy
if img& then call gdipdisposeimage(img&)
img&=0
if hgdiplus& then
call gdiplusshutdown(hgdiplus&)
hgdiplus&=0
end if
postquitmessage 0
function=0
exit function
end select
function=defwindowproc(hwnd&,msg&,wparam&,lparam&)
end function
function getpicfilename(byval hwnd&) as string
dim szcurdir1 as asciiz*%max_path
dim szcurdir2 as asciiz*%max_path
dim szfilename as asciiz*%max_path
dim sztitle as asciiz*%max_path
dim ofn as openfilename
ofn.lstructsize=sizeof(ofn)
ofn.hwndowner=hwnd&
ofn.hinstance=hinstance&
filter$="Graphic files (*.bmp,*.jpg,*.jpeg,*.gif,*.tif,*.tiff)" _
+chr$(0)+"*.bmp;*.jpg;*.jpeg;*.gif;*.tif;*.tiff"+chr$(0)
sztitle="Open A Graphic File"
ofn.lpstrfilter=strptr(filter$)
ofn.lpstrfiletitle=varptr(szfilename)
ofn.nmaxfiletitle=sizeof(szfilename)
ofn.lpstrtitle=varptr(sztitle)
ofn.flags=%ofn_pathmustexist
getcurrentdirectory sizeof(szcurdir1),szcurdir1
getopenfilename ofn
getcurrentdirectory sizeof(szcurdir2),szcurdir2
if right$(szcurdir2,1)<>"\" then szcurdir2=szcurdir2+"\"
if szfilename="" then
function=""
else
function=szcurdir2+szfilename
end if
setcurrentdirectory szcurdir1
end function
function savepicfilename(byval hwnd&,byval defnamefile$) as string
dim szcurdir as asciiz*%max_path
dim szfilename as asciiz*%max_path
dim sztitle as asciiz*%max_path
dim ofn as openfilename
filter$="Graphic files (*.bmp,*.jpg,*.jpeg,*.gif,*.tif,*.tiff)" _
+chr$(0)+"*.bmp;*.jpg;*.jpeg;*.gif;*.tif;*.tiff"+chr$(0)
sztitle="Save Graphic File"
szfilename=defnamefile$
getcurrentdirectory sizeof(szcurdir),szcurdir
ofn.lstructsize=sizeof(ofn)
ofn.hwndowner=hwnd&
ofn.hinstance=hinstance&
ofn.lpstrfilter=strptr(filter$)
ofn.lpstrfiletitle=varptr(szfilename)
ofn.nmaxfiletitle=sizeof(szfilename)
ofn.lpstrtitle=varptr(sztitle)
ofn.lpstrfile=varptr(szfilename)
ofn.flags=%ofn_overwriteprompt
ofn.lpstrcustomfilter=0&
ofn.nmaxcustfilter=0
ofn.nfilterindex=1
ofn.nmaxfile=%max_path
ofn.lpstrinitialdir=varptr(szcurdir)
ofn.nfileoffset=0
ofn.nfileextension=0&
ofn.lcustdata=0&
ofn.lpfnhook=0&
ofn.lptemplatename=0&
ofn.lpstrdefext=%null
getsavefilename ofn
if szfilename="" then
function=""
else
function=szfilename
end if
end function
Code:
''gdiplus.dll declares and functions:
%qualitymodehigh=2 ''best rendering quality
%unitpixel=2 ''each unit is one device pixel.
type gdiplusstartupinput
gdiplusversion as dword ''must be 1
debugeventcallback as dword ''ignored on free builds
suppressbackgroundthread as long ''FALSE unless you're prepared to call hook/unhook functions
suppressexternalcodecs as long ''FALSE unless you want GDI+ only to use its internal image codecs
end type
type gdiplusstartupoutput
notificationhook as dword
notificationunhook as dword
end type
type imagecodecinfo
classid as guid ''clsid codec identifier
formatid as guid ''guid file format identifier
codecname as dword ''pointer to asciiz string with codec name
dllname as dword ''pointer to asciiz string with pathname of the dll where codec resides, or %null
formatdescription as dword ''pointer to asciiz string with name of the format used by codec
filenameextension as dword ''pointer to asciiz string with all filename extensions associated with the codec, separated with semicolons
mimetype as dword ''pointer to asciiz string with mime type of codec
flags as dword ''combination of flags from imagecodecflags
version as dword ''integer with version of the codec
sigcount as dword ''integer with no. of signatures used by file format associated with the codec
sigsize as dword ''integer with no. of bytes of each signature
sigpattern as dword ''pointer to array of bytes with the pattern for each signature
sigmask as dword ''pointer to array of bytes with the mask for each signature
end type
declare function gdiplusstartup lib "gdiplus.dll" _
alias "GdiplusStartup" _
(dword,gdiplusstartupinput,gdiplusstartupoutput) _
as long
declare sub gdiplusshutdown lib "gdiplus.dll" _
alias "GdiplusShutdown" (byval dword)
declare function gdiploadimagefromfile lib "gdiplus.dll" _
alias "GdipLoadImageFromFile" _
(byval string,dword) as long
declare function gdipdisposeimage lib "gdiplus.dll" _
alias "GdipDisposeImage" (byval dword) as long
declare function gdipgetimageencoderssize lib "gdiplus.dll" _
alias "GdipGetImageEncodersSize" _
(dword,dword) as long
declare function gdipgetimageencoders lib "gdiplus.dll" _
alias "GdipGetImageEncoders" _
(byval dword,byval dword,byval dword) as long
declare function gdipsaveimagetofile lib "gdiplus.dll" _
alias "GdipSaveImageToFile" _
(byval dword,byval string,guid, _
optional byval dword) as long
declare function gdipsetinterpolationmode lib "gdiplus.dll" _
alias "GdipSetInterpolationMode" _
(byval long,byval long) as long
declare function gdipcreatebitmapfromhbitmap lib "gdiplus.dll" _
alias "GdipCreateBitmapFromHBITMAP" _
(byval long,byval long,long) as long
declare function gdipdrawimagerecti lib "gdiplus.dll" _
alias "GdipDrawImageRectI" _
(byval long,byval long,byval long,byval long, _
byval long,byval long) as long
declare function gdipgetimagewidth lib "gdiplus.dll" _
alias "GdipGetImageWidth" _
(byval long,long) as long
declare function gdipgetimageheight lib "gdiplus.dll" _
alias "GdipGetImageHeight" _
(byval long,long) as long
declare function gdipdeletegraphics lib "gdiplus.dll" _
alias "GdipDeleteGraphics" _
(byval long) as long
declare function gdipgraphicsclear lib "gdiplus.dll" _
alias "GdipGraphicsClear" _
(byval long,byval long) as long
declare function gdipcreatefromhwnd lib "gdiplus.dll" _
alias "GdipCreateFromHWND" _
(byval long,long) as long
declare function gdipcreatefromhdc lib "gdiplus.dll" _
alias "GdipCreateFromHDC" _
(byval long,long) as long
declare function gdipgetimagepixelformat lib "gdiplus.dll" _
alias "GdipGetImagePixelFormat" _
(byval long,long) as long
declare function gdipgetimagedimension lib "gdiplus.dll" _
alias "GdipGetImageDimension" _
(byval long,single,single) as long
declare function gdipgetimagegraphicscontext lib "gdiplus.dll" _
alias "GdipGetImageGraphicsContext" _
(byval long,long) as long
declare function gdipcreatebitmapfromscan0 lib "gdiplus.dll" _
alias "GdipCreateBitmapFromScan0" _
(byval long,byval long,byval long,byval long, _
any,long) as long
declare function gdipgetinterpolationmode lib "gdiplus.dll" _
alias "GdipGetInterpolationMode" _
(byval long,long) as long
declare function gdipdrawimagerectrecti lib "gdiplus.dll" _
alias "GdipDrawImageRectRectI" _
(byval long,byval long,byval long,byval long, _
byval long,byval long,byval long,byval long, _
byval long,byval long,byval long, _
optional byval long,optional byval long, _
optional byval long) as long
declare function gdipgetsmoothingmode lib "gdiplus.dll" _
alias "GdipGetSmoothingMode" _
(byval long,long) as long
declare function readunicodestring(byval dword) as string
declare function getencoderclsid(byval string) as string
declare function convertimage(byval string,byval string, _
byval string) as long
declare function saveimagetofile(byval dword,byval string, _
byval string) as long
function readunicodestring(byval ucs???) as string
local p as byte ptr
p=ucs???
if p=%null then exit function
b$=""
do until chr$(@p)=$nul
b$=b$+chr$(@p)
p=p+2 ''unicode strings have 2 bytes per char
loop
function=b$
end function
function getencoderclsid(byval smimetype$) as string
dim pimagecodecinfo as imagecodecinfo ptr
dim p as byte ptr
smimetype$=ucase$(smimetype$)
gdipgetimageencoderssize(numencoders???,nsize???)
redim buffer?(nsize???-1)
pimagecodecinfo=varptr(buffer?(0))
y&=gdipgetimageencoders(numencoders???,nsize???,pimagecodecinfo)
if y&<>0 then exit function
for x???=1 to numencoders???
if instr(ucase$(readunicodestring(@pimagecodecinfo.mimetype)),smimetype$) then
function=guidtxt$(@pimagecodecinfo.classid)
exit for
end if
incr pimagecodecinfo
next x???
end function
function convertimage(byval loadflname$,byval saveflname$, _
byval smimetype$) as long
dim startupinput as gdiplusstartupinput
dim startupoutput as gdiplusstartupoutput
dim sencoderclsid as guid
if trim$(loadflname$)="" or trim$(saveflname$)="" then
exit function
end if
startupinput.gdiplusversion=1
if gdiplusstartup(token???,startupinput,byval %null) then
msgbox "Error initializing GDI+",%mb_ok,"GDI+ Error"
exit function
end if
b$=getencoderclsid(smimetype$)
if b$="" then
msgbox "Encoder not installed",%mb_ok,"GDI+ Error"
exit function
end if
sencoderclsid=guid$(b$)
ucflname$=ucode$(loadflname$)
y&=gdiploadimagefromfile(ucflname$,lpimage???)
if y& then
function=y&
exit function
end if
if lpimage??? then
ucflname$=ucode$(saveflname$)
y&=gdipsaveimagetofile(lpimage???,ucflname$, _
sencoderclsid,encoderparams???)
if y& then
function=gdipdisposeimage(lpimage???)
exit function
end if
end if
gdipdisposeimage lpimage???
gdiplusshutdown token???
function=y&
end function
function saveimagetofile(byval lpimage???,byval saveflname$, _
byval smimetype$) as long
dim sencoderclsid as guid
b$=getencoderclsid(smimetype$)
if b$="" then
msgbox "Encoder not installed",%mb_ok,"GDI+ Error"
exit function
end if
sencoderclsid=guid$(b$)
ucflname$=ucode$(saveflname$)
function=gdipsaveimagetofile(lpimage???,ucflname$,sencoderclsid)
end function