MathgeomGLS
483 строки · 12.6 Кб
1unit fBitmap;
2
3interface
4
5uses
6Winapi.Windows,
7Winapi.Messages,
8System.SysUtils,
9System.Variants,
10System.Classes,
11Vcl.Graphics,
12Vcl.Controls,
13Vcl.Forms,
14Vcl.Dialogs,
15Vcl.StdCtrls,
16Vcl.Buttons,
17Vcl.ExtCtrls,
18Vcl.ExtDlgs,
19Vcl.Imaging.Jpeg,
20
21uGlobal;
22
23type
24TBitmapForm = class(TForm)
25Label1: TLabel;
26EditScale: TEdit;
27UnitRG: TRadioGroup;
28Label2: TLabel;
29EditWidth: TEdit;
30Label3: TLabel;
31EditHeight: TEdit;
32OKBitBtn: TBitBtn;
33SavePictureDialog: TSavePictureDialog;
34WidthLabel: TLabel;
35HeightLabel: TLabel;
36ColorDialog: TColorDialog;
37Label6: TLabel;
38EditBorder: TEdit;
39ColorButton: TSpeedButton;
40CloseBitBtn: TBitBtn;
41Label4: TLabel;
42procedure FormCreate(Sender: TObject);
43procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
44procedure FloatKeyPress(Sender: TObject; var Key: Char);
45procedure ScaleKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
46procedure numKeyPress(Sender: TObject; var Key: Char);
47procedure WidthKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
48procedure HeightKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
49procedure UnitRGClick(Sender: TObject);
50procedure EditBorderKeyPress(Sender: TObject; var Key: Char);
51procedure FormShow(Sender: TObject);
52procedure ColorButtonClick(Sender: TObject);
53procedure EditBorderKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
54procedure CloseBitBtnClick(Sender: TObject);
55private
56bmpScale: double;
57bmpWidth: integer; { as pixels }
58bmpHeight: integer; { as pixels }
59BorderWidth: integer;
60BorderColor: TColor;
61procedure ShowData(Sender: TObject);
62function PixelTomm(v: integer): double;
63function PixelTocm(v: integer): double;
64function PixelToInch(v: integer): double;
65function mmToPixel(v: double): integer;
66function cmToPixel(v: double): integer;
67function InchToPixel(v: double): integer;
68end;
69
70var
71BitmapForm: TBitmapForm;
72
73//=====================================================================
74implementation
75//=====================================================================
76
77uses
78fPlot1D;
79
80{$R *.dfm}
81
82procedure TBitmapForm.FormCreate(Sender: TObject);
83begin
84with Layout do
85begin
86if bmpScale = 0 then
87begin
88Left := (Screen.Width - Width) div 2;
89Top := (Screen.Height - Height) div 2;
90UnitRG.ItemIndex := 0;
91bmpScale := 1;
92BorderColor := ClRed;
93BorderWidth := 5;
94end
95else
96begin
97Left := BitmapLeft;
98Top := BitmapTop;
99UnitRG.ItemIndex := BitmapUnit;
100bmpScale := BitmapScale;
101BorderColor := BitmapBorderColor;
102BorderWidth := BitmapBorderWidth;
103end;
104end;
105bmpWidth := round(bmpScale*MainForm.GLViewer.Width);
106bmpHeight := round(bmpScale*MainForm.GLViewer.Height);
107
108ShowData(Sender);
109end;
110
111procedure TBitmapForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
112var
113BorderRect: TRect;
114GraphRect: TRect;
115bmp: TBitmap;
116jpg: TJPEGImage;
117filebmp: TBitmap;
118fName: TFileName;
119isJpeg: Boolean;
120
121function ScanText(const s: string): string;
122var
123i: integer;
124
125begin
126Result := s;
127for i := 1 to Length(s) do
128if CharInSet(Result[i], ['/', '\', ':', '*', '?', '<', '>', '|'])
129then Result[i] := ' ';
130end;
131
132begin
133if ModalResult = mrOK then
134begin
135isJpeg := pos('.jpg', Caption) > 0;
136
137BorderRect := Rect(BorderWidth div 2, BorderWidth div 2,
138bmpWidth - BorderWidth div 2 + 1,
139bmpHeight - BorderWidth div 2 + 1);
140GraphRect := Rect(0, 0, bmpWidth - 2*BorderWidth,
141bmpHeight - 2*BorderWidth);
142
143with SavePictureDialog do
144begin
145FName := ScanText(GraphData.PlotData.TextStr);
146
147if isJpeg then
148begin
149Filter := 'Jpeg (*.jpg)|*.jpg';
150Title := 'Save Graph as ''.jpg'' File';
151FileName := FName+'.jpg';
152end
153else
154begin
155Filter := 'Bitmaps (*.bmp)|*.bmp';
156Title := 'Save Graph as ''.bmp'' File';
157FileName := FName+'.bmp';
158end;
159
160InitialDir := ImagePath;
161if Execute then
162begin
163jpg := nil;
164if isJpeg then
165begin
166jpg := TJPEGImage.Create;
167jpg.CompressionQuality := 100;
168{ default is 90; range 1..100; 100 best quality }
169end;
170bmp := TBitmap.Create;
171
172filebmp := TBitmap.Create;
173try
174bmp.PixelFormat := pf32bit;
175{ bmp is a device-independent true-color 32 bits per pixel bitmap. }
176with GraphRect do
177begin
178bmp.Width := Right - Left;
179bmp.Height := Bottom - Top;
180end;
181
182filebmp.PixelFormat := pf32bit;
183with BorderRect do
184begin
185filebmp.Width := Right - Left + BorderWidth -1;
186filebmp.Height := Bottom - Top + BorderWidth -1;
187end;
188
189MainForm.GLViewer.Invalidate;;
190
191with MainForm.GLMemoryViewer do
192begin
193Width := bmp.Width;
194Height := bmp.Height;
195Buffer.BackgroundColor := GraphData.BackColor;
196Render;
197bmp := Buffer.CreateSnapShotBitmap;
198end;
199
200filebmp.Canvas.Pen.Color := BorderColor;
201filebmp.Canvas.Pen.Width := BorderWidth;
202filebmp.Canvas.Rectangle(BorderRect);
203filebmp.Canvas.Draw(BorderWidth, BorderWidth, bmp);
204if isJpeg then
205begin
206jpg.Assign(filebmp);
207jpg.SaveToFile(FileName);
208end
209else filebmp.SaveToFile(FileName);
210finally
211bmp.Free;
212filebmp.Free;
213if isJpeg then jpg.Free;
214end;
215ImagePath := ExtractFilePath(FileName);
216ImagePath := IncludeTrailingPathDelimiter(ImagePath);
217end;
218end;
219end;
220with Layout do
221begin
222BitmapLeft := Left;
223BitmapTop := Top;
224BitmapUnit := UnitRG.ItemIndex;
225BitmapScale := bmpScale;
226BitmapBorderColor := BorderColor;
227BitmapBorderWidth := BorderWidth;
228end;
229end;
230
231procedure TBitmapForm.FormShow(Sender: TObject);
232begin
233UnitRG.SetFocus;
234UnitRG.ItemIndex := 0;
235UnitRGClick(Sender);
236EditScale.SetFocus;
237end;
238
239procedure TBitmapForm.ColorButtonClick(Sender: TObject);
240begin
241ColorDialog.Color := BorderColor;
242if ColorDialog.Execute then BorderColor := ColorDialog.Color;
243end;
244
245procedure TBitmapForm.EditBorderKeyPress(Sender: TObject; var Key: Char);
246begin
247if not CharInSet(Key, ['0'..'9', #8]) then Key := #0
248end;
249
250procedure TBitmapForm.EditBorderKeyUp(Sender: TObject; var Key: Word;
251Shift: TShiftState);
252var
253v: integer;
254
255begin
256try
257v := StrToInt(EditBorder.Text);
258except
259v := 10;
260end;
261BorderWidth := v;
262ShowData(Sender);
263end;
264
265procedure TBitmapForm.FloatKeyPress(Sender: TObject; var Key: Char);
266begin
267with Sender as TEdit do
268if not CharInSet(Key, ['0'..'9', '.', #8]) then Key := #0
269end;
270
271procedure TBitmapForm.ScaleKeyUp(Sender: TObject; var Key: Word;
272Shift: TShiftState);
273begin
274try
275bmpScale := StrToFloat(EditScale.Text);
276except
277bmpScale := 1.0;
278end;
279bmpWidth := round(bmpScale*MainForm.GLViewer.Width);
280bmpHeight := round(bmpScale*MainForm.GLViewer.Height);
281ShowData(Sender);
282end;
283
284procedure TBitmapForm.numKeyPress(Sender: TObject; var Key: Char);
285begin
286with Sender as TEdit do
287begin
288if UnitRG.ItemIndex = 0 then
289begin
290if not CharInSet(Key,['0'..'9', #8]) then Key := #0
291end
292else if not CharInSet(Key, ['0'..'9', '.', #8]) then Key := #0
293end;
294end;
295
296procedure TBitmapForm.WidthKeyUp(Sender: TObject; var Key: Word;
297Shift: TShiftState);
298var
299v: double;
300
301begin
302try
303v := StrToFloat(EditWidth.Text);
304except
305v := bmpScale*MainForm.GLViewer.Width;
306end;
307case UnitRG.ItemIndex of
3080:bmpWidth := round(v);
3091:bmpWidth := mmToPixel(v);
3102:bmpWidth := cmToPixel(v);
3113:bmpWidth := InchToPixel(v);
312end;
313bmpScale := bmpWidth/MainForm.GLViewer.Width;
314bmpHeight := round(bmpScale*MainForm.GLViewer.Height);
315ShowData(Sender);
316end;
317
318procedure TBitmapForm.HeightKeyUp(Sender: TObject; var Key: Word;
319Shift: TShiftState);
320var
321v: double;
322
323begin
324try
325v := StrToFloat(EditHeight.Text);
326except
327v := bmpScale*MainForm.GLViewer.Height;
328end;
329case UnitRG.ItemIndex of
3300:bmpHeight := round(v);
3311:bmpHeight := mmToPixel(v);
3322:bmpHeight := cmToPixel(v);
3333:bmpHeight := InchToPixel(v);
334end;
335bmpScale := bmpHeight/MainForm.GLViewer.Height;
336bmpWidth := round(bmpScale*MainForm.GLViewer.Width);
337ShowData(Sender);
338end;
339
340procedure TBitmapForm.UnitRGClick(Sender: TObject);
341begin
342ShowData(Sender);
343end;
344
345procedure TBitmapForm.ShowData(Sender: TObject);
346procedure TagIsZero;
347{ not a change in the edit fields: Scale Width or Height }
348begin { TagIsZero }
349EditScale.Text := FloatToStrF(bmpScale, ffFixed, 8, 2);
350case UnitRg.ItemIndex of
3510:begin { Pixels }
352EditWidth.Text := IntToStr(bmpWidth);
353EditHeight.Text := IntToStr(bmpHeight);
354WidthLabel.Caption := 'Pixels';
355HeightLabel.Caption := 'Pixels';
356end;
3571:begin { mm }
358EditWidth.Text :=
359FloatToStrF(PixelTomm(bmpWidth), ffFixed, 8, 2);
360EditHeight.Text :=
361FloatToStrF(PixelTomm(bmpHeight), ffFixed, 8, 2);
362WidthLabel.Caption := 'mm';
363HeightLabel.Caption := 'mm';
364end;
3652:begin { cm }
366EditWidth.Text :=
367FloatToStrF(PixelTocm(bmpWidth), ffFixed, 8, 2);
368EditHeight.Text :=
369FloatToStrF(PixelTocm(bmpHeight), ffFixed, 8, 2);
370WidthLabel.Caption := 'cm';
371HeightLabel.Caption := 'cm';
372end;
3733:begin { inch }
374EditWidth.Text :=
375FloatToStrF(PixelToInch(bmpWidth), ffFixed, 8, 2);
376EditHeight.Text :=
377FloatToStrF(PixelToInch(bmpHeight), ffFixed, 8, 2);
378WidthLabel.Caption := 'inches';
379HeightLabel.Caption := 'inches';
380end;
381end;
382end;
383
384begin
385if Sender is TEdit then
386begin
387with Sender as TEdit do
388case Tag of
3890:TagIsZero; { Factor }
3901:begin { Scale }
391case UnitRg.ItemIndex of
3920:begin
393EditWidth.Text := IntToStr(bmpWidth);
394EditHeight.Text := IntToStr(bmpHeight);
395end;
3961:begin
397EditWidth.Text :=
398FloatToStrF(PixelTomm(bmpWidth), ffFixed, 8, 2);
399EditHeight.Text :=
400FloatToStrF(PixelTomm(bmpHeight), ffFixed, 8, 2);
401end;
4022:begin
403EditWidth.Text :=
404FloatToStrF(PixelTocm(bmpWidth), ffFixed, 8, 2);
405EditHeight.Text :=
406FloatToStrF(PixelTocm(bmpHeight), ffFixed, 8, 2);
407end;
4083:begin
409EditWidth.Text :=
410FloatToStrF(PixelToInch(bmpWidth), ffFixed, 8, 2);
411EditHeight.Text :=
412FloatToStrF(PixelToInch(bmpHeight), ffFixed, 8, 2);
413end;
414end;
415end;
4162:begin { Width }
417EditScale.Text := FloatToStrF(bmpScale, ffFixed, 8, 2);
418case UnitRg.ItemIndex of
4190:EditHeight.Text := IntToStr(bmpHeight);
4201:EditHeight.Text :=
421FloatToStrF(PixelTomm(bmpHeight), ffFixed, 8, 2);
4222:EditHeight.Text :=
423FloatToStrF(PixelTocm(bmpHeight), ffFixed, 8, 2);
4243:EditHeight.Text :=
425FloatToStrF(PixelToInch(bmpHeight), ffFixed, 8, 2);
426end;
427end;
4283:begin { Height }
429EditScale.Text := FloatToStrF(bmpScale, ffFixed, 8, 2);
430case UnitRg.ItemIndex of
4310:EditWidth.Text := IntToStr(bmpWidth);
4321:EditWidth.Text :=
433FloatToStrF(PixelTomm(bmpWidth), ffFixed, 8, 2);
4342:EditWidth.Text :=
435FloatToStrF(PixelTocm(bmpWidth), ffFixed, 8, 2);
4363:EditWidth.Text :=
437FloatToStrF(PixelToInch(bmpWidth), ffFixed, 8, 2);
438end;
439end;
440end;
441end
442else TagIsZero; { UnitRG }
443EditBorder.Text := IntToStr(BorderWidth);
444end;
445
446function TBitmapForm.PixelTomm(v: integer): double;
447begin
448Result := 25.4*v/Screen.PixelsPerInch;
449end;
450
451
452
453function TBitmapForm.PixelTocm(v: integer): double;
454begin
455Result := 2.54*v/Screen.PixelsPerInch;
456end;
457
458function TBitmapForm.PixelToInch(v: integer): double;
459begin
460Result := v/Screen.PixelsPerInch;
461end;
462
463function TBitmapForm.mmToPixel(v: double): integer;
464begin
465Result := round(Screen.PixelsPerInch*v/25.4);
466end;
467
468procedure TBitmapForm.CloseBitBtnClick(Sender: TObject);
469begin
470Close;
471end;
472
473function TBitmapForm.cmToPixel(v: double): integer;
474begin
475Result := round(Screen.PixelsPerInch*v/2.54);
476end;
477
478function TBitmapForm.InchToPixel(v: double): integer;
479begin
480Result := round(Screen.PixelsPerInch*v);
481end;
482
483end.
484