MathgeomGLS

1
unit faBitmap;
2

3
interface
4

5
uses
6
  Winapi.Windows,
7
  Winapi.Messages,
8
  System.SysUtils,
9
  System.Variants,
10
  System.Classes,
11
  Vcl.Graphics,
12
  Vcl.Controls,
13
  Vcl.Forms,
14
  Vcl.Dialogs,
15
  Vcl.StdCtrls,
16
  Vcl.Buttons,
17
  Vcl.ExtCtrls,
18
  Vcl.ExtDlgs,
19
  Vcl.Imaging.Jpeg,
20

21
  Graf.Global1d;
22

23
type
24
  TBitmapForm = class(TForm)
25
    Label1: TLabel;
26
    EditScale: TEdit;
27
    UnitRG: TRadioGroup;
28
    Label2: TLabel;
29
    EditWidth: TEdit;
30
    Label3: TLabel;
31
    EditHeight: TEdit;
32
    OKBitBtn: TBitBtn;
33
    SavePictureDialog: TSavePictureDialog;
34
    WidthLabel: TLabel;
35
    HeightLabel: TLabel;
36
    ColorDialog: TColorDialog;
37
    Label6: TLabel;
38
    EditBorder: TEdit;
39
    ColorButton: TSpeedButton;
40
    CloseBitBtn: TBitBtn;
41
    Label4: TLabel;
42
    procedure FormCreate(Sender: TObject);
43
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
44
    procedure FloatKeyPress(Sender: TObject; var Key: Char);
45
    procedure ScaleKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
46
    procedure numKeyPress(Sender: TObject; var Key: Char);
47
    procedure WidthKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
48
    procedure HeightKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
49
    procedure UnitRGClick(Sender: TObject);
50
    procedure EditBorderKeyPress(Sender: TObject; var Key: Char);
51
    procedure FormShow(Sender: TObject);
52
    procedure ColorButtonClick(Sender: TObject);
53
    procedure EditBorderKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
54
    procedure CloseBitBtnClick(Sender: TObject);
55
  private
56
    bmpScale: double;
57
    bmpWidth: integer;   { as pixels }
58
    bmpHeight: integer;  { as pixels }
59
    BorderWidth: integer;
60
    BorderColor: TColor;
61
    procedure ShowData(Sender: TObject);
62
    function PixelTomm(v: integer): double;
63
    function PixelTocm(v: integer): double;
64
    function PixelToInch(v: integer): double;
65
    function mmToPixel(v: double): integer;
66
    function cmToPixel(v: double): integer;
67
    function InchToPixel(v: double): integer;
68
  end;
69

70
var
71
  BitmapForm: TBitmapForm;
72

73
//=====================================================================
74
implementation
75
//=====================================================================
76

77
uses
78
  faGraf1D;
79

80
{$R *.dfm}
81

82
procedure TBitmapForm.FormCreate(Sender: TObject);
83
begin
84
  with Layout do
85
  begin
86
    if bmpScale = 0 then
87
    begin
88
      Left := (Screen.Width - Width) div 2;
89
      Top := (Screen.Height - Height) div 2;
90
      UnitRG.ItemIndex := 0;
91
      bmpScale := 1;
92
      BorderColor := ClRed;
93
      BorderWidth := 5;
94
    end
95
    else
96
    begin
97
      Left := BitmapLeft;
98
      Top := BitmapTop;
99
      UnitRG.ItemIndex := BitmapUnit;
100
      bmpScale := BitmapScale;
101
      BorderColor := BitmapBorderColor;
102
      BorderWidth := BitmapBorderWidth;
103
    end;
104
  end;
105
  bmpWidth := round(bmpScale*MainForm.GLViewer.Width);
106
  bmpHeight := round(bmpScale*MainForm.GLViewer.Height);
107

108
  ShowData(Sender);
109
end;
110

111
procedure TBitmapForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
112
var
113
  BorderRect: TRect;
114
  GraphRect: TRect;
115
  bmp: TBitmap;
116
  jpg: TJPEGImage;
117
  filebmp: TBitmap;
118
  fName: TFileName;
119
  isJpeg: Boolean;
120

121
  function ScanText(const s: string): string;
122
  var
123
    i: integer;
124

125
  begin
126
    Result := s;
127
    for i := 1 to Length(s) do
128
    if CharInSet(Result[i], ['/', '\', ':', '*', '?', '<', '>', '|'])
129
    then Result[i] := ' ';
130
  end;
131

132
begin
133
  if ModalResult = mrOK then
134
  begin
135
    isJpeg := pos('.jpg', Caption) > 0;
136

137
    BorderRect := Rect(BorderWidth div 2, BorderWidth div 2,
138
                       bmpWidth - BorderWidth div 2 + 1,
139
                       bmpHeight - BorderWidth div 2 + 1);
140
    GraphRect := Rect(0, 0, bmpWidth - 2*BorderWidth,
141
                            bmpHeight - 2*BorderWidth);
142

143
    with SavePictureDialog do
144
    begin
145
      FName := ScanText(GraphData.PlotData.TextStr);
146

147
      if isJpeg then
148
      begin
149
        Filter := 'Jpeg (*.jpg)|*.jpg';
150
        Title := 'Save Graph as ''.jpg'' File';
151
        FileName := FName+'.jpg';
152
      end
153
      else
154
      begin
155
        Filter := 'Bitmaps (*.bmp)|*.bmp';
156
        Title := 'Save Graph as ''.bmp'' File';
157
        FileName := FName+'.bmp';
158
      end;
159

160
      InitialDir := ImagePath;
161
      if Execute then
162
      begin
163
        jpg := nil;
164
        if isJpeg then
165
        begin
166
          jpg := TJPEGImage.Create;
167
          jpg.CompressionQuality := 100;
168
        { default is 90; range 1..100; 100 best quality }
169
        end;
170
        bmp := TBitmap.Create;
171

172
        filebmp := TBitmap.Create;
173
        try
174
          bmp.PixelFormat := pf32bit;
175
        { bmp is a device-independent true-color 32 bits per pixel bitmap. }
176
          with GraphRect do
177
          begin
178
            bmp.Width := Right - Left;
179
            bmp.Height := Bottom - Top;
180
          end;
181

182
          filebmp.PixelFormat := pf32bit;
183
          with BorderRect do
184
          begin
185
            filebmp.Width := Right - Left + BorderWidth -1;
186
            filebmp.Height := Bottom - Top + BorderWidth -1;
187
          end;
188

189
          MainForm.GLViewer.Invalidate;;
190

191
          with MainForm.GLMemoryViewer do
192
          begin
193
            Width := bmp.Width;
194
            Height := bmp.Height;
195
            Buffer.BackgroundColor := GraphData.BackColor;
196
            Render;
197
            bmp := Buffer.CreateSnapShotBitmap;
198
          end;
199

200
          filebmp.Canvas.Pen.Color := BorderColor;
201
          filebmp.Canvas.Pen.Width := BorderWidth;
202
          filebmp.Canvas.Rectangle(BorderRect);
203
          filebmp.Canvas.Draw(BorderWidth, BorderWidth, bmp);
204
          if isJpeg then
205
          begin
206
            jpg.Assign(filebmp);
207
            jpg.SaveToFile(FileName);
208
          end
209
          else filebmp.SaveToFile(FileName);
210
        finally
211
          bmp.Free;
212
          filebmp.Free;
213
          if isJpeg then jpg.Free;
214
        end;
215
        ImagePath := ExtractFilePath(FileName);
216
        ImagePath := IncludeTrailingPathDelimiter(ImagePath);
217
      end;
218
    end;
219
  end;
220
  with Layout do
221
  begin
222
    BitmapLeft := Left;
223
    BitmapTop := Top;
224
    BitmapUnit := UnitRG.ItemIndex;
225
    BitmapScale := bmpScale;
226
    BitmapBorderColor := BorderColor;
227
    BitmapBorderWidth := BorderWidth;
228
  end;
229
end;
230

231
procedure TBitmapForm.FormShow(Sender: TObject);
232
begin
233
  UnitRG.SetFocus;
234
  UnitRG.ItemIndex := 0;
235
  UnitRGClick(Sender);
236
  EditScale.SetFocus;
237
end;
238

239
procedure TBitmapForm.ColorButtonClick(Sender: TObject);
240
begin
241
  ColorDialog.Color := BorderColor;
242
  if ColorDialog.Execute then BorderColor := ColorDialog.Color;
243
end;
244

245
procedure TBitmapForm.EditBorderKeyPress(Sender: TObject; var Key: Char);
246
begin
247
  if not CharInSet(Key, ['0'..'9', #8]) then Key := #0
248
end;
249

250
procedure TBitmapForm.EditBorderKeyUp(Sender: TObject; var Key: Word;
251
                                      Shift: TShiftState);
252
var
253
  v: integer;
254

255
begin
256
  try
257
    v := StrToInt(EditBorder.Text);
258
  except
259
    v := 10;
260
  end;
261
  BorderWidth := v;
262
  ShowData(Sender);
263
end;
264

265
procedure TBitmapForm.FloatKeyPress(Sender: TObject; var Key: Char);
266
begin
267
  with Sender as TEdit do
268
  if not CharInSet(Key, ['0'..'9', '.', #8]) then Key := #0
269
end;
270

271
procedure TBitmapForm.ScaleKeyUp(Sender: TObject; var Key: Word;
272
                                 Shift: TShiftState);
273
begin
274
  try
275
    bmpScale := StrToFloat(EditScale.Text);
276
  except
277
    bmpScale := 1.0;
278
  end;
279
  bmpWidth := round(bmpScale*MainForm.GLViewer.Width);
280
  bmpHeight := round(bmpScale*MainForm.GLViewer.Height);
281
  ShowData(Sender);
282
end;
283

284
procedure TBitmapForm.numKeyPress(Sender: TObject; var Key: Char);
285
begin
286
  with Sender as TEdit do
287
  begin
288
    if UnitRG.ItemIndex = 0 then
289
    begin
290
      if not CharInSet(Key,['0'..'9', #8]) then Key := #0
291
    end
292
    else if not CharInSet(Key, ['0'..'9', '.', #8]) then Key := #0
293
  end;
294
end;
295

296
procedure TBitmapForm.WidthKeyUp(Sender: TObject; var Key: Word;
297
                                 Shift: TShiftState);
298
var
299
  v: double;
300

301
begin
302
  try
303
    v := StrToFloat(EditWidth.Text);
304
  except
305
    v := bmpScale*MainForm.GLViewer.Width;
306
  end;
307
  case UnitRG.ItemIndex of
308
  0:bmpWidth := round(v);
309
  1:bmpWidth := mmToPixel(v);
310
  2:bmpWidth := cmToPixel(v);
311
  3:bmpWidth := InchToPixel(v);
312
  end;
313
  bmpScale := bmpWidth/MainForm.GLViewer.Width;
314
  bmpHeight := round(bmpScale*MainForm.GLViewer.Height);
315
  ShowData(Sender);
316
end;
317

318
procedure TBitmapForm.HeightKeyUp(Sender: TObject; var Key: Word;
319
                                  Shift: TShiftState);
320
var
321
  v: double;
322

323
begin
324
  try
325
    v := StrToFloat(EditHeight.Text);
326
  except
327
    v := bmpScale*MainForm.GLViewer.Height;
328
  end;
329
  case UnitRG.ItemIndex of
330
  0:bmpHeight := round(v);
331
  1:bmpHeight := mmToPixel(v);
332
  2:bmpHeight := cmToPixel(v);
333
  3:bmpHeight := InchToPixel(v);
334
  end;
335
  bmpScale := bmpHeight/MainForm.GLViewer.Height;
336
  bmpWidth := round(bmpScale*MainForm.GLViewer.Width);
337
  ShowData(Sender);
338
end;
339

340
procedure TBitmapForm.UnitRGClick(Sender: TObject);
341
begin
342
  ShowData(Sender);
343
end;
344

345
procedure TBitmapForm.ShowData(Sender: TObject);
346
  procedure TagIsZero;
347
{ not a change in the edit fields: Scale Width or Height }
348
  begin   { TagIsZero }
349
    EditScale.Text := FloatToStrF(bmpScale, ffFixed, 8, 2);
350
    case UnitRg.ItemIndex of
351
    0:begin  { Pixels }
352
        EditWidth.Text := IntToStr(bmpWidth);
353
        EditHeight.Text := IntToStr(bmpHeight);
354
        WidthLabel.Caption := 'Pixels';
355
        HeightLabel.Caption := 'Pixels';
356
      end;
357
    1:begin  { mm }
358
        EditWidth.Text :=
359
            FloatToStrF(PixelTomm(bmpWidth), ffFixed, 8, 2);
360
        EditHeight.Text :=
361
            FloatToStrF(PixelTomm(bmpHeight), ffFixed, 8, 2);
362
        WidthLabel.Caption := 'mm';
363
        HeightLabel.Caption := 'mm';
364
      end;
365
    2:begin  { cm }
366
        EditWidth.Text :=
367
            FloatToStrF(PixelTocm(bmpWidth), ffFixed, 8, 2);
368
        EditHeight.Text :=
369
            FloatToStrF(PixelTocm(bmpHeight), ffFixed, 8, 2);
370
        WidthLabel.Caption := 'cm';
371
        HeightLabel.Caption := 'cm';
372
      end;
373
    3:begin  { inch }
374
        EditWidth.Text :=
375
            FloatToStrF(PixelToInch(bmpWidth), ffFixed, 8, 2);
376
        EditHeight.Text :=
377
            FloatToStrF(PixelToInch(bmpHeight), ffFixed, 8, 2);
378
        WidthLabel.Caption := 'inches';
379
        HeightLabel.Caption := 'inches';
380
      end;
381
    end;
382
  end;
383

384
begin
385
  if Sender is TEdit then
386
  begin
387
    with Sender as TEdit do
388
    case Tag of
389
    0:TagIsZero; { Factor }
390
    1:begin  { Scale }
391
        case UnitRg.ItemIndex of
392
        0:begin
393
            EditWidth.Text := IntToStr(bmpWidth);
394
            EditHeight.Text := IntToStr(bmpHeight);
395
          end;
396
        1:begin
397
            EditWidth.Text :=
398
                FloatToStrF(PixelTomm(bmpWidth), ffFixed, 8, 2);
399
            EditHeight.Text :=
400
                FloatToStrF(PixelTomm(bmpHeight), ffFixed, 8, 2);
401
          end;
402
        2:begin
403
            EditWidth.Text :=
404
                FloatToStrF(PixelTocm(bmpWidth), ffFixed, 8, 2);
405
            EditHeight.Text :=
406
                FloatToStrF(PixelTocm(bmpHeight), ffFixed, 8, 2);
407
          end;
408
        3:begin
409
            EditWidth.Text :=
410
                FloatToStrF(PixelToInch(bmpWidth), ffFixed, 8, 2);
411
            EditHeight.Text :=
412
                FloatToStrF(PixelToInch(bmpHeight), ffFixed, 8, 2);
413
          end;
414
        end;
415
      end;
416
    2:begin  { Width }
417
        EditScale.Text := FloatToStrF(bmpScale, ffFixed, 8, 2);
418
        case UnitRg.ItemIndex of
419
        0:EditHeight.Text := IntToStr(bmpHeight);
420
        1:EditHeight.Text :=
421
              FloatToStrF(PixelTomm(bmpHeight), ffFixed, 8, 2);
422
        2:EditHeight.Text :=
423
              FloatToStrF(PixelTocm(bmpHeight), ffFixed, 8, 2);
424
        3:EditHeight.Text :=
425
              FloatToStrF(PixelToInch(bmpHeight), ffFixed, 8, 2);
426
        end;
427
      end;
428
    3:begin  { Height }
429
        EditScale.Text := FloatToStrF(bmpScale, ffFixed, 8, 2);
430
        case UnitRg.ItemIndex of
431
        0:EditWidth.Text := IntToStr(bmpWidth);
432
        1:EditWidth.Text :=
433
              FloatToStrF(PixelTomm(bmpWidth), ffFixed, 8, 2);
434
        2:EditWidth.Text :=
435
              FloatToStrF(PixelTocm(bmpWidth), ffFixed, 8, 2);
436
        3:EditWidth.Text :=
437
              FloatToStrF(PixelToInch(bmpWidth), ffFixed, 8, 2);
438
        end;
439
      end;
440
    end;
441
  end
442
  else TagIsZero;  { UnitRG }
443
  EditBorder.Text := IntToStr(BorderWidth);
444
end;
445

446
function TBitmapForm.PixelTomm(v: integer): double;
447
begin
448
  Result := 25.4*v/Screen.PixelsPerInch;
449
end;
450

451

452

453
function TBitmapForm.PixelTocm(v: integer): double;
454
begin
455
  Result := 2.54*v/Screen.PixelsPerInch;
456
end;
457

458
function TBitmapForm.PixelToInch(v: integer): double;
459
begin
460
  Result := v/Screen.PixelsPerInch;
461
end;
462

463
function TBitmapForm.mmToPixel(v: double): integer;
464
begin
465
  Result := round(Screen.PixelsPerInch*v/25.4);
466
end;
467

468
procedure TBitmapForm.CloseBitBtnClick(Sender: TObject);
469
begin
470
  Close;
471
end;
472

473
function TBitmapForm.cmToPixel(v: double): integer;
474
begin
475
  Result := round(Screen.PixelsPerInch*v/2.54);
476
end;
477

478
function TBitmapForm.InchToPixel(v: double): integer;
479
begin
480
  Result := round(Screen.PixelsPerInch*v);
481
end;
482

483
end.
484