Code: Select all
;by einander
;PB 5.11 - tested on win x86
;
EnableExplicit
Define Ev,Wi,He,Result,Path$
Global _Img,_Canv,_Var$,_Selection,_InnerRgn
Global _Drawing,GMX.L,GMY.L
UseJPEGImageDecoder()
UsePNGImageDecoder()
UsePNGImageEncoder()
UseTGAImageDecoder()
UseTIFFImageDecoder()
UseJPEGImageDecoder()
UseJPEGImageEncoder()
#PatImg$ ="Windows or OS/2 Bitmap (*.bmp)|*.bmp"+
"|JPEG File Interchange Format (*.jpeg,*.jpg,*.jfif)|*.jpeg;*.jpg;*.jfif"+
"|Portable Network Graphics (*.png)|*.png"+
"|Tagged Image File (*.tif,*.tiff)|*.tif;*.tiff"+
"|All Supported Files|*.bmp;*.jpeg;*.jpg;*.jfif;*.png;*.tif;*.tiff"+
"|All Files (*.*)|*.*"
;
Structure RgnBrush
X.I
Y.I
RGB.L
EndStructure
;
Dim LP.Point(0)
;
Macro MMx : WindowMouseX(EventWindow()) : EndMacro
;
Macro MMy : WindowMouseY(EventWindow()) : EndMacro
;
Macro MMk
Abs(GetAsyncKeyState_(#VK_LBUTTON) +GetAsyncKeyState_(#VK_RBUTTON)*2+GetAsyncKeyState_(#VK_MBUTTON)*3)/$8000
EndMacro
;
Macro StopDraw
If _DrawING
StopDrawing()
_Drawing=0
EndIf
EndMacro
;
Macro CLS(RGB=0,Win=0)
Drawin(Win)
Box(0,0,OutputWidth(),OutputHeight(),RGB)
EndMacro
;
Macro DrawFast(Img,BKG=-1)
StopDraw
_DrawING=StartDrawing(ImageOutput(Img))
If BKG>-1:Box(0,0,OutputWidth(),OutputHeight(),Bkg):EndIf
EndMacro
;
;
Procedure.F MaxF(A.F,B.F) ; comparar
If A>B:ProcedureReturn A:EndIf
ProcedureReturn B
EndProcedure
;
Procedure CenterBoxes(X,Y,W1,H1,W2,H2,*P.Point) ;Out *P.Point to Center box
*P\X=X+(W1-W2)/2
*P\Y=Y+(H1-H2)/2
EndProcedure
;
Procedure ResizeFit(Img,NewWi,NewHe,Force=0,FreeImg=0,*P.Point=0) ;- RET New Image = Img proportionally Resized To Fit inside newwi,newhe
Static NewImg
Protected Wi2=ImageWidth(Img),He2=ImageHeight(Img)
If FreeImg And IsImage(NewImg) :FreeImage(NewImg) :EndIf
NewImg=GrabImage(Img,-1,0,0,Wi2,He2)
If Force Or Wi2>NewWi Or He2>NewHe
Protected Mx.F=MaxF(Wi2/NewWi,He2/NewHe)
Wi2/Mx : He2/Mx
ResizeImage(NewImg,Wi2,He2)
EndIf
If *P.Point ; ret *P para centrar NewImg en Img
CenterBoxes(0,0,NewWi,NewHe,ImageWidth(NewImg),ImageHeight(NewImg),*P)
EndIf
ProcedureReturn NewImg
EndProcedure
;
Procedure$ SaveImg(Img,DefaultFile$="",Title.S="Save Image") ; Save Image
Protected Pattern$ ="Windows Or OS/2 Bitmap (*.Bmp)|*.Bmp"
Pattern$+"|JPEG File Interchange Format (*.Jfif,*.Jpeg,*.Jpg)|*.Jpeg;*.jpg;*.jfif"
Pattern$+"|Portable Network Graphics (*.png)|*.png"
Pattern$+"|Tagged Image File (*.tif,*.tiff)|*.tif;*.tiff"
Protected File$=SaveFileRequester("Please Choose The File Name To Save", DefaultFile$, Pattern$, 0)
If File$
If SelectedFilePattern()=0
If LCase(GetExtensionPart(File$))<>"bmp" : File$+".bmp" :EndIf
SaveImage(Img,File$,#PB_ImagePlugin_BMP, 0, 32)
ProcedureReturn "Saved "+File$
ElseIf SelectedFilePattern()=1
If LCase(GetExtensionPart(File$))<>"jpg" : File$+".jpg" :EndIf
SaveImage(Img,File$,#PB_ImagePlugin_JPEG,10)
ProcedureReturn "Saved "+File$
ElseIf SelectedFilePattern()=2
If LCase(GetExtensionPart(File$))<>"png" : File$+".png" :EndIf
SaveImage(Img,File$,#PB_ImagePlugin_PNG)
ProcedureReturn "Saved "+File$
EndIf
Else
ProcedureReturn ("File Not Saved")
EndIf
EndProcedure
;
Procedure LeeImage(DefaultFile$="*.*",Title.S="Load Image") ; Load Image - Ret ImageNum StandardFile$ = "i:\" ; set initial File+path to Display
Protected File$,Result
If DefaultFile$="*.*" Or Right(DefaultFile$,1)="\": File$ = OpenFileRequester("Choose Image To load", DefaultFile$, #PatImg$,4)
Else:File$=DefaultFile$
EndIf
If File$
Protected Img=LoadImage(-1, File$)
_Var$=File$ ; para retorno
ProcedureReturn Img
Else
Result=MessageRequester("", "Image Not loaded."+#CRLF$+"Continue?", #PB_MessageRequester_YesNo)
If Result=#PB_MessageRequester_No
End
EndIf
EndIf
EndProcedure
;
Procedure GMX(Gad) ;- GMX(gad) ; HACE GMX, GMY : GetGadgetMouse x, y
Protected P.Point
GetCursorPos_(P)
ScreenToClient_( GadgetID(Gad), @P)
CopyMemory(@P\X,@GMX,16)
If GMX<0 Or GMX>=GadgetWidth(Gad) :ProcedureReturn -1 :EndIf
If GMY<0 Or GMY>=GadgetHeight(Gad) :ProcedureReturn -1 :EndIf
EndProcedure
;
Procedure Menu1(Wn)
Protected Menu= CreateMenu(-1, WindowID(Wn))
MenuItem( 1, "&Load Image")
ProcedureReturn Menu
EndProcedure
;
Procedure Menu2(Wn)
Protected Menu= CreateMenu(-1, WindowID(Wn))
MenuItem( 3, "Save Selection As...")
ProcedureReturn Menu
EndProcedure
;
Procedure DrawCanvas(Canvas,RGB=-1)
If _Drawing:StopDrawing():EndIf
_DrawING=StartDrawing(CanvasOutput(Canvas))
If RGB>-1
Box(0,0,OutputWidth(),OutputHeight(),RGB)
EndIf
EndProcedure
;
Macro Drawin(Win=0,RGB=-1)
StopDraw
_DrawING=StartDrawing(WindowOutput(Win))
If RGB>-1
Box(0,0,OutputWidth(),OutputHeight(),RGB)
EndIf
EndMacro
;
Procedure GetInnerRgn(*Rc.RECT,Array Lp.Point(1))
; Select region with Mouse inside *rc; out contour in LP.Point()
Protected Pt.Point,Count
Dim LP.Point(0)
Gmx(_Canv)
LP(0)\X=Gmx : LP(0)\Y=Gmy
While MMk=1
Gmx(_Canv)
WaitWindowEvent()
If #WM_MOUSEMOVE
DrawCanvas(_Canv)
Count+1
ReDim LP.Point(Count)
LP(Count)\X=GMx : LP(Count)\Y=GMy
LineXY(LP(Count-1)\X,LP(Count-1)\Y,LP(Count)\X,LP(Count)\Y,#White)
EndIf
StopDraw
Wend
DrawCanvas(_Canv)
If MMk=0
LineXY(LP(Count)\X,LP(Count)\Y,LP(0)\X,LP(0)\Y,#White)
StopDraw
EndIf
ProcedureReturn CreatePolygonRgn_(@LP(),Count,#WINDING) ; try #ALTERNATE,#WINDING <<<<<<<<
EndProcedure
;
Procedure InDraw(X,Y) ; check for Point() inside Drawing area
If X>=0 And Y>=0 And X<OutputWidth() And Y<OutputHeight()
ProcedureReturn #True
EndIf
EndProcedure
;
Procedure GetRgnBrush(Rgn,Array Arr.Rgnbrush(1),*Rc.Rect) ; store in Arr() positions and Colors From Rgn
Protected X,Y,N,Rwi,Rhe,I
GetRgnBox_(Rgn,*Rc)
Rwi=*Rc\Right-*Rc\Left
Rhe=*Rc\Bottom-*Rc\Top
Dim Arr(Rwi*Rhe)
DrawCanvas(_Canv)
For X=*Rc\Left To *Rc\Right-1
For Y=*Rc\Top To *Rc\Bottom-1
If PtInRegion_(Rgn,X,Y) And InDraw(X,Y)
Arr(N)\X=X
Arr(N)\Y=Y
N+1
EndIf
Next
Next
If N>0:ReDim Arr(N-1)
Drawfast(_Img)
For I=0 To N-1
Arr(I)\RGB=Point(Arr(I)\X,Arr(I)\Y)
Next
EndIf
EndProcedure
;
Procedure ProcessRegion(Array Lp.Point(1))
Static InnerRC,OuterRgn,TmpRgn,Pulsed
Dim Rgnbrush.Rgnbrush(0)
Protected Rc.Rect,I,Firstx,Firsty
Protected Offx=10,Offy=10 ; Choose here your preferred Margins <<<<<<<<<<<<<<<<<<<<<<
GetWindowRect_(GadgetID(_Canv),@Rc)
With Outer
DrawCanvas(_Canv)
Select MMk
Case 0 : Pulsed=0
Case 1
If Pulsed=0
If _InnerRgn : Gmx(_Canv)
Else ; if _InnerRgn don't exist, try to Create it
OuterRgn=CreateRectRgn_(0,0,OutputWidth(),OutputHeight())
_InnerRgn=GetInnerRgn(@Rc,LP())
GetRgnbrush(_InnerRgn,RgnBrush(),@Rc)
SortStructuredArray(Rgnbrush(),#PB_Sort_Ascending,OffsetOf(Rgnbrush\X),#PB_Sort_Integer)
Firstx=Rgnbrush(0)\X-Offx
SortStructuredArray(Rgnbrush(),#PB_Sort_Ascending,OffsetOf(Rgnbrush\Y),#PB_Sort_Integer)
Firsty=Rgnbrush(0)\Y-Offy
Drawin()
For I=0 To ArraySize(Rgnbrush())
Plot(Rgnbrush(I)\X-Firstx,Rgnbrush(I)\Y-Firsty,Rgnbrush(I)\RGB)
Next
If IsImage(_Selection):FreeImage(_Selection):EndIf
_Selection=GrabDrawingImage(-1,0,0,Rc\Right-Rc\Left+Offx*2,Rc\Bottom-Rc\Top+Offy*2)
DrawCanvas(_Canv)
EndIf
Pulsed=#True
EndIf
Case 2
DeleteObject_(TmpRgn)
DeleteObject_(_InnerRgn )
DeleteObject_(OuterRgn)
Cls()
_InnerRgn=0
StopDraw
SetGadgetAttribute(_Canv,#PB_Canvas_Image,ImageID(_Img))
EndSelect
EndWith
EndProcedure
;<<<<<<<<<<<<<<<<<<
OpenWindow(0,0,0,800,600 ,"Test Window",#PB_Window_SystemMenu|#PB_Window_Maximize)
Wi=WindowWidth(0):He=WindowHeight(0)
ResizeWindow(0,Wi/2,0,Wi/2-20,He)
Define Menu2=Menu2(0)
Define Testwin=OpenWindow(-1,0,0,Wi/2-15,He,"Define Region - Right mouse button to undefine",#PB_Window_SystemMenu)
SetWindowColor(0,$22)
SetWindowColor(Testwin,$22)
Define Menu1=Menu1(Testwin)
Define Outer.RECT
_Canv=CanvasGadget(-1,0,0,1,1,#PB_Canvas_Keyboard)
Repeat
EV=WaitWindowEvent(1)
If EV= #WM_KEYDOWN And EventwParam()=27:End:EndIf
Select Ev
Case #PB_Event_Gadget
Select EventGadget()
Case _Canv
ProcessRegion(Lp())
EndSelect
Case #PB_Event_Menu
Select EventMenu()
Case 1
Repeat
If IsImage(_Img):FreeImage(_Img):EndIf
_Img=LeeImage("e:\Graficos\")
If _Img=0
MessageRequester("",_Var$+#CRLF$+"Image Error",0)
Result=MessageRequester("", "Image Not loaded."+#CRLF$+"Continue?", #PB_MessageRequester_YesNo)
If Result=#PB_MessageRequester_No
End
EndIf
EndIf
Until _Img
Path$=GetPathPart(_Var$)
_Img=Resizefit(_Img,Wi/2,He)
ResizeGadget(_Canv,0,0,ImageWidth(_Img),ImageHeight(_Img))
SetGadgetAttribute(_Canv,#PB_Canvas_Image,ImageID(_Img))
DeleteObject_(_InnerRgn )
_InnerRgn=0
Cls($22)
Case 3 ; save Selection
If IsImage(_Selection)
SaveImg(_Selection,Path$)
Else
Result=MessageRequester("", "Nothing to save."+#CRLF$+"Continue?", #PB_MessageRequester_YesNo)
If Result=#PB_MessageRequester_No
End
EndIf
EndIf
EndSelect
EndSelect
Until EV= #PB_Event_CloseWindow
End
Saving the selection as Jpeg fails. Bmp and Png seems to work Ok.