1 {
2 *****************************************************************************
3 See the file COPYING.modifiedLGPL.txt, included in this distribution,
4 for details about the license.
5 *****************************************************************************
6
7 Authors: Luís Rodrigues, Alexander Klenin
8
9 }
10
11 unit TADrawerWMF;
12
13 {$H+}
14
15 interface
16
17 {$IFDEF WINDOWS}
18 uses
19 Windows, Classes, Graphics,
20 TADrawerCanvas, TAGraph;
21
22 type
23 { TMetafile }
24
25 TMetafile = class(TGraphic)
26 private
27 FImageHandle: HENHMETAFILE;
28 FMMHeight: Integer; // are in 0.01 mm logical pixels
29 FMMWidth: Integer; // are in 0.01 mm logical pixels
30 FImagePxHeight: Integer; // in device pixels
31 FImagePxWidth: Integer; // in device pixels
32
33 procedure DeleteImage;
GetAuthornull34 function GetAuthor: String;
GetDescriptionnull35 function GetDescription: String;
GetHandlenull36 function GetHandle: HENHMETAFILE;
37 procedure SetHandle(AValue: HENHMETAFILE);
38 procedure SetMMHeight(AValue: Integer);
39 procedure SetMMWidth(AValue: Integer);
40 protected
41 procedure Draw(ACanvas: TCanvas; const ARect: TRect); override;
GetEmptynull42 function GetEmpty: Boolean; override;
GetHeightnull43 function GetHeight: Integer; override;
GetTransparentnull44 function GetTransparent: Boolean; override;
GetWidthnull45 function GetWidth: Integer; override;
46 procedure SetHeight(AValue: Integer); override;
47 procedure SetTransparent(AValue: Boolean); override;
48 procedure SetWidth(AValue: Integer); override;
49 public
50 constructor Create; override;
51 destructor Destroy; override;
52
53 public
54 procedure Assign(ASource: TPersistent); override;
55 procedure Clear; override;
56 procedure CopyToClipboard;
57 procedure LoadFromFile(const AFileName: String); override;
58 procedure LoadFromStream(AStream: TStream); override;
ReleaseHandlenull59 function ReleaseHandle: HENHMETAFILE;
60 procedure SaveToFile(const AFileName: String); override;
61 procedure SaveToStream(AStream: TStream); override;
62
63 property CreatedBy: String read GetAuthor;
64 property Description: String read GetDescription;
65 property Empty: boolean read GetEmpty;
66 property Handle: HENHMETAFILE read GetHandle write SetHandle;
67
68 property MMHeight: Integer read FMMHeight write SetMMHeight;
69 property MMWidth: Integer read FMMWidth write SetMMWidth;
70 end;
71
72 { TMetafileCanvas }
73
74 TMetafileCanvas = class(TCanvas)
75 strict private
76 FMetafile: TMetafile;
77 public
78 constructor Create(AMetafile: TMetafile; AReferenceDevice: HDC);
79 constructor CreateWithComment(
80 AMetafile: TMetafile; AReferenceDevice: HDC;
81 const ACreatedBy, ADescription: String);
82 destructor Destroy; override;
83 end;
84
85 { TWindowsMetafileDrawer }
86
87 TWindowsMetafileDrawer = class(TCanvasDrawer)
88 strict private
89 FFileName: String;
90 FMetafile: TMetafile;
91 public
92 constructor Create(const AFileName: String); reintroduce;
93 destructor Destroy; override;
94 public
95 procedure DrawingBegin(const ABoundingBox: TRect); override;
96 procedure DrawingEnd; override;
GetCanvasnull97 function GetCanvas: TCanvas; override;
98 end;
99
100 { TWMFChartHelper }
101
102 TWMFChartHelper = class helper for TChart
103 procedure CopyToClipboardMetafile;
104 procedure SaveToWMF(const AFileName: String);
105 end;
106 {$ENDIF}
107
108 implementation
109
110 {$IFDEF WINDOWS}
111 uses
112 SysUtils, clipbrd, TAChartUtils;
113
114 { TWindowsMetafileDrawer }
115
116 constructor TWindowsMetafileDrawer.Create(const AFileName: String);
117 begin
118 FFileName := AFileName;
119 FMetafile := TMetafile.Create;
120 inherited Create(nil);
121 end;
122
123 destructor TWindowsMetafileDrawer.Destroy;
124 begin
125 FreeAndNil(FCanvas);
126 FreeAndNil(FMetafile);
127 inherited Destroy;
128 end;
129
130 procedure TWindowsMetafileDrawer.DrawingBegin(const ABoundingBox: TRect);
131 begin
132 inherited DrawingBegin(ABoundingBox);
133 FreeAndNil(FCanvas);
134 FMetafile.Width := ABoundingBox.Right - ABoundingBox.Left;
135 FMetafile.Height := ABoundingBox.Bottom - ABoundingBox.Top;
136 if FCanvas = nil then
137 FCanvas := TMetafileCanvas.Create(FMetafile, 0);
138 end;
139
140 procedure TWindowsMetafileDrawer.DrawingEnd;
141 begin
142 FreeAndNil(FCanvas);
143 if FFileName = '' then
144 // Clipboard.Assign(FMetaFile)
145 FMetafile.CopyToClipboard
146 else
147 FMetafile.SaveToFile(FFileName);
148 end;
149
TWindowsMetafileDrawer.GetCanvasnull150 function TWindowsMetafileDrawer.GetCanvas: TCanvas;
151 begin
152 if FCanvas = nil then
153 FCanvas := TMetafileCanvas.Create(FMetafile, 0);
154 Result := FCanvas;
155 end;
156
157 { TMetafile }
158
159 procedure TMetafile.DeleteImage;
160 begin
161 if FImageHandle <> 0 then
162 DeleteEnhMetafile(FImageHandle);
163 FImageHandle := 0;
164 end;
165
TMetafile.GetAuthornull166 function TMetafile.GetAuthor: String;
167 var
168 authorLength: Integer;
169 begin
170 Result := '';
171 if FImageHandle = 0 then exit;
172
173 authorLength := GetEnhMetafileDescription(FImageHandle, 0, nil);
174 if authorLength <= 0 then exit;
175 SetLength(Result, authorLength);
176 GetEnhMetafileDescription(FImageHandle, authorLength, PChar(Result));
177 SetLength(Result, StrLen(PChar(Result)));
178 end;
179
GetDescriptionnull180 function TMetafile.GetDescription: String;
181 var
182 descLength: Integer;
183 begin
184 Result := '';
185 if FImageHandle = 0 then Exit;
186
187 descLength := GetEnhMetafileDescription(FImageHandle, 0, nil);
188 if descLength <= 0 then exit;
189 SetLength(Result, descLength);
190 GetEnhMetafileDescription(FImageHandle, descLength, PChar(Result));
191 SetLength(Result, StrLen(PChar(Result)));
192 end;
193
TMetafile.GetEmptynull194 function TMetafile.GetEmpty: Boolean;
195 begin
196 Result := FImageHandle = 0;
197 end;
198
GetHandlenull199 function TMetafile.GetHandle: HENHMETAFILE;
200 begin
201 Result := FImageHandle;
202 end;
203
204 procedure TMetafile.SetHandle(AValue: HENHMETAFILE);
205 var
206 emfHeader: TEnhMetaHeader;
207 begin
208 if
209 (AValue <> 0) and
210 (GetEnhMetafileHeader(AValue, sizeof(emfHeader), @emfHeader) = 0)
211 then
212 raise EInvalidImage.Create('Invalid Metafile');;
213
214 if FImageHandle <> 0 then DeleteImage;
215
216 FImageHandle := AValue;
217 FImagePxWidth := 0;
218 FImagePxHeight := 0;
219 FMMWidth := emfHeader.rclFrame.Right - emfHeader.rclFrame.Left;
220 FMMHeight := emfHeader.rclFrame.Bottom - emfHeader.rclFrame.Top;
221 end;
222
223
224 procedure TMetafile.SetMMHeight(AValue: Integer);
225 begin
226 FImagePxHeight := 0;
227 if FMMHeight <> AValue then FMMHeight := AValue;
228 end;
229
230 procedure TMetafile.SetMMWidth(AValue: Integer);
231 begin
232 FImagePxWidth := 0;
233 if FMMWidth <> AValue then FMMWidth := AValue;
234 end;
235
236 procedure TMetafile.SetTransparent(AValue: Boolean);
237 begin
238 if AValue then
239 raise EComponentError.Create('Not implemented');
240 end;
241
242 procedure TMetafile.Draw(ACanvas: TCanvas; const ARect: TRect);
243 var
244 r: TRect;
245 begin
246 if FImageHandle = 0 then exit;
247 r := ARect;
248 PlayEnhMetaFile(ACanvas.Handle, FImageHandle, r);
249 end;
250
TMetafile.GetHeightnull251 function TMetafile.GetHeight: Integer;
252 var
253 emfHeader: TEnhMetaHeader;
254 begin
255 if FImageHandle = 0 then
256 exit(FImagePxHeight);
257 // convert 0.01mm units to device pixels
258 GetEnhMetaFileHeader(FImageHandle, Sizeof(emfHeader), @emfHeader);
259 Result := MulDiv(
260 FMMHeight, // metafile height in 0.01mm
261 emfHeader.szlDevice.cy, // device height in pixels
262 emfHeader.szlMillimeters.cy * 100); // device height in mm
263 end;
264
TMetafile.GetTransparentnull265 function TMetafile.GetTransparent: Boolean;
266 begin
267 Result := false;
268 end;
269
GetWidthnull270 function TMetafile.GetWidth: Integer;
271 var
272 emfHeader: TEnhMetaHeader;
273 begin
274 if FImageHandle = 0 then
275 exit(FImagePxWidth);
276 // convert 0.01mm units to device pixels
277 GetEnhMetaFileHeader(FImageHandle, Sizeof(emfHeader), @emfHeader);
278 Result := MulDiv(
279 FMMWidth, // metafile width in 0.01mm
280 emfHeader.szlDevice.cx, // device width in pixels
281 emfHeader.szlMillimeters.cx * 100); // device width in 0.01mm
282 end;
283
284
285 procedure TMetafile.SetHeight(AValue: Integer);
286 var
287 emfHeader: TEnhMetaHeader;
288 begin
289 if FImageHandle = 0 then
290 FImagePxHeight := AValue
291 else begin // convert device pixels to 0.01mm units
292 GetEnhMetaFileHeader(FImageHandle, Sizeof(emfHeader), @emfHeader);
293 MMHeight := MulDiv(AValue, // metafile height in pixels
294 emfHeader.szlMillimeters.cy * 100, // device height in 0.01mm
295 emfHeader.szlDevice.cy); // device height in pixels
296 end;
297 end;
298
299 procedure TMetafile.SetWidth(AValue: Integer);
300 var
301 emfHeader: TEnhMetaHeader;
302 begin
303 if FImageHandle = 0 then
304 FImagePxWidth := AValue
305 else begin // convert device pixels to 0.01mm units
306 GetEnhMetaFileHeader(FImageHandle, Sizeof(emfHeader), @emfHeader);
307 MMWidth := MulDiv(AValue, // metafile width in pixels
308 emfHeader.szlMillimeters.cx * 100, // device width in mm
309 emfHeader.szlDevice.cx); // device width in pixels
310 end;
311 end;
312
313 constructor TMetafile.Create;
314 begin
315 inherited Create;
316 FImageHandle := 0;
317 end;
318
319 destructor TMetafile.Destroy;
320 begin
321 DeleteImage;
322 inherited Destroy;
323 end;
324
325 procedure TMetafile.Assign(ASource: TPersistent);
326 begin
327 if (ASource = nil) or (ASource is TMetafile) then begin
328 if FImageHandle <> 0 then
329 DeleteImage;
330 if Assigned(ASource) then begin
331 FImageHandle := TMetafile(ASource).Handle;
332 FMMWidth := TMetafile(ASource).MMWidth;
333 FMMHeight := TMetafile(ASource).MMHeight;
334 FImagePxWidth := TMetafile(ASource).Width;
335 FImagePxHeight := TMetafile(ASource).Height;
336 end
337 end
338 else
339 inherited Assign(ASource);
340 end;
341
342 procedure TMetafile.Clear;
343 begin
344 DeleteImage;
345 end;
346
347 procedure TMetafile.CopyToClipboard;
348 // http://www.olivierlanglois.net/metafile-clipboard.html
349 var
350 Format: Word;
351 begin
352 if FImageHandle = 0 then exit;
353
354 OpenClipboard(0);
355 try
356 EmptyClipboard;
357 Format := CF_ENHMETAFILE;
358 SetClipboardData(Format, FImageHandle);
359 finally
360 CloseClipboard;
361 end;
362 end;
363
364 procedure TMetafile.LoadFromFile(const AFileName: String);
365 begin
366 Unused(AFileName);
367 raise EComponentError.Create('Not Implemented');
368 end;
369
370 procedure TMetafile.SaveToFile(const AFileName: String);
371 var
372 outFile: HENHMETAFILE;
373 begin
374 if FImageHandle = 0 then exit;
375 outFile := CopyEnhMetaFile(FImageHandle, PChar(AFileName));
376 if outFile = 0 then
377 RaiseLastWin32Error;
378 DeleteEnhMetaFile(outFile);
379 end;
380
381 procedure TMetafile.LoadFromStream(AStream: TStream);
382 begin
383 Unused(AStream);
384 raise EComponentError.Create('Not Implemented');
385 end;
386
387 procedure TMetafile.SaveToStream(AStream: TStream);
388 begin
389 Unused(AStream);
390 raise EComponentError.Create('Not Implemented');
391 end;
392
TMetafile.ReleaseHandlenull393 function TMetafile.ReleaseHandle: HENHMETAFILE;
394 begin
395 DeleteImage;
396 Result := FImageHandle;
397 FImageHandle := 0;
398 end;
399
400 { TMetafileCanvas }
401
402 constructor TMetafileCanvas.Create(AMetafile: TMetafile; AReferenceDevice: HDC);
403 begin
404 CreateWithComment(
405 AMetafile, AReferenceDevice, AMetafile.CreatedBy, AMetafile.Description);
406 end;
407
408 constructor TMetafileCanvas.CreateWithComment(
409 AMetafile: TMetafile; AReferenceDevice: HDC;
410 const ACreatedBy, ADescription: String);
411 var
412 refDC: HDC;
413 r: TRect;
414 temp: HDC;
415 p: PChar;
416 w, h: Integer;
417 begin
418 inherited Create;
419 FMetafile := AMetafile;
420
421 refDC := AReferenceDevice;
422 if refDC = 0 then
423 refDC := GetDC(0);
424
425 try
426 if FMetafile.MMWidth = 0 then begin
427 w := GetDeviceCaps(refDC, HORZSIZE) * 100;
428 if FMetafile.Width = 0 then // if no width get refDC width
429 FMetafile.MMWidth := w
430 else // else convert
431 FMetafile.MMWidth := MulDiv(
432 FMetafile.Width, w, GetDeviceCaps(refDC, HORZRES));
433 end;
434
435 if FMetafile.MMHeight = 0 then begin
436 h := GetDeviceCaps(refDC, VERTSIZE) * 100;
437 if FMetafile.Height = 0 then // if no height get refDC height
438 FMetafile.MMHeight := h
439 else // else convert
440 FMetafile.MMHeight := MulDiv(
441 FMetafile.Height, h, GetDeviceCaps(refDC, VERTRES));
442 end;
443
444 r := Rect(0, 0, FMetafile.MMWidth, FMetafile.MMHeight);
445 // lpDescription stores both author and description
446 if (Length(ACreatedBy) > 0) or (Length(ADescription) > 0) then
447 p := PChar(ACreatedBy+#0+ADescription+#0#0)
448 else
449 p := nil;
450 temp := CreateEnhMetafile(refDC, nil, @r, p);
451 if temp = 0 then
452 raise EOutOfResources.Create('Out of Resources');;
453 Handle := temp;
454 finally
455 if AReferenceDevice = 0 then
456 ReleaseDC(0, refDC);
457 end;
458 end;
459
460 destructor TMetafileCanvas.Destroy;
461 begin
462 FMetafile.Handle := CloseEnhMetafile(Handle);
463 inherited Destroy;
464 end;
465
466 { TWMFChartHelper }
467
468 procedure TWMFChartHelper.CopyToClipboardMetafile;
469 begin
470 Draw(TWindowsMetafileDrawer.Create(''), Rect(0, 0, Width, Height));
471 end;
472
473 procedure TWMFChartHelper.SaveToWMF(const AFileName: String);
474 begin
475 Draw(TWindowsMetafileDrawer.Create(AFilename), Rect(0, 0, Width, Height));
476 end;
477 {$ENDIF}
478
479 end.
480
481