Menu
▾
▴
[Win32forth-cvs] win32forth/src/lib FileLister.f, NONE, 1.1 IMAGEWINDOW.F, NONE, 1.1 ExUtils.f, 1.4, 1.5
|
From: Ezra B. <ezr...@us...> - 2006-06-14 05:55:26
|
Update of /cvsroot/win32forth/win32forth/src/lib In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv13205/src/lib Modified Files: ExUtils.f Added Files: FileLister.f IMAGEWINDOW.F Log Message: Some file shifting. EAB --- NEW FILE: IMAGEWINDOW.F --- \ FreeImageWindow.f \ Routines to define object class for viewing bitmaps in a window \ Some code extracted from 4FreeImage.f by J.v.d.Ven \ August 31, 2004 - updated to use DrawDibDraw function for displaying bitmaps \ July 12th, 2003 - 21:44 \ November 22nd, 2003 - 22:29 - updated to be more versatile with \ image handling & manipulation. Added functions from FreeImage.dll version 3.0 \ September 8th, 2003 - 18:08 - added Wipe: to imagewindow class to allow just \ blanking a window. \ only forth also definitions WinLibrary FreeImage.dll WINLIBRARY msvfw32.dll 0x0004 constant DDF_SAME_HDC needs enum.f \ enumerated constants \- as >SYSTEM : AS WINPROC-LAST @ PROC>CFA ALIAS ; SYSTEM> \- ?exitm macro ?exitm " if exitm then" INTERNAL \ FreeImage Load / Save flag constants #define BMP_DEFAULT 0 #define BMP_SAVE_RLE 1 #define CUT_DEFAULT 0 #define ICO_DEFAULT 0 #define ICO_FIRST 0 #define ICO_SECOND 0 #define ICO_THIRD 0 #define IFF_DEFAULT 0 #define JPEG_DEFAULT 0 #define JPEG_FAST 1 #define JPEG_ACCURATE 2 #define JPEG_QUALITYSUPERB 0x80 #define JPEG_QUALITYGOOD 0x100 #define JPEG_QUALITYNORMAL 0x200 #define JPEG_QUALITYAVERAGE 0x400 #define JPEG_QUALITYBAD 0x800 #define KOALA_DEFAULT 0 #define LBM_DEFAULT 0 #define MNG_DEFAULT 0 #define PCD_DEFAULT 0 #define PCD_BASE 1 #define PCD_BASEDIV4 2 #define PCD_BASEDIV16 3 #define PCX_DEFAULT 0 #define PNG_DEFAULT 0 #define PNG_IGNOREGAMMA 1 // avoid gamma correction #define PNM_DEFAULT 0 #define PNM_SAVE_RAW 0 // If set the writer saves in RAW format (i.e. P4, P5 or P6) #define PNM_SAVE_ASCII 1 // If set the writer saves in ASCII format (i.e. P1, P2 or P3) #define PSD_DEFAULT 0 #define RAS_DEFAULT 0 #define TARGA_DEFAULT 0 #define TARGA_LOAD_RGB888 1 // If set the loader converts RGB555 and ARGB8888 -> RGB888. #define TARGA_LOAD_RGB555 2 // This flag is obsolete #define TIFF_DEFAULT 0 #define TIFF_CMYK 0x0001 // reads/stores tags for separated CMYK (use | to combine with compression flags) #define TIFF_PACKBITS 0x0100 // save using PACKBITS compression #define TIFF_DEFLATE 0x0200 // save using DEFLATE compression #define TIFF_ADOBE_DEFLATE 0x0400 // save using ADOBE DEFLATE compression #define TIFF_NONE 0x0800 // save without any compression #define WBMP_DEFAULT 0 #define XBM_DEFAULT 0 #define XPM_DEFAULT 0 \ possible FreeImage file types -1 to enum-value 1 to increment enum: FIF_UNKNOWN FIF_BMP FIF_ICO FIF_JPEG FIF_JNG FIF_KOALA FIF_LBM FIF_MNG FIF_PBM FIF_PBMRAW FIF_PCD FIF_PCX FIF_PGM FIF_PGMRAW FIF_PNG FIF_PPM FIF_PPMRAW FIF_RAS FIF_TARGA FIF_TIFF FIF_WBMP FIF_PSD FIF_CUT FIF_XBM FIF_XPM FIF_GIF ; FIF_LBM Constant FIF_IFF /* * Image type used in FreeImage. */ 0 to enum-value enum: FIT_UNKNOWN // unknown type FIT_BITMAP // standard image : 1-, 4-, 8-, 16-, 24-, 32-bit FIT_UINT16 // array of unsigned short : unsigned 16-bit FIT_INT16 // array of short : signed 16-bit FIT_UINT32 // array of unsigned long : unsigned 32-bit FIT_INT32 // array of long : signed 32-bit FIT_FLOAT // array of float : 32-bit IEEE floating point FIT_DOUBLE // array of double : 64-bit IEEE floating point FIT_COMPLEX // array of FICOMPLEX : 2 x 64-bit IEEE floating point ; /* Image color type used in FreeImage. */ 0 to enum-value enum: FIC_MINISWHITE // min value is white FIC_MINISBLACK // min value is black FIC_RGB // RGB color model FIC_PALETTE // color map indexed FIC_RGBALPHA // RGB color model with alpha channel FIC_CMYK // CMYK color model ; /* Color quantization algorithms. Constants used in FreeImage_ColorQuantize. */ 0 to enum-value enum: FIQ_WUQUANT // Xiaolin Wu color quantization algorithm FIQ_NNQUANT // NeuQuant neural-net quantization algorithm by Anthony Dekker ; /* Dithering algorithms. Constants used FreeImage_Dither. */ 0 to enum-value enum: FID_FS // Floyd & Steinberg error diffusion FID_BAYER4x4 // Bayer ordered dispersed dot dithering (order 2 dithering matrix) FID_BAYER8x8 // Bayer ordered dispersed dot dithering (order 3 dithering matrix) FID_CLUSTER6x6 // Ordered clustered dot dithering (order 3 - 6x6 matrix) FID_CLUSTER8x8 // Ordered clustered dot dithering (order 4 - 8x8 matrix) FID_CLUSTER16x16 // Ordered clustered dot dithering (order 8 - 16x16 matrix) ; /* Upsampling / downsampling filters. Constants used in FreeImage_Rescale. */ 0 to enum-value enum: FILTER_BOX // Box, pulse, Fourier window, 1st order (constant) b-spline FILTER_BICUBIC // Mitchell & Netravali's two-param cubic filter FILTER_BILINEAR // Bilinear filter FILTER_BSPLINE // 4th order (cubic) b-spline FILTER_CATMULLROM // Catmull-Rom spline, Overhauser spline FILTER_LANCZOS3 // Lanczos3 filter ; /* Color channels. Constants used in color manipulation routines. */ 0 to enum-value enum: FICC_RGB // Use red, green and blue channels FICC_RED // Use red channel FICC_GREEN // Use green channel FICC_BLUE // Use blue channel FICC_ALPHA // Use alpha channel FICC_BLACK // Use black channel FICC_REAL // Complex images: use real part FICC_IMAG // Complex images: use imaginary part FICC_MAG // Complex images: use magnitude FICC_PHASE // Complex images: use phase ; EXTERNAL 1 proc _FreeImage_GetWidth@4 as FIGetWidth 1 proc _FreeImage_GetHeight@4 as FIGetHeight 4 proc _FreeImage_Save@16 as FISave 1 proc _FreeImage_GetInfo@4 as FIGetInfo 1 proc _FreeImage_GetBits@4 as FIGetBits 1 proc _FreeImage_Unload@4 as FIUnload 3 proc _FreeImage_Load@12 as FILoad 1 proc _FreeImage_GetFIFFromFilename@4 as FIGetInfoFromFilename 9 proc _FreeImage_ConvertFromRawBits@36 as FIConvertFromRawBits 2 proc _FreeImage_GetFileType@8 as FIGetFileType 0 proc _FreeImage_GetVersion@0 as FIGetVersion 1 proc _FreeImage_FlipVertical@4 as FIFlipVertical 1 proc _FreeImage_FlipHorizontal@4 as FIFlipHorizontal 1 proc _FreeImage_ConvertTo8Bits@4 as FIConvertTo8Bits 1 proc _FreeImage_ConvertTo16Bits565@4 as FIConvertTo16Bits 1 proc _FreeImage_ConvertTo24Bits@4 as FIConvertTo24Bits 1 proc _FreeImage_ConvertTo32Bits@4 as FIConvertTo32Bits 2 proc _FreeImage_RotateClassic@12 as FIRotate 2 proc _FreeImage_AdjustBrightness@12 as FIAdjustBrightness 2 proc _FreeImage_AdjustContrast@12 as FIAdjustContrast 0 proc _FreeImage_Invert@4 as FIInvert 1 proc _FreeImage_Clone@4 as FIClone 1 proc _FreeImage_GetBPP@4 as FIBitsPerPixel 4 proc _FreeImage_Rescale@16 as FIReScale 2 proc _FreeImage_AdjustGamma@12 as FIAdjustGamma 4 proc _FreeImage_LoadFromHandle@16 as FILoadFromHandle 1 to enum-value enum: NORMAL_FIT BEST_FIT FIT_SIZE ; INTERNAL 0 value ThisImage \ allow forward referencing for right click 0 value wincnt \ count of open image windows PopUpBar ImagePopupBar PopUp "" MenuItem "Open image file" OpenImageFile: ThisImage ; MenuItem "Erase image" Wipe: ThisImage ; MenuItem "Restore original image" Reload: ThisImage ; MenuSeparator SubMenu "Save image as" MenuItem "Bitmap" SaveAsBitmap: ThisImage ; MenuItem "Jpeg" SaveAsJpeg: ThisImage ; MenuItem "Png" SaveAsPng: ThisImage ; EndSubMenu MenuSeparator false MENUMESSAGE "Action" MenuSeparator MenuItem "Invert image" InvertImage: ThisImage ; SubMenu "Flip" MenuItem "Horizontal" FlipHorizontal: ThisImage ; MenuItem "Vertical" FlipVertical: ThisImage ; EndSubMenu SubMenu "Rotate" MenuItem "90 degrees" 90.0e RotateImage: ThisImage ; MenuItem "180 degrees" 180.0e RotateImage: ThisImage ; MenuItem "270 degrees" 270.0e RotateImage: ThisImage ; EndSubMenu SubMenu "Convert image to" :MenuItem mnu8 "8 bits" ConvertTo8Bits: ThisImage ; :MenuItem mnu16 "16 bits" ConvertTo16Bits: ThisImage ; :MenuItem mnu24 "24 bits" ConvertTo24Bits: ThisImage ; :MenuItem mnu32 "32 bits" ConvertTo32Bits: ThisImage ; EndSubmenu MenuSeparator SubMenu "View Mode" :MenuItem mnunorm "Normal" NORMAL_FIT SetViewMode: ThisImage ; :MenuItem mnuscale "Best Fit" BEST_FIT SetViewMode: ThisImage ; :MenuItem mnufit "Fit to size" FIT_SIZE SetViewMode: ThisImage ; EndSubMenu MenuSeparator SubMenu "BackGround" :MenuItem mnublack "BLACK" BLACK SetBackGroundColor: ThisImage ; :MenuItem mnuwhite "WHITE" WHITE SetBackGroundColor: ThisImage ; EndSubMenu Endbar EXTERNAL FileOpenDialog GetImageFile "Select Image File" "Image Files|*.bmp;*.dib;*.rle;*.jpg;*.jpeg;*.ico;*.pcd;*.psd;*.pcx;*.ppm;*.pgm;*.pbm;*.png;*.ras;*.tga;*.tif;*.gif|All Files (*.*)|*.*|" FileSaveDialog SaveAsBitmapDlg "Save Image File:" "Bitmap|*.bmp;*.dib|Jpeg|*.jpg;*.jpeg|Png|*.png|All Image Files|*.bmp;*.dib;*.rle;*.jpg;*.jpeg;*.ico;*.pcd;*.psd;*.pcx;*.ppm;*.pgm;*.pbm;*.png;*.ras;*.tga;*.tif;*.gif|All Files (*.*)|*.*|" :Class FreeImageWindow <Super Child-Window WinDC ImageDC int FIBITMAP \ pointer to FreeImage bitmap structure int BackGroundColor int ViewMode int dopopup? max-path bytes ImageFileName 256 value image-id int &bitmap int >&bitmap int DrawDibDC 4 CallBack: FIReadProc { &buffer size cnt fihandle -- cnt } fihandle &bitmap <> abort" Attempted read from wrong bitmap!" cnt 0 do >&bitmap &buffer size move size +to >&bitmap size +to &buffer loop cnt ; 4 CallBack: FIWriteProc { &buffer size cnt fihandle -- size } size ; 3 CallBack: FISeekProc { fihandle offset origin -- 0 } fihandle &bitmap <> abort" Attempted seek from wrong bitmap!" origin case SEEK_SET of fihandle offset + to >&bitmap endof SEEK_END of abort" Invalid seek" endof offset +to >&bitmap endcase 0 ; 1 CallBack: FITellProc { fihandle -- res } fihandle &bitmap <> abort" Attempted query from wrong bitmap!" fihandle >&bitmap > abort" Invalid handle!" >&bitmap fihandle - ; create IOProcs &FIReadProc , &FIWriteProc , &FISeekProc , &FITellProc , :M LoadFromHandle: { FIF_FORMAT addr -- FIBITMP } addr to &bitmap addr to >&bitmap 0 &bitmap IOProcs FIF_FORMAT FILoadFromHandle ;M : gen-id ( -- id ) image-id 1 +to image-id ; : ValidImage? ( -- f ) FIBITMAP 0<> hwnd 0<> and ; :M ImageWidth: ( -- w ) FIBITMAP FIGetWidth ;M :M ImageHeight: ( -- h ) FIBITMAP FIGetHeight ;M :M SaveImage: { imgtype imgparam -- } \ At the same size ValidImage? not ?exitm hwnd Start: SaveAsBitmapDlg dup c@ 0= if drop exitm then count new$ dup>r place r@ count ".ext-only" nip 0= if imgtype case FIF_BMP of s" .bmp" endof FIF_JPEG of s" .jpg" endof FIF_PNG of s" .png" endof \ FIF_BMP to imgtype s" .bmp" rot s" .img" rot \ default extension endcase r@ +place then imgparam r> 1+ FIBITMAP imgtype FISave drop ;M : CalcImageSize { \ cxDib cyDib - wDib hDib } ImageWidth: self to cxDib ImageHeight: self to cyDib \ calc scale factor Width s>f cxDib s>f f/ \ dxScale Height s>f cyDib s>f f/ \ dyScale fmin \ dScale \ remove this line, if the Image should be scaled to max window size \ fdup f1.0 f> if fdrop f1.0 then \ dScale \ calc bitmap size cyDib s>f fover f* f0.5 f+ \ dScale dHeight cxDib s>f frot f* f0.5 f+ \ dHeight dWidth f>s f>s ; \ wWidth hHeight : ErasePartOfWindow ( left top right bottom ) BackGroundColor FillArea: ImageDC ; : wipe-window ( -- ) temprect GetClientRect: self 0 0 Right: Temprect Bottom: Temprect ErasePartOfWindow ; : ShowScaledImage ( --) \ load and draw Image; keep aspect ratio DDF_SAME_HDC ImageHeight: self \ nSrcHeight ImageWidth: self \ nSrcWidth 0 \ y-coord of source upper-left corner 0 \ x-coord of source upper-left corner FIBITMAP FIGetBits \ *lpBits FIBITMAP FIGetInfo \ *lpBitsInfo CalcImageSize swap \ nDestHeight nDestWidth \ center bitmap in window 2dup Height rot - 2/ dup 0> \ YDest if 0 0 Width 3 pick ErasePartOfWindow \ top 0 Height 2 pick - 1- Width Height ErasePartOfWindow \ bottom then Width rot - 2/ dup 0> \ XDest if 0 0 2 pick Height ErasePartOfWindow \ left Width over - 1- 0 Width Height ErasePartOfWindow \ right then ImageDC.hdc DrawDIBDC Call DrawDibDraw drop ; : ShowImageInFixedWindow ( -- ) \ load and draw Image; fit to window DDF_SAME_HDC ImageHeight: self \ cScanlines ImageWidth: self \ dwWidth 0 \ Ysrc 0 \ Xsrc FIBITMAP FIGetBits \ *lpvBits FIBITMAP FIGetInfo \ *lpBmi Height Width 0 ( y-coord of dest upper-left corner ) \ ydest 0 ( x-coord of dest upper-left corner ) \ xdest ImageDC.hdc DrawDIBDC Call DrawDibDraw drop ; : ShowImage ( -- ) \ load and draw Image; keep Image size wipe-window DDF_SAME_HDC ImageHeight: self \ cScanlines ImageWidth: self \ dwWidth 0 \ Ysrc 0 \ Xsrc FIBITMAP FIGetBits \ *lpvBits FIBITMAP FIGetInfo \ *lpBmi -1 \ use -1 \ image size 0 ( y-coord of dest upper-left corner ) \ ydest 0 ( x-coord of dest upper-left corner ) \ xdest ImageDC.hdc \ hdc DrawDIBDC Call DrawDibDraw drop ; : check-bits ( -- ) BitsPerPixel: [ self ] case 8 of true Check: mnu8 false Enable: mnu8 false Check: mnu16 false Check: mnu24 false Check: mnu32 true Enable: mnu16 true Enable: mnu24 true Enable: mnu32 endof 16 of true Check: mnu16 false Enable: mnu16 false Check: mnu8 false Check: mnu24 false Check: mnu32 true Enable: mnu8 true Enable: mnu24 true Enable: mnu32 endof 24 of true Check: mnu24 false Enable: mnu24 false Check: mnu8 false Check: mnu16 false Check: mnu32 true Enable: mnu8 true Enable: mnu16 true Enable: mnu32 endof 32 of true Check: mnu32 false Enable: mnu32 false Check: mnu8 false Check: mnu16 false Check: mnu24 true Enable: mnu8 true Enable: mnu16 true Enable: mnu24 endof ( default ) false Check: mnu8 false Check: mnu16 false Check: mnu24 false Check: mnu32 true Enable: mnu8 true Enable: mnu16 true Enable: mnu24 true Enable: mnu32 endcase ; : check-mode ( -- ) ViewMode case NORMAL_FIT of true Check: mnunorm false Check: mnuscale false Check: mnufit endof BEST_FIT of false Check: mnunorm true Check: mnuscale false Check: mnufit endof FIT_SIZE of false Check: mnunorm false Check: mnuscale true Check: mnufit endof ( default ) false Check: mnunorm false Check: mnuscale false Check: mnufit endcase BackGroundColor WHITE = dup not Check: mnuBlack Check: mnuWhite check-bits ; : DisplayImage ( -- ) ValidImage? not if wipe-window exit then ViewMode case NORMAL_FIT of ShowImage endof BEST_FIT of ShowScaledImage endof FIT_SIZE of ShowImageInFixedWindow endof endcase check-mode ; :M SetViewMode: ( f -- ) to ViewMode hwnd if DisplayImage then ;M :M SetBackGroundColor: ( color_object -- ) to BackGroundColor hwnd if DisplayImage then ;M :M UnLoadImage: ( -- ) ValidImage? if FIBITMAP FIUnload drop 0 to FIBITMAP then ;M : LoadImage ( -- ) UnLoadImage: self ImageFileName c@ 0<> if \ get filetype 0 ImageFileName 1+ dup>r FIGetFileType dup FIF_UNKNOWN = if \ on some filetype's _FreeImage_GetFileType fails, so \ try to get the filetype from the filename drop r@ FIGetInfoFromFilename then dup FIF_UNKNOWN <> if \ open file 0 r@ rot FILoad to FIBITMAP else drop then r>drop then ; :M SetImageFile: ( addr cnt -- ) \ filename for image ImageFileName dup>r place r> +null LoadImage DisplayImage ;M :M Wipe: ( -- ) \ clear any image from window UnLoadImage: self DisplayImage ;M :M ImageFileName: ( -- addr cnt ) \ return name of image file FIBITMAP if ImageFileName count else pad 0 then ;M :M OpenImageFile: ( -- ) hwnd ?dup if Start: GetImageFile dup c@ if count SetImageFile: self else drop then then ;M :M SetImageFromMemory: ( flag blue green red depth pitch height width lpvbits -- ) FIConvertFromRawBits dup FIF_UNKNOWN <> if UnLoadImage: self to FIBITMAP DisplayImage else drop then ;M :M LoadMemoryBitmap: ( &bitmap -- ) FIF_BMP swap LoadFromHandle: self dup FIF_UNKNOWN <> if UnLoadImage: self to FIBITMAP DisplayImage else drop then ;M :M ReLoad: ( -- ) \ redraw using earlier set image LoadImage DisplayImage ;M :M Refresh: ( -- ) DisplayImage ;M : open-image ( -- ) OpenImageFile: self ; :M ClassInit: ( -- ) ClassInit: Super 0 to FIBITMAP WHITE to BackGroundColor NORMAL_FIT to ViewMode ImageFileName max-path erase true to dopopup? gen-id to id ['] open-image SetDblClickFunc: self \ double click opens file 0 to DrawDibDC ;M :M On_Paint: ( -- ) Refresh: self ;M :M On_Init: ( -- ) On_Init: super ImagePopupBar SetPopupBar: self GetDc: self dup Puthandle: ImageDC HALFTONE swap Call SetStretchBltMode drop \ better image quality Call DrawDibOpen to DrawDIBDC ;M :M On_Done: ( -- ) GetHandle: ImageDC ReleaseDC: self DrawDIBDC Call DrawDibClose drop UnLoadImage: self On_Done: super ;M :M WM_RBUTTONDOWN ( h m w l -- ) dopopup? if self to ThisImage check-mode \ for popup menu WM_RBUTTONDOWN WM: Super else DefWindowProc: self then ;M :M WM_LBUTTONDBLCLK ( h w m l -- ) dopopup? if WM_LBUTTONDBLCLK WM: Super else DefWindowProc: self then ;M :M EnablePopup: ( -- ) true to dopopup? ;M :M DisablePopup: ( -- ) false to dopopup? ;M : ?version3+ ( -- f ) FIGetVersion c@ '0' - 3 >= dup 0= s" Version 3.xx of FreeImage library required for this function" ?MessageBox ; :M FlipVertical: ( -- ) ValidImage? not ?exitm ?version3+ not ?exitm FIBITMAP FIFlipVertical drop Refresh: self ;M :M FlipHorizontal: ( -- ) ValidImage? not ?exitm ?version3+ not ?exitm FIBITMAP FIFlipHorizontal drop Refresh: self ;M :M SaveAsJpeg: ( -- ) FIF_JPEG JPEG_QUALITYGOOD SaveImage: self ;M :M SaveAsBmp: ( -- ) FIF_BMP BMP_DEFAULT SaveImage: self ;M :M SaveAsPng: ( -- ) FIF_PNG PNG_DEFAULT SaveImage: self ;M :M BitsPerPixel: ( -- n ) ValidImage? if FIBITMAP FIBitsPerPixel else 0 then ;M :M ConvertTo8Bits: ( -- ) ValidImage? not ?exitm BitsPerPixel: self 8 = ?exitm FIBITMAP FIConvertTo8Bits UnLoadImage: self to FIBITMAP Refresh: self ;M :M ConvertTo16Bits: ( -- ) ValidImage? not ?exitm BitsPerPixel: self 16 = ?exitm FIBITMAP FIConvertTo16Bits UnLoadImage: self to FIBITMAP Refresh: self ;M :M ConvertTo24Bits: ( -- ) ValidImage? not ?exitm BitsPerPixel: self 24 = ?exitm FIBITMAP FIConvertTo24Bits UnLoadImage: self to FIBITMAP Refresh: self ;M :M ConvertTo32Bits: ( -- ) ValidImage? not ?exitm BitsPerPixel: self 32 = ?exitm FIBITMAP FIConvertTo32Bits UnLoadImage: self to FIBITMAP Refresh: self ;M \ the following routines require floating point parameters :M RotateImage: ( fs: degrees -- ) \ float fdepth 0= abort" Floating point parameter missing!" fs>ds \ move float to data stack ValidImage? not ?version3+ not or if 2drop exitm then FIBITMAP FiRotate UnLoadImage: self to FIBITMAP Refresh: self ;M :M AdjustBrightness: ( fs: percentage -- ) \ float fdepth 0= abort" Floating point parameter missing!" fs>ds \ move float to data stack ValidImage? not ?version3+ not or if 2drop exitm then FIBITMAP FIAdjustBrightness drop Refresh: self ;M :M AdjustContrast: ( fs: percentage -- ) \ float fdepth 0= abort" Floating point parameter missing!" fs>ds \ move float to data stack ValidImage? not ?version3+ not or if 2drop exitm then FIBITMAP FIAdjustContrast drop Refresh: self ;M :M InvertImage: ( -- ) ValidImage? not ?exitm ?version3+ not ?exitm FIBITMAP FIInvert drop Refresh: self ;M :M ImageHandle: ( -- fibitmap ) FIBITMAP ;M :M SetImageHandle: ( fibitmap -- ) UnLoadImage: self to FIBITMAP ;M :M Clone: ( -- fibitmap ) ValidImage? if FIBITMAP FIClone else 0 then ;M :M Zoom: { w h -- } ValidImage? not ?exitm ?version3+ not ?exitm BitsPerPixel: self 32 <> if ConvertTo32Bits: self then FILTER_BILINEAR h w FIBITMAP FIReScale UnLoadImage: self to FIBITMAP Refresh: self ;M \ Performs gamma correction on a 8-, 24- or 32-bit image. The gamma parameter \ represents the gamma value to use (gamma > 0). A value of 1.0 leaves the image \ alone, less than one darkens it, and greater than one lightens it. :M AdjustGamma: ( fs: gamma -- ) \ float fdepth 0= abort" Floating point parameter missing!" fs>ds \ move float to data stack ValidImage? not ?version3+ not or if 2drop exitm then BitsPerPixel: self 8 < if 2drop exitm then FIBITMAP FIAdjustGamma drop Refresh: self ;M ;Class MODULE \s >SYSTEM : AS WINPROC-LAST @ PROC>CFA ALIAS ; SYSTEM> \ Usage 1 proc ExitThread as EXIT-TASK \ creates a Word that compiles or executes the Function call All exported functions from FreeImage.dll version 3.xx+ _FreeImage_AdjustBrightness@12 _FreeImage_AdjustContrast@12 _FreeImage_AdjustCurve@12 _FreeImage_AdjustGamma@12 _FreeImage_Allocate@24 _FreeImage_AppendPage@8 _FreeImage_Clone@4 _FreeImage_CloseMultiBitmap@8 _FreeImage_ColorQuantize@8 _FreeImage_ConvertFromRawBits@36 _FreeImage_ConvertLine16To24_555@12 _FreeImage_ConvertLine16To24_565@12 _FreeImage_ConvertLine16To32_555@12 _FreeImage_ConvertLine16To32_565@12 _FreeImage_ConvertLine16To8_555@12 _FreeImage_ConvertLine16To8_565@12 _FreeImage_ConvertLine16_555_To16_565@12 _FreeImage_ConvertLine16_565_To16_555@12 _FreeImage_ConvertLine1To16_555@16 _FreeImage_ConvertLine1To16_565@16 _FreeImage_ConvertLine1To24@16 _FreeImage_ConvertLine1To32@16 _FreeImage_ConvertLine1To8@12 _FreeImage_ConvertLine24To16_555@12 _FreeImage_ConvertLine24To16_565@12 _FreeImage_ConvertLine24To32@12 _FreeImage_ConvertLine24To8@12 _FreeImage_ConvertLine32To16_555@12 _FreeImage_ConvertLine32To16_565@12 _FreeImage_ConvertLine32To24@12 _FreeImage_ConvertLine32To8@12 _FreeImage_ConvertLine4To16_555@16 _FreeImage_ConvertLine4To16_565@16 _FreeImage_ConvertLine4To24@16 _FreeImage_ConvertLine4To32@16 _FreeImage_ConvertLine4To8@12 _FreeImage_ConvertLine8To16_555@16 _FreeImage_ConvertLine8To16_565@16 _FreeImage_ConvertLine8To24@16 _FreeImage_ConvertLine8To32@16 _FreeImage_ConvertTo16Bits555@4 _FreeImage_ConvertTo16Bits565@4 _FreeImage_ConvertTo24Bits@4 _FreeImage_ConvertTo32Bits@4 _FreeImage_ConvertTo8Bits@4 _FreeImage_ConvertToRawBits@32 _FreeImage_Copy@20 _FreeImage_CreateICCProfile@12 _FreeImage_DeInitialise@0 _FreeImage_DeletePage@8 _FreeImage_DestroyICCProfile@4 _FreeImage_Dither@8 _FreeImage_FIFSupportsExportBPP@8 _FreeImage_FIFSupportsICCProfiles@4 _FreeImage_FIFSupportsReading@4 _FreeImage_FIFSupportsWriting@4 _FreeImage_FlipHorizontal@4 _FreeImage_FlipVertical@4 _FreeImage_GetBPP@4 _FreeImage_GetBits@4 _FreeImage_GetBlueMask@4 _FreeImage_GetChannel@8 _FreeImage_GetColorType@4 _FreeImage_GetColorsUsed@4 _FreeImage_GetCopyrightMessage@0 _FreeImage_GetDIBSize@4 _FreeImage_GetDotsPerMeterX@4 _FreeImage_GetDotsPerMeterY@4 _FreeImage_GetFIFCount@0 _FreeImage_GetFIFDescription@4 _FreeImage_GetFIFExtensionList@4 _FreeImage_GetFIFFromFilename@4 _FreeImage_GetFIFFromFormat@4 _FreeImage_GetFIFFromMime@4 _FreeImage_GetFIFRegExpr@4 _FreeImage_GetFileType@8 _FreeImage_GetFileTypeFromHandle@12 _FreeImage_GetFormatFromFIF@4 _FreeImage_GetGreenMask@4 _FreeImage_GetHeight@4 _FreeImage_GetHistogram@12 _FreeImage_GetICCProfile@4 _FreeImage_GetInfo@4 _FreeImage_GetInfoHeader@4 _FreeImage_GetLine@4 _FreeImage_GetLockedPageNumbers@12 _FreeImage_GetPageCount@4 _FreeImage_GetPalette@4 _FreeImage_GetPitch@4 _FreeImage_GetRedMask@4 _FreeImage_GetScanLine@8 _FreeImage_GetTransparencyCount@4 _FreeImage_GetTransparencyTable@4 _FreeImage_GetVersion@0 _FreeImage_GetWidth@4 _FreeImage_Initialise@4 _FreeImage_InsertPage@12 _FreeImage_Invert@4 _FreeImage_IsLittleEndian@0 _FreeImage_IsPluginEnabled@4 _FreeImage_IsTransparent@4 _FreeImage_Load@12 _FreeImage_LoadFromHandle@16 _FreeImage_LockPage@8 _FreeImage_MovePage@12 _FreeImage_OpenMultiBitmap@20 _FreeImage_OutputMessageProc _FreeImage_Paste@20 _FreeImage_RegisterExternalPlugin@20 _FreeImage_RegisterLocalPlugin@20 _FreeImage_Rescale@16 _FreeImage_RotateClassic@12 _FreeImage_RotateEx@48 _FreeImage_Save@16 _FreeImage_SaveToHandle@20 _FreeImage_SetChannel@12 _FreeImage_SetOutputMessage@4 _FreeImage_SetPluginEnabled@8 _FreeImage_SetTransparencyTable@12 _FreeImage_SetTransparent@8 _FreeImage_Threshold@8 _FreeImage_Unload@4 _FreeImage_UnlockPage@12 _FreeImage_ZLibCompress@16 _FreeImage_ZLibUncompress@16 --- NEW FILE: FileLister.f --- \ FileLister.f List Files in a Folder \ Thursday, August 19 2004 - Ezra Boyce \ Code adapted from ProjectManager.f, a.k.a shamelessly ripped off :-) \ See the FileWindow class at end of file for available methods and uses anew -FileLister.f needs linklist.f needs treeview.f needs bitmap.f needs apps\forthform\quiksort.f load-bitmap folderbmp "apps\forthform\res\folder.bmp" : rootdir? { pathstr cnt -- f } \ f = true if path is at root pathstr cnt + 2 - w@ s" :\" drop w@ = ?dup ?exit pathstr cnt + 1- c@ ':' = ; \- ?exitm macro ?exitm " if exitm then" :Object FileFinder <Super Object max-path bytes findpath 32 bytes findspecs :M FindFirstFile: ( addr cnt -- ior ) \ ior = 0 = success find-first-file nip ;M :M FindNextFile: ( -- ior ) \ ior = 0 = success find-next-file nip ;M :M FindClose: ( -- ior ) \ ior = 0 = success find-close drop ;M :M GetFileAttributes: ( -- n ) _Win32-Find-Data @ ;M :M GetFileName: ( -- adr cnt ) get-file-name zcount ;M :M GetFileSize: ( -- d ) get-file-size ;M :M ClassInit: ( -- ) ClassInit: super findpath max-path erase s" *.*" findspecs place \ default ;M : .or..? ( -- f ) \ is found file directories . or ..? GetFileName: self drop c@ '.' = ; :M IsDirectory?: ( -- f ) \ exclude . and .. GetFileAttributes: self FILE_ATTRIBUTE_DIRECTORY and 0<> .or..? not and ;M :M IsFile?: ( -- f ) GetFileAttributes: self FILE_ATTRIBUTE_DIRECTORY and 0= ;M :M SetUp: ( pathstr len spec$ cnt -- ) \ pathstr len = pointer to path to search \ spec$ cnt = file specs to search for dup 0= if 2drop s" *.*" then 31 min 0max findspecs place findpath place ;M :M FindFiles: ( -- f ) \ specs should be already setup new$ >r findpath count r@ place findspecs count dup if r@ ?+\ then r@ +place r> count FindFirstFile: self ;M :M FullPath: ( -- addr cnt ) \ return full path of directory found findpath count new$ dup>r place GetFileName: self dup if r@ ?+\ then r@ +place r> count ;M ;Object :Class FolderItem <super Object record: iteminfo max-path 1+ bytes itemname int parenttree \ parent treeview control int parentitem \ parent item in treeview control int hwnditem \ handle for item short itemflags 2 bits itemid \ item id, 0 for child item 14 bits reservedflags ;recordsize: sizeof(iteminfo) int iconhandle cell bytes index \ save information for each individual file Record: Win32_Find_Data int FileAttributes int FileCreationTimeLow int FileCreationTimeHigh int FileLastAccessTimeLow int FileLastAccessTimeHigh int FileLastWriteTimeLow int FileLastWriteTimeHigh int FileSizeHigh int FileSizeLow int Reserved0 int Reserved1 max-path bytes FileName 14 bytes AlternateFileName ;RecordSize: sizeof(Win32_Find_Data) :M GetFileAttributes: ( -- n ) FileAttributes ;M :M GetFileName: ( -- adr cnt ) FileName zcount ;M :M GetFileSize: ( -- d ) FileSizeLow ;M : .or..? ( -- f ) \ is found file directories . or ..? GetFileName: self drop c@ '.' = ; :M IsFile?: ( -- f ) GetFileAttributes: self FILE_ATTRIBUTE_DIRECTORY and 0= ;M :M IsDirectory?: ( -- f ) \ exclude . and .. IsFile?: self not .or..? not and ;M :M classinit: ( -- ) classinit: super iteminfo sizeof(iteminfo) erase Win32_Find_Data sizeof(Win32_Find_Data) erase 0 to iconhandle -1 index ! ;M :m GetData: ( -- addr cnt ) \ access for any additional information needed Win32_Find_Data sizeof(Win32_Find_Data) ;m :M setname: ( addr cnt -- ) \ assumes name is set for FindFirstFile, FindNextFile etc. itemname max-path erase max-path min 0max itemname swap move \ transfer the info _Win32-Find-Data Win32_Find_Data sizeof(Win32_Find_Data) move ;M :m getname: ( -- addrz ) itemname ;m :m getname$: ( -- addr cnt ) itemname zcount ;m :m isparentitem: ( n -- ) to parentitem ;m :m parentitem: ( -- n ) parentitem ;m :m isparenttree: ( n -- ) to parenttree ;m :m parenttree: ( -- n ) parenttree ;m :m handle: ( -- hwnd ) hwnditem ;m :m ishandle: ( n -- ) to hwnditem ;m :m itemid: ( -- f ) itemid ;m :m isitemid: ( f -- ) to itemid ;m :m iconhandle: ( -- n ) iconhandle ;m :m isiconhandle: ( n -- ) to iconhandle ;m :m index: ( -- n ) index @ ;m :m isindex: ( n -- ) index ! ;m :M AddIcon: ( -- ) index itemname conhndl Call ExtractAssociatedIcon to iconhandle ;M /* Windows API say the following isn't necessary :M ~: ( -- ) iconhandle ?dup if Call DestroyIcon drop 0 to iconhandle then ;M */ ;class :Class TreeList <super linked-list int hwndlist int itemid 32 constant listmax \ maximum length of list name listmax 1+ bytes listname :m handle: ( -- n ) hwndlist ;m :m ishandle: ( hwnd -- ) to hwndlist ;m :m itemid: ( -- f ) itemid ;m :m isitemid: ( f -- ) to itemid ;m :m setname: ( addr cnt -- ) listname dup listmax erase swap listmax min 0max move ;m :m getname: ( -- namez ) listname ;m :m classinit: ( -- ) classinit: super s" .." setname: self -1 isitemid: self ;m \ identifies parent :m DeleteItem: { item \ flag -- } Data@: self 0= ?exitm false to flag #Links: self 1+ 1 ?do i >Link#: self Data@: self item = if 0 Data!: self DeleteLink: self item dispose true to flag \ mark as found leave then loop flag 0= abort" Item not found in list!" ;m :m total: ( -- n ) Data@: self if #links: self else 0 then ;m :m GetEntry: { n -- obj | 0 } 0 total: self 0= ?exitm n 1 total: self between not ?exitm drop n >Link#: self Data@: self ;m ;class :Class FolderTree <super TreeViewControl int ThisItem \ temp pointer to new item int hwndmain \ handle of root item in tree int hwndimage \ handle to imagelist int FolderList int sortorder int tree-click \ called when an item is clicked int on_update \ called when folder tree is refreshed int SelectedItem \ tree item object int show-files? \ do we want to display files as well as directories? int #dirs \ number of directories found when updating int #fls \ ditto files max-path bytes thespecs int hwndlabel \ handle to window to display path \ number of files shown is limited only by available memory \ however only first 4k will be sorted. Of course the buffer size could always be increased 16 1024 * constant recbuffer-size recbuffer-size cell / constant max-recs \ about 4000 files and directories for sorting int recbuffer \ pointer to memory used for sorting 2 cells bytes rootname max-path 1+ bytes Treepath : free-recbuffer ( -- ) recbuffer ?dup if release 0 to recbuffer then ; :M Handle: ( -- hwndmain ) hwndmain ;M :m SetRootName: ( addr cnt -- ) rootname 2 cells erase rootname swap move ;m :m Setpath: { addr cnt -- } \ check for valid path addr cnt + 2 - w@ 0x5C3A = \ are the last chars ':\' i.e root dir? if addr cnt treepath place treepath +null exitm then addr cnt find-first-file ?exitm \ does not exist so exit @ FILE_ATTRIBUTE_DIRECTORY and \ something was found if addr cnt treepath place \ it is a directory treepath +null then find-close drop ;M :m Getpath: ( -- addr cnt ) treepath count ;M :M SetSpecs: ( addr cnt -- ) thespecs place ;M :M GetSpecs: ( -- addr cnt ) thespecs count ;M :M IsLabelHandle: ( hwnd -- ) to hwndlabel ;M : CreateImageList ( -- ) \ create image list for treeview control total: folderlist 2 + \ maximum images dup 2 max \ number of images to use ILC_COLOR4 \ color depth 18 16 \ bitmap size height,width Call ImageList_Create to hwndimage ; : RegisterList ( -- ) \ register list with this treeview control hwndimage ?dup 0= ?exit TVSIL_NORMAL TVM_SETIMAGELIST hwnd send-window ; : add-icons { \ item -- } \ add icon for each file total: folderlist 1+ 1 ?do i >Link#: FolderList Data@: FolderList to item IconHandle: item hwndimage Call ImageList_AddIcon dup -1 <> if isindex: item else drop then loop ; \ A folder has a default icon to represent it but I find it displays kinda dark in the \ treeview imagelist. I am sure it is simply something I am missing about image lists \ but for now I will use my own folder bitmap to represent folders in the treeview : Add-folderbmp { \ hbitmap -- } hwndimage 0= ?exit \ we don't have any folderbmp usebitmap map-3dcolors \ create bitmap handle GetDc: self dup>r CreateDIBitmap to hbitmap r> ReleaseDc: self hbitmap \ was it successful? if NULL \ no overlay image list hbitmap hwndimage Call ImageList_Add drop hbitmap Call DeleteObject drop \ discard, windows has a copy then ; : AddImages ( -- ) CreateImageList RegisterList Color: WHITE hwndimage Call ImageList_SetBkColor drop add-folderbmp add-icons ; : ?Hasfiles ( -- f ) \ does a directory have any files? IsDirectory?: ThisItem if treepath count pad place pad ?+\ s" *.*" pad +place \ not necessarily the "thespecs" value pad count find-first-file nip 0= if find-close drop 1 else 0 then else 0 then ; : ?itemimage ( -- n ) IsDirectory?: ThisItem if 1 \ use my folder bitmap for directory entries else index: ThisItem \ use associated file icon then ; : AddTreeItem ( -- ) \ add file or directory to tree tvins /tvins erase tvitem /tvitem erase ?HasFiles to cChildren Handle: FolderList to hParent TVI_LAST to hInsertAfter GetName$: ThisItem "to-pathend" asciiz to pszText ThisItem to lparam ?itemimage dup to iImage to iSelectedImage [ TVIF_TEXT TVIF_CHILDREN or TVIF_PARAM or TVIF_IMAGE or TVIF_SELECTEDIMAGE or ] LITERAL to mask tvitem->tvins tvins 0 TVM_INSERTITEMA hWnd Call SendMessage IsHandle: ThisItem ; : UpdateList ( addr cnt -- ) \ save file info SetName: ThisItem FolderList IsParentItem: ThisItem self IsParentTree: ThisItem IsDirectory?: Thisitem isitemid: ThisItem AddIcon: ThisItem ; : add-items ( -- ) \ actually add found files to tree AddImages >FirstLink: FolderList #dirs 0 \ directories first ?do Data@: FolderList to ThisItem AddTreeItem >NextLink: FolderList loop show-files? #fls 0<> and \ and then files if #dirs 1+ dup >Link#: FolderList total: FolderList 1+ swap ?do Data@: FolderList to ThisItem AddTreeItem >NextLink: FolderList loop then ; : AddFile ( str cnt -- ) Data@: FolderList if AddLink: FolderList then New> FolderItem dup Data!: FolderList to ThisItem ( str cnt ) UpdateList ; : ?rootimage ( -- n ) rootname zcount rootdir? 1 and ; : AddRoot ( -- ) tvins /tvins erase tvitem /tvitem erase 1 to cChildren \ assuming we have TVI_ROOT to hParent TVI_LAST to hInsertAfter Folderlist to lparam getname: lparam to pszText ?rootimage dup to iImage to iSelectedImage [ TVIF_TEXT TVIF_CHILDREN or TVIF_PARAM or TVIF_IMAGE or TVIF_SELECTEDIMAGE or ] LITERAL to mask tvitem->tvins tvins 0 TVM_INSERTITEMA hWnd Call SendMessage dup ishandle: FolderList to hwndmain ; : CreateTree ( -- ) new> treelist to FolderList rootname zcount SetName: FolderList ; :M start: ( parent -- ) start: super CreateTree AddRoot recbuffer-size malloc to recbuffer ;M :m Classinit: ( -- ) Classinit: super 0 to SelectedItem s" .." setrootname: self treepath off s" *.*" thespecs place ['] drop to tree-click ['] drop to on_update 0 to SelectedItem true to show-files? 0 to #dirs 0 to #fls 0 to hwndlabel 0 to recbuffer SortAscending: [ self ] ;m : DisposeTheList ( -- ) FolderList if Folderlist DisposeList FolderList Dispose 0 to FolderList then ; :M WindowStyle: ( -- style ) WindowStyle: super TVS_HASLINES or TVS_HASBUTTONS or TVS_DISABLEDRAGDROP or TVS_SHOWSELALWAYS or TVS_LINESATROOT or ;M :m ~: ( -- ) DisposeTheList free-recbuffer ;m :m Close: ( -- ) DisposeTheList free-recbuffer hwndimage ?dup if Call ImageList_Destroy drop then Close: super ;m : FindAllFiles ( -- ) path-ptr >r thespecs to path-ptr 0 to #dirs 0 to #fls \ we get all directories first TreePath count s" *.*" Setup: FileFinder FindFiles: FileFinder begin 0= while IsDirectory?: FileFinder if FullPath: FileFinder AddFile 1 +to #dirs then FindNextFile: FileFinder repeat FindClose: FileFinder \ now we get the rest of the files first-path" begin dup 0> while TreePath count 2swap SetUp: FileFinder FindFiles: FileFinder begin 0= while IsFile?: FileFinder if FullPath: FileFinder AddFile 1 +to #fls then FindNextFile: FileFinder repeat FindClose: FileFinder next-path" repeat 2drop r> to path-ptr ; : recbuffer() ( n -- addr ) recbuffer +cells ; :M SortAscending: ( -- ) ['] 0< to sortorder ;M :M SortDescending: ( -- ) ['] 0> to sortorder ;M \ : null-check ( a1 -- a1 ) \ ?win-error-enabled 0= \ if dup 0= \ if drop ['] noop \ convert null to NOOP \ exit \ and exit \ then \ then \ dup 0= s" Attempt to execute a NULL function" ?TerminateBox \ ; : dosortorder ( n -- f ) sortorder null-check execute ; : compare-recs ( n1 n2 -- f ) GetName$: [ swap ] "to-pathend" GetName$: [ rot ] "to-pathend" caps-compare dosortorder ; : readrecbuffer ( -- ) \ load temporary buffer with record pointers >FirstLink: FolderList total: FolderList max-recs min 0max 0 ?do Data@: FolderList i recbuffer() ! >NextLink: FolderList loop ; : writerecbuffer ( -- ) \ rewrite sorted records to database >FirstLink: FolderList total: FolderList max-recs min 0max 0 ?do i recbuffer() @ Data!: FolderList >NextLink: FolderList loop ; : sortfiles ( -- ) recbuffer 0= ?exit \ if not allocated abort sorting ['] compare-recs is precedes \ set sort comparator total: folderlist 2 < ?exit readrecbuffer \ load buffer #dirs 1 > if 0 recbuffer() #dirs sort \ sort the directories then #fls 1 > if #dirs recbuffer() #fls sort \ and the files then writerecbuffer ; : show-path ( -- ) hwndlabel 0= ?exit hwndlabel Call IsWindow 0= ?exit treepath count asciiz 0 WM_SETTEXT hwndlabel send-window ; :M UpdateFiles: ( -- ) treepath c@ 0= if current-dir$ count setpath: self then TreePath count rootdir? \ if at root can't go up a level if Treepath dup ?+\ +NULL TreePath count else s" .." \ indicates ability to ascend then SetRootName: self Close: self \ clear tree parent Start: self \ and restart _Win32-Find-Data [ 11 cells max-path + 14 + ] LITERAL erase FindAllFiles SortFiles add-items show-path hwndmain ToggleExpandItem: self self On_Update null-check execute \ user function ;M :M ascend: ( -- ) GetPath: self 2dup rootdir? if 2drop exitm then 2dup + swap '\' -scan drop over - SetPath: self Updatefiles: self ;m :m descend: ( --) SelectedItem 0= ?exitm IsDirectory?: SelectedItem not ?exitm GetName$: SelectedItem SetPath: self Updatefiles: self ;m :M On_SelChanged: ( -- f ) \ lparamNew to SelectedItem SelectedItem tree-click null-check execute false ;M :m DeleteFile: ( -- ) Selecteditem 0= ?exitm itemid: SelectedItem 0<> ?exitm \ can't delete folder or root s" Delete " new$ dup>r place getname$: SelectedItem r@ +place s" ?" r@ +place r@ +NULL r> 1+ ( sztext ) z" Are you sure?" ( ztitle ) MB_YESNO ( style ) MessageBox: parent IDNO = ?exitm Getname$: SelectedItem delete-file dup s" Delete file failed" ?MessageBox ?exitm handle: SelectedItem \ save it SelectedItem dup parentitem: [ ] DeleteItem: [ ] ( handle ) \ lparam 0 \ wparam TVM_DELETEITEM \ msg hwnd send-window 0 to SelectedItem UpdateFiles: self ;m :M SelectedItem: ( -- n ) SelectedItem ;M :M #Dirs: ( -- n ) #dirs ;M :M #Files: ( -- n ) #fls ;m :M Showfiles: ( f -- ) to show-files? ;m :M IsOn_Update: ( cfa -- ) to on_update ;m :M IsTree-Click: ( cfa -- ) to tree-click ;m :M FileList: ( -- list ) FolderList ;M ;Class :Class FileWindow <Super Child-Window FolderTree ThisFolder int tree-dblclick int wstyle \ additional window style e.g WS_BORDER :M ClassInit: ( -- ) ClassInit: Super ['] drop to tree-dblclick NextId to ID 0 to wstyle ;M :M On_Init: ( -- ) self Start: ThisFolder Updatefiles: ThisFolder ;m :M WindowStyle: ( -- style ) WindowStyle: super wstyle or ;M \ add in user style :M AddStyle: ( n -- ) to wstyle ;M :M On_Size: ( -- ) autosize: thisfolder ;M :M #Dirs: ( -- n ) #dirs: thisfolder ;M :M #Files: ( -- n ) #files: thisfolder ;m :M Showfiles: ( f -- ) \ allow or disallow display of files in tree showfiles: thisfolder ;m :M IsOn_Update: ( cfa -- ) \ cfa to execute whenever the display is updated ison_update: thisfolder ;m :M IsTree-Click: ( cfa -- ) \ set cfa to be executed when item in tree is clicked istree-click: thisfolder ;m :M IsTree-Dblclick: ( cfa -- ) \ set cfa to be executed when item in tree is double-clicked to tree-dblclick ;M :M TheFolderTree: ( -- obj ) \ direct access to the tree Addr: ThisFolder ;M :M UpdateFiles: ( -- ) \ update the display UpdateFiles: ThisFolder ;M :M SetPath: ( addr cnt -- ) \ set for valid path SetPath: ThisFolder ;M :M GetPath: ( -- addr cnt ) GetPath: ThisFolder ;M :M SetSpecs: ( addr cnt -- ) \ e.g s" *.f;*.seq;*.frm;*.txt" SetSpecs: Thisfolder ;M :M GetSpecs: ( -- addr cnt ) GetSpecs: ThisFolder ;M :M IsLabelhandle: ( hwnd -- ) \ handle of window that will display path name IsLabelHandle: ThisFolder ;M :M SortAscending: ( -- ) SortAscending: ThisFolder ;M :M SortDescending: ( -- ) SortDescending: ThisFolder ;M :M DeleteFile: ( -- ) \ delete selected file after confirmation DeleteFile: ThisFolder ;M :M SelectedItem: ( -- ) \ selected file or directory, itemid = 0 means it is a file SelectedItem: ThisFolder ;M :M Total: ( -- n ) \ sum of files and directories #dirs: self #files: self + ;M :M FileList: ( -- list ) FileList: ThisFolder ;M :M ChooseFolder: ( -- ) \ change folder programatically, also available by right clicking hwnd 0= ?exitm z" Select a drive or folder" \ use a copy of path because if cancelled path info is changed to null GetPath: self pad place pad hwnd BrowseForFolder if pad count SetPath: self UpdateFiles: self then ;M :M Close: ( -- ) Close: ThisFolder Close: Super ;M :M WM_NOTIFY ( h m w l -- f ) dup @ GetHandle: ThisFolder = if dup 2 cells+ @ case \ check for double click NM_DBLCLK of ItemId: [ SelectedItem: ThisFolder ] dup 0= \ is a file? if drop SelectedItem: ThisFolder tree-dblclick null-check execute else -1 = \ .. selection? if ascend: ThisFolder else descend: ThisFolder then then endof \ right click in treeview opens browseforfolder dialog NM_RCLICK of ChooseFolder: self endof endcase Handle_Notify: ThisFo... [truncated message content] |
