Delphi-Projects

1
unit CustomBlank;
2

3
interface
4

5
uses
6
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
7
  Printers, ExtCtrls;
8

9
type
10
  TCustomBlank = class
11
  private
12
    { Private declarations }
13
    FMetaFile: TMetaFile;
14
    FMetafileCanvas: TMetafileCanvas;
15
    FPixelsPerInchX: Integer;
16
    FPixelsPerInchY: Integer;
17
    FTopMargin: Integer;
18
    FLeftMargin: Integer;
19
    FHeight: Integer;
20
    FWidth: Integer;
21
    function GetFont: TFont;
22
    procedure SetFont(const Value: TFont);
23
  protected
24
    { Protected declarations }
25
    function GetCanvas: TCanvas;
26
  public
27
    { Public declarations }
28
    function xm(x: Integer): Integer;
29
    function ym(y: Integer): Integer;
30
    procedure ResetFont(Name: string = ''; Size: Integer = 0;
31
      Style: string = '');
32
    procedure FL(x, y, x2, y2: Integer);
33
    procedure RL(x, y, x2, y2: Integer);
34
    procedure HL(x, y, x2: Integer);
35
    procedure VL(x, y, y2: Integer);
36
    procedure TL(x, y: Integer; S: string); overload;
37
    procedure TL(x, y, x2: Integer; S: string); overload;
38
    procedure TC(x, y, x2: Integer; S: string);
39
    procedure TB(x, y, x2, y2: Integer; S: string);
40
    procedure TV(x, y, x2, y2: Integer; S: string);
41
    procedure BeginScreenDoc;
42
    procedure BeginPrinterDoc;
43
    procedure EndDoc;
44
    procedure DrawPrinterPage;
45
    procedure Preview;
46
    procedure Print(NumCopies: Integer = 1; const DocTitle: string = 'Бланк');
47
    procedure DrawRulers;
48
    procedure SaveImage(const FileName: string);
49
    constructor Create; virtual;
50
    destructor Destroy; override;
51
    property Canvas: TCanvas read GetCanvas;
52
    property Font: TFont read GetFont write SetFont;
53
    property TopMargin: Integer read FTopMargin write FTopMargin;
54
    property LeftMargin: Integer read FLeftMargin write FLeftMargin;
55
    property Width: Integer read FWidth write FWidth;
56
    property Height: Integer read FHeight write FHeight;
57
  published
58
    { Published declarations }
59
  end;
60

61
implementation
62

63
uses
64
  PreviewUnit, Math;
65

66
{ TCustomBlank }
67

68
constructor TCustomBlank.Create;
69
begin
70
  FPixelsPerInchX := Screen.PixelsPerInch;
71
  FPixelsPerInchY := Screen.PixelsPerInch;
72

73
  //A4(mm)
74
  FLeftMargin := 20;
75
  FTopMargin := 15;
76
  FWidth := 210;
77
  FHeight := 297;
78
end;
79

80
destructor TCustomBlank.Destroy;
81
begin
82
  FMetafileCanvas.Free;
83
  FMetaFile.Free;
84
  inherited Destroy;
85
end;
86

87
procedure TCustomBlank.BeginScreenDoc;
88
begin
89
  FPixelsPerInchX := Screen.PixelsPerInch;
90
  FPixelsPerInchY := Screen.PixelsPerInch;
91

92
  FMetaFile.Free;
93
  FMetaFile := TMetaFile.Create;
94
  with FMetaFile do
95
  begin
96
    Height := MulDiv(FHeight, FPixelsPerInchX * 10, 254);
97
    Width := MulDiv(FWidth, FPixelsPerInchY * 10, 254);
98
  end;
99

100
  FMetafileCanvas.Free;
101
  FMetafileCanvas := TMetafileCanvas.Create(FMetaFile, 0);
102
  with FMetafileCanvas do
103
  begin
104
    Font.Name := 'Times New Roman';
105
    Font.Size := 8;
106
    Font.Charset := RUSSIAN_CHARSET;
107
    Pen.Width := 1;
108
  end;
109
end;
110

111
procedure TCustomBlank.BeginPrinterDoc;
112
begin
113
  FPixelsPerInchX := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
114
  FPixelsPerInchY := GetDeviceCaps(Printer.Handle, LOGPIXELSY);
115

116
  FMetaFile.Free;
117
  FMetaFile := TMetaFile.Create;
118
  with FMetaFile do
119
  begin
120
    Height := MulDiv(FHeight, FPixelsPerInchX * 10, 254);
121
    Width := MulDiv(FWidth, FPixelsPerInchY * 10, 254);
122
  end;
123

124
  FMetafileCanvas.Free;
125
  FMetafileCanvas := TMetafileCanvas.Create(FMetaFile, Printer.Handle);
126
  with FMetafileCanvas do
127
  begin
128
    Font.Name := 'Times New Roman';
129
    Font.Size := 8;
130
    Font.Charset := RUSSIAN_CHARSET;
131
    if FPixelsPerInchY <> Screen.PixelsPerInch then
132
      Font.Size := Round(Font.Size * FPixelsPerInchY / Screen.PixelsPerInch);
133
    Pen.Width := 1 + FPixelsPerInchY div 300;
134
  end;
135
end;
136

137
procedure TCustomBlank.EndDoc;
138
begin
139
  FMetafileCanvas.Free;
140
  FMetafileCanvas := nil;
141
end;
142

143
function TCustomBlank.xm(x: Integer): Integer;
144
begin
145
  Result := MulDiv(x, FPixelsPerInchX * 10, 254);
146
end;
147

148
function TCustomBlank.ym(y: Integer): Integer;
149
begin
150
  if y < 0 then
151
  begin
152
    y := -y;
153
    Result := MulDiv(y, FPixelsPerInchY * 10, 254) -
154
      FMetafileCanvas.TextHeight('W');
155
  end
156
  else
157
    Result := MulDiv(y, FPixelsPerInchY * 10, 254);
158
end;
159

160
procedure TCustomBlank.HL(x, y, x2: Integer);
161
begin
162
  with FMetafileCanvas do
163
  begin
164
    y := ym(y);
165
    MoveTo(xm(x), y);
166
    LineTo(xm(x2), y);
167
  end;
168
end;
169

170
procedure TCustomBlank.RL(x, y, x2, y2: Integer);
171
begin
172
  with FMetafileCanvas do
173
  begin
174
    //Rectangle(xm(x), ym(y), xm(x2), ym(y2));
175
    x := xm(x); x2 := xm(x2);
176
    y := ym(y); y2 := ym(y2);
177
    MoveTo(x, y);
178
    LineTo(x2,y);
179
    LineTo(x2,y2);
180
    LineTo(x, y2);
181
    LineTo(x, y);
182
  end;
183
end;
184

185
procedure TCustomBlank.TB(x, y, x2, y2: Integer; S: string);
186
var
187
  R: TRect;
188
begin
189
  R := Rect(xm(x), ym(y), xm(x2), ym(y2));
190
  DrawText(FMetafileCanvas.Handle, PChar(S), Length(S), R,
191
    DT_LEFT or DT_NOPREFIX or DT_WORDBREAK);
192
end;
193

194
procedure TCustomBlank.TV(x, y, x2, y2: Integer; S: string);
195
var
196
  R: TRect;
197
begin
198
  R := Rect(xm(x), ym(y), xm(x2), ym(y2));
199
  DrawText(FMetafileCanvas.Handle, PChar(S), Length(S), R,
200
    DT_CENTER or DT_VCENTER or DT_NOPREFIX or DT_SINGLELINE);
201
end;
202

203
procedure TCustomBlank.TL(x, y: Integer; S: string);
204
begin
205
  FMetafileCanvas.TextOut(xm(x), ym(y), S);
206
end;
207

208
procedure TCustomBlank.TL(x, y, x2: Integer; S: string);
209
var
210
  R: TRect;
211
begin
212
  with FMetafileCanvas do
213
  begin
214
    R.Top := ym(y);
215
    R.Left := xm(x);
216
    R.Bottom := R.Top + TextHeight(S);
217
    R.Right := xm(x2);
218
    TextRect(R, R.Left, R.Top, S);
219
  end;
220
end;
221

222
procedure TCustomBlank.TC(x, y, x2: Integer; S: string);
223
begin
224
  with FMetafileCanvas do
225
  begin
226
    x := xm(x);
227
    Inc(x, (xm(x2) - x - TextWidth(S)) div 2);
228
    TextOut(x, ym(y), S);
229
  end;
230
end;
231

232
procedure TCustomBlank.VL(x, y, y2: Integer);
233
begin
234
  with FMetafileCanvas do
235
  begin
236
    x := xm(x);
237
    MoveTo(x, ym(y));
238
    LineTo(x, ym(y2));
239
  end;
240
end;
241

242
procedure TCustomBlank.FL(x, y, x2, y2: Integer);
243
begin
244
  with FMetafileCanvas do
245
  begin
246
    MoveTo(xm(x), ym(y));
247
    LineTo(xm(x2), ym(y2));
248
  end;
249
end;
250

251
procedure TCustomBlank.Preview;
252
var
253
  Form: TPreviewForm;
254
begin
255
  Form := TPreviewForm.Create(Application);
256
  try
257
    Form.ScrollBox.DisableAutoRange;
258
    with Form.Image do
259
    begin
260
      SetBounds(2, 2, FMetaFile.Width, FMetaFile.Height);
261
      Form.Bevel.SetBounds(Left, Top, Width + 2, Height + 2);
262
      Canvas.Draw(xm(LeftMargin), ym(TopMargin), FMetaFile);
263
      //Form.ScrollBox.VertScrollBar.Range := Form.Image.Height;
264
    end;
265
    Form.ScrollBox.EnableAutoRange;
266
    with Form do
267
    begin
268
      Height := Min(Form.Image.Height + 40, Screen.Height - 40);
269
      Width := Min(Form.Image.Width + 40, Screen.Width - 40);
270
      //Left := (Screen.Width - Width - 40) div 2;
271
      //Top := (Screen.Height - Height - 40) div 2;
272
      ShowModal;
273
    end;
274
  finally
275
    Form.Free;
276
  end;
277
end;
278

279
procedure TCustomBlank.Print(NumCopies: Integer = 1; const DocTitle: string = 'Бланк');
280
begin
281
  Printer.Title := DocTitle;
282
  Printer.BeginDoc;
283
  while NumCopies > 0 do
284
  begin
285
    DrawPrinterPage;
286
    Dec(NumCopies);
287
    if NumCopies > 0 then
288
      Printer.NewPage;
289
  end;
290
  Printer.EndDoc;
291
end;
292

293
procedure TCustomBlank.DrawRulers;
294
var
295
  I: Integer;
296
begin
297
  with FMetafileCanvas do
298
  begin
299
    HL(0, 0, FWidth);
300
    VL(0, 0, FHeight);
301
    for I := 1 to (FWidth div 10) do
302
    begin
303
      VL(I * 10 - 5, 0, 1);
304
      VL(I * 10, 0, 3);
305
      TL(I * 10, 3, IntToStr(I));
306
    end;
307
    for I := 1 to (FHeight div 10) do
308
    begin
309
      HL(0, I * 10 - 5, 1);
310
      HL(0, I * 10, 3);
311
      TL(3, I * 10, IntToStr(I));
312
    end;
313
  end;
314
end;
315

316
function TCustomBlank.GetCanvas: TCanvas;
317
begin
318
  Result := FMetafileCanvas;
319
end;
320

321
procedure TCustomBlank.DrawPrinterPage;
322
var
323
  X, Y: Integer;
324
begin
325
  X := xm(FLeftMargin);
326
  Y := ym(FTopMargin);
327
  Dec(X, GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX));
328
  Dec(Y, GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY));
329
  Printer.Canvas.Draw(X, Y, FMetaFile);
330
end;
331

332
function TCustomBlank.GetFont: TFont;
333
var
334
  Font: TFont;
335
begin
336
  Font := TFont.Create;
337
  try
338
    Font.Assign(FMetafileCanvas.Font);
339
    if FPixelsPerInchY <> Screen.PixelsPerInch then
340
      Font.Size := Round(Result.Size * Screen.PixelsPerInch / FPixelsPerInchY);
341
    Result.Assign(Font);
342
  finally
343
    Font.Free;
344
  end;
345
end;
346

347
procedure TCustomBlank.SetFont(const Value: TFont);
348
begin
349
  with FMetafileCanvas.Font do
350
  begin
351
    Assign(Value);
352
    if FPixelsPerInchY <> Screen.PixelsPerInch then
353
      Size := Round(Size * FPixelsPerInchY / Screen.PixelsPerInch);
354
  end;
355
end;
356

357
procedure TCustomBlank.ResetFont(Name: string = ''; Size: Integer = 0;
358
  Style: string = '');
359
begin
360
  with FMetafileCanvas do
361
  begin
362
    if Name <> '' then
363
      try
364
        Font.Name := Name;
365
      except
366
        ;
367
      end;
368

369
    if Size > 0 then
370
    begin
371
      Font.Size := Size;
372
      if FPixelsPerInchY <> Screen.PixelsPerInch then
373
        Font.Size := Round(Font.Size * FPixelsPerInchY / Screen.PixelsPerInch);
374
    end;
375

376
    if Style <> '' then
377
    begin
378
      if Pos('N', Style) > 0 then
379
        Font.Style := [];
380
      if Pos('B', Style) > 0 then
381
        Font.Style := Font.Style + [fsBold];
382
      if Pos('I', Style) > 0 then
383
        Font.Style := Font.Style + [fsItalic];
384
      if Pos('U', Style) > 0 then
385
        Font.Style := Font.Style + [fsUnderline];
386
    end;
387
    Font.Charset := RUSSIAN_CHARSET;
388
  end;
389
end;
390

391
procedure TCustomBlank.SaveImage(const FileName: string);
392
var
393
  Img: TBitmap;
394
begin
395
  Img := TBitmap.Create;
396
  try
397
    Img.PixelFormat := pf1bit;
398
    Img.Height := FMetaFile.Height;
399
    Img.Width := FMetaFile.Width;
400
    Img.Canvas.Draw(xm(FLeftMargin),ym(FTopMargin),FMetaFile);
401
    Img.SaveToFile(FileName + '.bmp');
402
//    FMetaFile.Height :=
403
//    FMetaFile.Width :=
404
    FMetaFile.SaveToFile(FileName + '.emf');
405
  finally
406
    Img.Free;
407
  end;
408
end;
409

410
end.
411