1 unit MainForm; 2 3 interface 4 5 uses 6 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 7 Dialogs, Menus, FreeBitmap, ComCtrls, ImgList, ToolWin; 8 9 type 10 TfwbMainForm = class(TForm) 11 MainMenu: TMainMenu; 12 mnuFile: TMenuItem; 13 mnuFileOpen: TMenuItem; 14 mnuExit: TMenuItem; 15 OD: TOpenDialog; 16 StatusBar: TStatusBar; 17 mnuImage: TMenuItem; 18 mnuImageFlip: TMenuItem; 19 mnuFlipHorz: TMenuItem; 20 mnuFlipVert: TMenuItem; 21 mnuConvert: TMenuItem; 22 mnuTo8Bits: TMenuItem; 23 mnuTo16Bits555: TMenuItem; 24 mnuTo16Bits565: TMenuItem; 25 mnuTo24Bits: TMenuItem; 26 mnuTo32Bits: TMenuItem; 27 mnuDither: TMenuItem; 28 mnuQuantize: TMenuItem; 29 mnuGrayScale: TMenuItem; 30 mnuRotate: TMenuItem; 31 mnuClockwise: TMenuItem; 32 mnuAntiClockwise: TMenuItem; 33 mnuInvert: TMenuItem; 34 mnuClear: TMenuItem; 35 mnuTo4Bits: TMenuItem; 36 tbTools: TToolBar; 37 btnCopy: TToolButton; 38 ImageList1: TImageList; 39 ToolButton1: TToolButton; 40 btnPaste: TToolButton; 41 btnClear: TToolButton; 42 btnOpen: TToolButton; 43 ToolButton3: TToolButton; 44 ToolButton4: TToolButton; 45 procedure FormDestroy(Sender: TObject); 46 procedure FormPaint(Sender: TObject); 47 procedure FormCreate(Sender: TObject); 48 procedure mnuExitClick(Sender: TObject); 49 procedure mnuFileOpenClick(Sender: TObject); 50 procedure FormResize(Sender: TObject); 51 procedure mnuFlipHorzClick(Sender: TObject); 52 procedure btnCopyClick(Sender: TObject); 53 procedure btnClearClick(Sender: TObject); 54 procedure btnPasteClick(Sender: TObject); 55 private 56 FBitmap: TFreeWinBitmap; 57 procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND; 58 public 59 { Public declarations } 60 end; 61 62 var 63 fwbMainForm: TfwbMainForm; 64 65 implementation 66 67 {$R *.dfm} 68 69 uses 70 FreeUtils, FreeImage, Math; 71 72 procedure TfwbMainForm.FormDestroy(Sender: TObject); 73 begin 74 if Assigned(FBitmap) then 75 FBitmap.Free; 76 end; 77 78 procedure TfwbMainForm.FormPaint(Sender: TObject); 79 var 80 dx, dy, w, h: Integer; 81 r1, r2: Double; 82 R: TRect; 83 begin 84 if FBitmap.IsValid then // draw the bitmap 85 begin 86 // determine paint rect 87 r1 := FBitmap.GetWidth / FBitmap.GetHeight; 88 r2 := ClientWidth / ClientHeight; 89 if r1 > r2 then // fit by width 90 begin 91 w := ClientWidth; 92 h := Floor(w / r1); 93 dx := 0; 94 dy := (ClientHeight - h) div 2; 95 end 96 else // fit by height 97 begin 98 h := ClientHeight; 99 w := Floor(h * r1); 100 dy := 0; 101 dx := (ClientWidth - w) div 2; 102 end; 103 with ClientRect do 104 R := Bounds(Left + dx, Top + dy, w, h); 105 FBitmap.Draw(Canvas.Handle, R); 106 107 // erase area around the image 108 Canvas.Brush.Color := Color; 109 if dx > 0 then 110 begin 111 with ClientRect do 112 R := Bounds(Left, Top, dx, ClientHeight); 113 Canvas.FillRect(R); 114 with ClientRect do 115 R := Bounds(Right - dx, Top, dx, ClientHeight); 116 Canvas.FillRect(R); 117 end else 118 if dy > 0 then 119 begin 120 with ClientRect do 121 R := Bounds(Left, Top, ClientWidth, dy); 122 Canvas.FillRect(R); 123 with ClientRect do 124 R := Bounds(Left, Bottom - dy, ClientWidth, dy); 125 Canvas.FillRect(R); 126 end 127 end 128 else // clear 129 begin 130 Canvas.Brush.Color := Color; 131 Canvas.FillRect(ClientRect); 132 end 133 end; 134 135 procedure TfwbMainForm.FormCreate(Sender: TObject); 136 begin 137 FBitmap := TFreeWinBitmap.Create; 138 139 mnuImage.Enabled := FBitmap.IsValid; 140 OD.Filter := FIU_GetAllFilters; 141 end; 142 143 procedure TfwbMainForm.mnuExitClick(Sender: TObject); 144 begin 145 Close; 146 end; 147 148 procedure TfwbMainForm.mnuFileOpenClick(Sender: TObject); 149 var 150 t: Cardinal; 151 begin 152 if OD.Execute then 153 begin 154 t := GetTickCount; 155 FBitmap.Load(OD.FileName); 156 t := GetTickCount - t; 157 mnuImage.Enabled := FBitmap.IsValid; 158 StatusBar.Panels[0].Text := 'Loaded in ' + IntToStr(t) + ' msec.'; 159 StatusBar.Panels[1].Text := Format('%dx%d', [FBitmap.GetWidth, FBitmap.GetHeight]); 160 Invalidate; 161 end; 162 end; 163 164 procedure TfwbMainForm.FormResize(Sender: TObject); 165 begin 166 Invalidate 167 end; 168 169 procedure TfwbMainForm.WMEraseBkgnd(var Message: TMessage); 170 begin 171 Message.Result := 1; 172 end; 173 174 procedure TfwbMainForm.mnuFlipHorzClick(Sender: TObject); 175 begin 176 with FBitmap do 177 if Sender = mnuFlipHorz then 178 FLipHorizontal else 179 if Sender = mnuFlipVert then 180 FlipVertical else 181 if Sender = mnuTo4Bits then 182 ConvertTo4Bits else 183 if Sender = mnuTo8Bits then 184 ConvertTo8Bits else 185 if Sender = mnuTo16Bits555 then 186 ConvertTo16Bits555 else 187 if Sender = mnuTo16Bits565 then 188 ConvertTo16Bits565 else 189 if Sender = mnuTo24Bits then 190 ConvertTo24Bits else 191 if Sender = mnuTo32Bits then 192 ConvertTo32Bits else 193 if Sender = mnuDither then 194 Dither(FID_FS) else 195 if Sender = mnuQuantize then 196 ColorQuantize(FIQ_WUQUANT) else 197 if Sender = mnuGrayScale then 198 ConvertToGrayscale else 199 if Sender = mnuClockwise then 200 Rotate(-90) else 201 if Sender = mnuAntiClockwise then 202 Rotate(90) else 203 if Sender = mnuInvert then 204 Invert else 205 if Sender = mnuClear then 206 Clear; 207 Invalidate; 208 end; 209 210 procedure TfwbMainForm.btnCopyClick(Sender: TObject); 211 begin 212 if FBitmap.IsValid then FBitmap.CopyToClipBoard(Handle); 213 end; 214 215 procedure TfwbMainForm.btnClearClick(Sender: TObject); 216 begin 217 FBitmap.Clear; 218 Invalidate; 219 end; 220 221 procedure TfwbMainForm.btnPasteClick(Sender: TObject); 222 begin 223 FBitmap.PasteFromClipBoard; 224 Invalidate; 225 end; 226 227 end. 228