1 { A fpvectorial writer for wmf files.
2
3 Documentation used:
4 - http://msdn.microsoft.com/en-us/library/cc250370.aspx
5 - http://wvware.sourceforge.net/caolan/ora-wmf.html
6 - http://www.symantec.com/avcenter/reference/inside.the.windows.meta.file.format.pdf
7
8 Coordinates:
9 - wmf has y=0 at top, y grows downward (like with standard canvas).
10 - fpv has y=0 at bottom and y grows upwards if page.UseTopLeftCoordinates is
11 false or like wmf otherwise.
12
13 Issues:
14 - Text background is opaque although it should be transparent.
15 - IrfanView cannot open the files written.
16 - Text positioning incorrect due to positive/negative font heights.
17
18 Author: Werner Pamler
19 }
20
21 {.$DEFINE WMF_DEBUG}
22
23 unit wmfvectorialwriter;
24
25 {$mode objfpc}{$H+}
26
27 interface
28
29 uses
30 Classes, SysUtils,
31 FPImage, FPCanvas,
32 fpvectorial, fpvWMF;
33
34 type
35 TParamArray = array of word;
36
37 TWMFObjList = class(TFPList)
38 public
Addnull39 function Add(AData: Pointer): Integer;
FindBrushnull40 function FindBrush(ABrush: TvBrush): Word;
FindFontnull41 function FindFont(AFont: TvFont): Word;
FindPennull42 function FindPen(APen: TvPen): Word;
43 end;
44
45 { TvWMFVectorialWriter }
46
47 TvWMFVectorialWriter = class(TvCustomVectorialWriter)
48 private
49 // Headers
50 FWMFHeader: TWMFHeader;
51 FPlaceableHeader: TPlaceableMetaHeader;
52 // list for WMF Objects
53 FObjList: TWMFObjList;
54 //
55 FBBox: TRect; // in metafile units as specified by UnitsPerInch. NOTE: "logical" units can be different!
56 FLogicalMaxX: Word; // Max x coordinate used for scaling
57 FLogicalMaxY: Word; // Max y coordinate used for scaling
58 FLogicalBounds: TRect; // Enclosing boundary rectangle in logical units
59 FScalingFactor: Double; // Conversion fpvectorial units to logical units
60 FMaxRecordSize: Int64;
61 FCurrFont: TvFont;
62 FCurrBrush: TvBrush;
63 FCurrPen: TvPen;
64 FCurrTextColor: TFPColor;
65 FCurrTextAnchor: TvTextAnchor;
66 FCurrBkMode: Word;
67 FCurrPolyFillMode: Word;
68 FUseTopLeftCoordinates: Boolean;
69 FErrMsg: TStrings;
70
CalcChecksumnull71 function CalcChecksum: Word;
72 procedure ClearObjList;
MakeWMFColorRecordnull73 function MakeWMFColorRecord(AColor: TFPColor): TWMFColorRecord;
74 procedure PrepareScaling(APage: TvVectorialPage);
ScaleXnull75 function ScaleX(x: Double): Integer;
ScaleYnull76 function ScaleY(y: Double): Integer;
ScaleSizeXnull77 function ScaleSizeX(x: Double): Integer;
ScaleSizeYnull78 function ScaleSizeY(y: Double): Integer;
79 procedure UpdateBounds(x, y: Integer);
80
81 procedure WriteBkColor(AStream: TStream; APage: TvVectorialPage);
82 procedure WriteBkMode(AStream: TStream; AMode: Word);
83 procedure WriteBrush(AStream: TStream; ABrush: TvBrush);
84 procedure WriteCircle(AStream: TStream; ACircle: TvCircle);
85 procedure WriteEllipse(AStream: TStream; AEllipse: TvEllipse);
86 procedure WriteEOF(AStream: TStream);
87 procedure WriteExtText(AStream: TStream; AText: TvText);
88 procedure WriteFont(AStream: TStream; AFont: TvFont);
89 procedure WriteLayer(AStream: TStream; ALayer: TvLayer);
90 procedure WriteMapMode(AStream: TStream);
91 procedure WritePageEntities(AStream: TStream; APage: TvVectorialPage);
92 procedure WritePath(AStream: TStream; APath: TPath);
93 procedure WritePen(AStream: TStream; APen: TvPen);
94 procedure WritePolyFillMode(AStream: TStream; AValue: Word);
95 procedure WritePolygon(AStream: TStream; APolygon: TvPolygon);
96 procedure WriteRectangle(AStream: TStream; ARectangle: TvRectangle);
97 procedure WriteText(AStream: TStream; AText: TvText);
98 procedure WriteTextAlign(AStream: TStream; AAlign: Word);
99 procedure WriteTextAnchor(AStream: TStream; AAnchor: TvTextAnchor);
100 procedure WriteTextColor(AStream: TStream; AColor: TFPColor);
101 procedure WriteWindowExt(AStream: TStream);
102 procedure WriteWindowOrg(AStream: TStream);
103
104 procedure WriteEntity(AStream: TStream; AEntity: TvEntity);
105 procedure WriteWMFRecord(AStream: TStream; AFunc: word; ASize: Int64); overload;
106 procedure WriteWMFRecord(AStream: TStream; AFunc: Word; const AParams; ASize: Int64);
107 procedure WriteWMFParams(AStream: TStream; const AParams; ASize: Int64);
108
109 protected
110 procedure WritePage(AStream: TStream; AData: TvVectorialDocument;
111 APage: TvVectorialPage);
112
113 procedure LogError(AMsg: String);
114
115 public
116 constructor Create; override;
117 destructor Destroy; override;
118 procedure WriteToStream(AStream: TStream; AData: TvVectorialDocument); override;
119 end;
120
121 var
122 // Settings
123 gWMFVecReader_UseTopLeftCoords: Boolean = True;
124
125 implementation
126
127 uses
128 Types, LazUTF8, LConvEncoding,
129 Math,
130 fpvUtils;
131
132 const
133 ONE_INCH = 25.4; // 1 inch = 25.4 mm
134 DEFAULT_SIZE = 100; // size of image if scaling info is not available
135 SIZE_OF_WORD = 2;
136
137 type
138 TWMFFont = class
139 Font: TvFont;
140 end;
141
142 TWMFBrush = class
143 Brush: TvBrush;
144 end;
145
146 TWMFPen = class
147 Pen: TvPen;
148 end;
149
150 TWMFPalette = class
151 // not used, just needed as a filler in the ObjList
152 end;
153
154 TWMFRegion = class
155 // not used, just needed as a filler in the ObjList
156 end;
157
158
SameBrushnull159 function SameBrush(ABrush1, ABrush2: TvBrush): Boolean;
160 begin
161 Result := (ABrush1.Color.Red = ABrush2.Color.Red) and
162 (ABrush1.Color.Green = ABrush2.Color.Green) and
163 (ABrush1.Color.Blue = ABrush2.Color.Blue) and
164 (ABrush1.Style = ABrush2.Style);
165 end;
166
SameFontnull167 function SameFont(AFont1, AFont2: TvFont): Boolean;
168 const
169 EPS = 1E-3;
170 begin
171 Result := {(AFont1.Color.Red = AFont2.Color.Red) and
172 (AFont1.Color.Green = AFont2.Color.Green) and
173 (AFont1.Color.Blue = AFont2.Color.Blue) and }
174 (AFont1.Size = AFont2.Size) and
175 (UTF8Lowercase(AFont1.Name) = UTF8Lowercase(AFont2.Name)) and
176 SameValue(AFont1.Orientation, AFont2.Orientation, EPS) and
177 (AFont1.Bold = AFont2.Bold) and
178 (AFont1.Italic = AFont2.Italic) and
179 (AFont1.Underline = AFont2.Underline) and
180 (AFont1.StrikeThrough = AFont2.StrikeThrough);
181 end;
182
SamePennull183 function SamePen(APen1, APen2: TvPen): Boolean;
184 var
185 i: Integer;
186 begin
187 Result := (APen1.Color.Red = APen2.Color.Red) and
188 (APen1.Color.Green = APen2.Color.Green) and
189 (APen1.Color.Blue = APen2.Color.Blue) and
190 (APen1.Style = APen2.Style) and
191 (APen1.Width = APen2.Width) and
192 (High(APen1.Pattern) = High(APen2.Pattern));
193 if Result then
194 for i:=0 to Length(APen1.Pattern) - 1 do
195 if APen1.Pattern[i] <> APen2.Pattern[i] then begin
196 Result := false;
197 exit;
198 end;
199 end;
200
SamePointnull201 function SamePoint(P1, P2: TWMFPointXYRecord): Boolean;
202 begin
203 Result := (P1.X = P2.X) and (P1.Y = P2.Y);
204 end;
205
206
207 { TWMFObjList }
208
Addnull209 function TWMFObjList.Add(AData: Pointer): Integer;
210 var
211 i: Integer;
212 begin
213 // Fill empty items first
214 for i := 0 to Count-1 do
215 if Items[i] = nil then begin
216 Items[i] := AData;
217 Result := i;
218 exit;
219 end;
220 Result := inherited Add(AData);
221 end;
222
FindBrushnull223 function TWMFObjList.FindBrush(ABrush: TvBrush): Word;
224 var
225 i: Integer;
226 begin
227 for i:=0 to Count-1 do
228 if (TObject(Items[i]) is TWMFBrush) and SameBrush(ABrush, TWMFBrush(Items[i]).Brush)
229 then begin
230 Result := i;
231 exit;
232 end;
233 Result := Word(-1);
234 end;
235
FindFontnull236 function TWMFObjList.FindFont(AFont: TvFont): Word;
237 var
238 i: Integer;
239 begin
240 for i:=0 to Count-1 do
241 if (TObject(Items[i]) is TWMFFont) and SameFont(AFont, TWMFFont(Items[i]).Font)
242 then begin
243 Result := i;
244 exit;
245 end;
246 Result := Word(-1);
247 end;
248
TWMFObjList.FindPennull249 function TWMFObjList.FindPen(APen: TvPen): Word;
250 var
251 i: Integer;
252 begin
253 for i:=0 to Count-1 do
254 if (TObject(Items[i]) is TWMFPen) and SamePen(APen, TWMFPen(Items[i]).Pen)
255 then begin
256 Result := i;
257 exit;
258 end;
259 Result := Word(-1);
260 end;
261
262
263 { TvWMFVectorialWriter }
264
265 constructor TvWMFVectorialWriter.Create;
266 begin
267 inherited;
268 FErrMsg := TStringList.Create;
269 FObjList := TWMFObjList.Create;
270 FCurrTextColor := colBlack;
271 FCurrTextAnchor := vtaStart;
272 with FCurrPen do begin
273 Style := TFPPenStyle(-1);
274 Color := colBlack;
275 Width := -1;
276 end;
277 with FCurrBrush do begin
278 Style := TFPBrushStyle(-1);
279 Color := colBlack;
280 end;
281 with FCurrFont do begin
282 Color := colBlack;
283 Size := -1;
284 Name := '';
285 Orientation := 0;
286 Bold := false;
287 Italic := False;
288 Underline := false;
289 StrikeThrough := false;
290 end;
291 end;
292
293 destructor TvWMFVectorialWriter.Destroy;
294 begin
295 ClearObjList;
296 FObjList.Free;
297 FErrMsg.Free;
298 inherited;
299 end;
300
301 { Calculate the checksum of the PlaceableHeader (without the Checksum field) }
CalcChecksumnull302 function TvWMFVectorialWriter.CalcChecksum: Word;
303 var
304 P: ^word;
305 n: Integer;
306 begin
307 Result := 0;
308 P := @FPlaceableHeader;
309 n := 0;
310 while n < SizeOf(FPlaceableHeader) do begin
311 Result := Result xor P^;
312 inc(P);
313 inc(n, SIZE_OF_WORD);
314 end;
315 end;
316
317 procedure TvWMFVectorialWriter.ClearObjList;
318 var
319 i: Integer;
320 begin
321 for i:=0 to FObjList.Count-1 do
322 TObject(FObjList[i]).Free;
323 FObjList.Clear;
324 end;
325
326 procedure TvWMFVectorialWriter.LogError(AMsg: String);
327 begin
328 FErrMsg.Add(AMsg);
329 end;
330
MakeWMFColorRecordnull331 function TvWMFVectorialWriter.MakeWMFColorRecord(AColor: TFPColor): TWMFColorRecord;
332 begin
333 Result.ColorRED := AColor.Red shr 8;
334 Result.ColorGREEN := AColor.Green shr 8;
335 Result.ColorBLUE := AColor.Blue shr 8;
336 Result.Reserved := 0;
337 end;
338
339 procedure TvWMFVectorialWriter.PrepareScaling(APage: TvVectorialPage);
340 const
341 MAXINT16 = 32767;
342 var
343 maxx, maxy: Double;
344 begin
345 FScalingFactor := round(ONE_INCH * 100); // 1 logical unit is 1/100 mm = 10 µm
346 maxx := APage.Width * FScalingFactor;
347 maxy := APage.Height * FScalingFactor;
348 // wmf is 16 bit only! --> reduce magnification if numbers get too big
349 if Max(maxx, maxy) > MAXINT16 then
350 begin
351 FScalingFactor := trunc(MAXINT16 / Max(APage.Width, APage.Height));
352 FLogicalMaxX := word(trunc(APage.Width * FScalingFactor));
353 FLogicalMaxY := word(trunc(APage.Height * FScalingFactor));
354 end else
355 begin
356 FLogicalMaxX := trunc(maxx);
357 FLogicalMaxY := trunc(maxy);
358 end;
359 end;
360
ScaleSizeXnull361 function TvWMFVectorialWriter.ScaleSizeX(x: Double): Integer;
362 begin
363 Result := Round(x * FScalingFactor);
364 end;
365
ScaleSizeYnull366 function TvWMFVectorialWriter.ScaleSizeY(y: Double): Integer;
367 begin
368 Result := Round(y * FScalingFactor);
369 end;
370
TvWMFVectorialWriter.ScaleXnull371 function TvWMFVectorialWriter.ScaleX(x: Double): Integer;
372 begin
373 Result := ScaleSizeX(x);
374 end;
375
TvWMFVectorialWriter.ScaleYnull376 function TvWMFVectorialWriter.ScaleY(y: Double): Integer;
377 begin
378 if FUseTopLeftCoordinates then
379 Result := ScaleSizeY(y) else
380 Result := FLogicalMaxY - ScaleSizeY(y);
381 end;
382
383 procedure TvWMFVectorialWriter.UpdateBounds(x, y: Integer);
384 begin
385 FLogicalBounds.Left := Min(X, FLogicalBounds.Left);
386 FLogicalBounds.Top := Min(Y, FLogicalBounds.Top);
387 FLogicalBounds.Right := Max(X, FLogicalBounds.Right);
388 FLogicalBounds.Bottom := Max(Y, FLogicalBounds.Bottom);
389 end;
390
391 procedure TvWMFVectorialWriter.WriteBkColor(AStream: TStream; APage: TvVectorialPage);
392 var
393 rec: TWMFColorRecord;
394 begin
395 rec := MakeWMFColorRecord(APage.BackgroundColor);
396 WriteWMFRecord(AStream, META_SETBKCOLOR, rec, SizeOf(rec));
397 end;
398
399 procedure TvWMFVectorialWriter.WriteBkMode(AStream: TStream; AMode: Word);
400 var
401 mode: DWord;
402 begin
403 FCurrBkMode := AMode;
404 if AMode in [BM_TRANSPARENT, BM_OPAQUE] then begin
405 mode := AMode;
406 WriteWMFRecord(AStream, META_SETBKMODE, mode, SizeOf(mode));
407 end;
408 end;
409
410 procedure TvWMFVectorialWriter.WriteBrush(AStream: TStream; ABrush: TvBrush);
411 var
412 rec: TWMFBrushRecord;
413 idx: Word;
414 wmfbrush: TWMFBrush;
415 brushstyle: TFPBrushStyle;
416 begin
417 if SameBrush(ABrush, FCurrBrush) then
418 exit;
419
420 idx := FObjList.FindBrush(ABrush);
421 if idx = Word(-1) then begin
422 // No gradient support by wmf --> use a clear brush instead.
423 if ABrush.Kind <> bkSimpleBrush then
424 brushstyle := bsClear else
425 brushstyle := ABrush.Style;
426 case brushstyle of
427 bsClear : rec.Style := BS_NULL;
428 bsSolid : rec.Style := BS_SOLID;
429 bsHorizontal : begin rec.Style := BS_HATCHED; rec.Hatch := HS_HORIZONTAL; end;
430 bsVertical : begin rec.Style := BS_HATCHED; rec.Hatch := HS_VERTICAL; end;
431 bsFDiagonal : begin rec.Style := BS_HATCHED; rec.Hatch := HS_FDIAGONAL; end;
432 bsBDiagonal : begin rec.Style := BS_HATCHED; rec.Hatch := HS_BDIAGONAL; end;
433 bsCross : begin rec.Style := BS_HATCHED; rec.Hatch := HS_CROSS; end;
434 bsDiagCross : begin rec.Style := BS_HATCHED; rec.Hatch := HS_DIAGCROSS; end;
435 { not supported
436 BS_PATTERN = $0003;
437 BS_INDEXED = $0004;
438 BS_DIBPATTERN = $0005;
439 BS_DIBPATTERNPT = $0006;
440 BS_PATTERN8X8 = $0007;
441 BS_DIBPATTERN8X8 = $0008;
442 BS_MONOPATTERN = $0009; }
443 else rec.Style := BS_SOLID;
444 end;
445 rec.ColorRED := ABrush.Color.Red shr 8;
446 rec.ColorGREEN := ABrush.Color.Green shr 8;
447 rec.ColorBLUE := ABrush.Color.Blue shr 8;
448 rec.Reserved := 0;
449 wmfBrush := TWMFBrush.Create;
450 wmfBrush.Brush := ABrush;
451 idx := FObjList.Add(wmfBrush);
452 WriteWMFRecord(AStream, META_CREATEBRUSHINDIRECT, rec, SizeOf(rec));
453 end;
454 WriteWMFRecord(AStream, META_SELECTOBJECT, idx, SizeOf(idx));
455
456 FCurrBrush := ABrush;
457 end;
458
459 procedure TvWMFVectorialWriter.WriteCircle(AStream: TStream;
460 ACircle: TvCircle);
461 var
462 rec: TWMFRectRecord;
463 c, r: TPoint;
464 begin
465 WritePen(AStream, ACircle.Pen);
466 WriteBrush(AStream, ACircle.Brush);
467 c.x := ScaleX(ACircle.X);
468 c.y := ScaleY(ACircle.Y);
469 r.x := ScaleSizeX(ACircle.Radius);
470 r.y := ScaleSizeY(ACircle.Radius);
471 rec.Left := c.x - r.x;
472 rec.Right := c.x + r.x;
473 if FUseTopLeftCoordinates then begin
474 rec.Top := c.y - r.y;
475 rec.Bottom := c.y + r.y;
476 end else
477 begin
478 rec.Top := c.y + r.y;
479 reC.Bottom := c.y - r.y;
480 end;
481 UpdateBounds(rec.Left, rec.Top);
482 UpdateBounds(rec.Right, rec.Bottom);
483
484 // WMF record header + parameters
485 WriteWMFRecord(AStream, META_ELLIPSE, rec, SizeOf(TWMFRectRecord));
486 end;
487
488 procedure TvWMFVectorialWriter.WriteEllipse(AStream: TStream;
489 AEllipse: TvEllipse);
490 var
491 r: TWMFRectRecord;
492 begin
493 WritePen(AStream, AEllipse.Pen);
494 WriteBrush(AStream, AEllipse.Brush);
495 r.Left := ScaleX(AEllipse.X - AEllipse.HorzHalfAxis);
496 r.Top := ScaleY(AEllipse.Y + AEllipse.VertHalfAxis);
497 r.Right := ScaleX(AEllipse.X + AEllipse.HorzHalfAxis);
498 r.Bottom := ScaleY(AEllipse.Y - AEllipse.VertHalfAxis);
499 UpdateBounds(r.Left, r.Top);
500 UpdateBounds(r.Right, r.Bottom);
501
502 // WMF record header + parameters
503 WriteWMFRecord(AStream, META_ELLIPSE, r, SizeOf(TWMFRectRecord));
504 end;
505
506
507 procedure TvWMFVectorialWriter.WriteEntity(AStream: TStream; AEntity: TvEntity);
508 begin
509 if AEntity is TvPolygon then
510 WritePolygon(AStream, TvPolygon(AEntity))
511 else if AEntity is TvRectangle then
512 WriteRectangle(AStream, TvRectangle(AEntity))
513 else if AEntity is TvCircle then
514 WriteCircle(AStream, TvCircle(AEntity))
515 else if AEntity is TvEllipse then
516 WriteEllipse(AStream, TvEllipse(AEntity))
517 else if AEntity is TvText then
518 WriteText(AStream, TvText(AEntity))
519 else if AEntity is TPath then
520 WritePath(AStream, TPath(AEntity));
521 end;
522
523 procedure TvWMFVectorialWriter.WriteEOF(AStream: TStream);
524 begin
525 WriteWMFRecord(AStream, META_EOF, 0);
526 end;
527
528 procedure TvWMFVectorialWriter.WriteExtText(AStream: TStream; AText: TvText);
529 var
530 s: String;
531 rec: TWMFExtTextRecord;
532 i, n: Integer;
533 P: TPoint;
534 offs: TPoint;
535 brush: TvBrush;
536 begin
537 brush := AText.Brush;
538 if (brush.Style = bsClear) and (FCurrBkMode = BM_OPAQUE) then
539 WriteBkMode(AStream, BM_TRANSPARENT)
540 else begin
541 if FCurrBkMode = BM_TRANSPARENT then
542 WriteBkMode(AStream, BM_OPAQUE);
543 WriteBrush(AStream, AText.Brush);
544 end;
545
546 WriteFont(AStream, AText.Font);
547
548 if (AText.TextAnchor <> FCurrTextAnchor) then
549 WriteTextAnchor(AStream, AText.TextAnchor);
550
551 s := UTF8ToISO_8859_1(AText.Value.Text);
552 n := SizeOf(TWMFExtTextRecord) + Length(s);
553 if odd(n) then begin
554 inc(n);
555 s := s + #0;
556 end;
557
558 rec.X := ScaleX(AText.X);
559 rec.Y := ScaleY(AText.Y);
560 // No vertical offset required because text alignment is TA_BASELINE.
561 rec.Options := 0; // no clipping, no background
562 rec.Len := UTF8Length(s);
563
564 WriteWMFRecord(AStream, META_EXTTEXTOUT, rec, n);
565 AStream.Position := AStream.Position - Length(s);
566 WriteWMFParams(AStream, s[1], Length(s));
567 end;
568
569 procedure TvWMFVectorialWriter.WriteFont(AStream: TStream; AFont: TvFont);
570 var
571 rec: TWMFFontRecord;
572 idx: Word;
573 wmfFont: TWMFFont;
574 fntName: String;
575 i, n: Integer;
576 begin
577 if (AFont.Color.Red <> FCurrTextColor.Red) or
578 (AFont.Color.Green <> FCurrTextColor.Green) or
579 (AFont.Color.Blue <> FCurrTextColor.Blue)
580 then
581 WriteTextColor(AStream, AFont.Color);
582
583 if SameFont(AFont, FCurrFont) then
584 exit;
585
586 idx := FObjList.FindFont(AFont);
587 if idx = Word(-1) then begin
588 fntName := UTF8ToISO_8859_1(AFont.Name) + #0;
589 if odd(UTF8Length(fntName)) then
590 fntName := fntName + #0;
591 if Length(fntName) > 32 then begin
592 Delete(fntName, 31, MaxInt);
593 fntName := fntName + #0;
594 end;
595
596 n := SizeOf(TWMFFontRecord) + Length(fntName);
597 rec.Height := ScaleSizeY(AFont.Size);
598 rec.Width := 0;
599 rec.Orientation := round(AFont.Orientation * 10);
600 rec.Escapement := round(AFont.Orientation * 10); // 0;
601 // strange: must use "Escapement" here, not "Orientation".
602 // Otherwise MS software will not show the rotated font.
603 rec.Weight := IfThen(AFont.Bold, 700, 400);
604 rec.Italic := IfThen(AFont.Italic, 1, 0);
605 rec.Underline := IfThen(AFont.Underline, 1, 0);
606 rec.Strikeout := IfThen(AFont.StrikeThrough, 1, 0);
607 rec.Charset := DEFAULT_CHARSET;
608 rec.OutPrecision := 0; // default
609 rec.ClipPrecision := 0; // default
610 rec.Quality := 0; // default
611 rec.PitchAndFamily := 0; // don't care / default
612
613 WriteWMFRecord(AStream, META_CREATEFONTINDIRECT, rec, n);
614 AStream.Position := AStream.Position - Length(fntName);
615 WriteWMFParams(AStream, fntName[1], Length(fntName));
616
617 wmfFont := TWMFFont.Create;
618 wmfFont.Font := AFont;
619 idx := FObjList.Add(wmfFont);
620 end;
621 WriteWMFRecord(AStream, META_SELECTOBJECT, idx, SizeOf(idx));
622
623 FCurrFont := AFont;
624 end;
625
626 procedure TvWMFVectorialWriter.WriteLayer(AStream: TStream; ALayer: TvLayer);
627 var
628 entity: TvEntity;
629 i: Integer;
630 begin
631 for i := 0 to ALayer.GetEntitiesCount - 1 do
632 begin
633 entity := ALayer.GetEntity(i);
634 WriteEntity(AStream, entity);
635 end;
636 end;
637
638 procedure TvWMFVectorialWriter.WriteMapMode(AStream: TStream);
639 var
640 mode: Word;
641 begin
642 mode := MM_ANISOTROPIC;
643 WriteWMFRecord(AStream, META_SETMAPMODE, mode, SizeOf(mode));
644 end;
645
646 procedure TvWMFVectorialWriter.WritePage(AStream: TStream;
647 AData: TvVectorialDocument; APage: TvVectorialPage);
648 begin
649 WriteWindowExt(AStream);
650 WriteWindowOrg(AStream);
651 WriteMapMode(AStream);
652 WriteBkColor(AStream, APage);
653 WriteBkMode(AStream, BM_TRANSPARENT);
654 WriteTextAlign(AStream, TA_BASELINE or TA_LEFT);
655
656 WritePageEntities(AStream, APage);
657
658 WriteEOF(AStream);
659 end;
660
661 procedure TvWMFVectorialWriter.WritePageEntities(AStream: TStream;
662 APage: TvVectorialPage);
663 var
664 entity: TvEntity;
665 i: Integer;
666 begin
667 for i := 0 to APage.GetEntitiesCount - 1 do
668 begin
669 entity := APage.GetEntity(i);
670 WriteEntity(AStream, entity);
671 end;
672 end;
673
674 procedure TvWMFVectorialWriter.WritePath(AStream: TStream; APath: TPath);
675 var
676 points: TPointsArray; // array of TPoint
677 pts: array of TWMFPointXYRecord;
678 polystarts: TIntegerDynArray;
679 allclosed: boolean;
680 isClosed: Boolean;
681 i, len: Word;
682 first, last: Integer;
683 p, npoly, npts: Integer;
684 begin
685 WritePen(AStream, APath.Pen);
686 WriteBrush(AStream, APath.Brush);
687
688 ConvertPathToPolygons(APath, 0, 0, FScalingFactor, FScalingFactor, points, polystarts);
689 SetLength(pts, Length(points));
690 for i:=0 to High(points) do begin
691 pts[i].X := points[i].X;
692 if FUseTopLeftCoordinates then
693 pts[i].Y := points[i].Y else
694 pts[i].Y := FLogicalMaxY - points[i].Y;
695 end;
696
697 allClosed := true;
698 p := 0;
699 while p < Length(polystarts) do begin
700 first := polystarts[p];
701 last := IfThen(p = High(polystarts), High(pts), polystarts[p+1]-1);
702 isClosed := SamePoint(pts[first], pts[last]);
703 if not isClosed then begin
704 allClosed := false;
705 break;
706 end;
707 inc(p);
708 end;
709
710 npoly := Length(polystarts);
711 if allClosed and (Length(polystarts) > 1) then begin
712 // "POLY-POLYGON"
713 WriteWMFRecord(AStream, META_POLYPOLYGON, // Prepare memory for ...
714 SIZE_OF_WORD + // ... polygon count
715 Length(polystarts) * SIZE_OF_WORD + // ... point count per polygon
716 Length(pts) * SizeOf(TWMFPointXYRecord) // ... points
717 );
718 // Write polgon count
719 WriteWMFParams(AStream, npoly, SIZE_OF_WORD);
720 // Write number of points per polygon
721 p := 0;
722 while p < Length(polystarts) do begin
723 first := polystarts[p];
724 last := IfThen(p = High(polystarts), High(pts), polystarts[p+1]-1);
725 npts := last - first + 1;
726 WriteWMFParams(AStream, npts, SIZE_OF_WORD);
727 inc(p);
728 end;
729 // Write points of each polygon
730 p := 0;
731 while p < Length(polystarts) do begin
732 first := polystarts[p];
733 last := IfThen(p = High(polystarts), High(pts), polystarts[p+1]-1);
734 npts := last - first + 1;
735 WriteWMFParams(AStream, pts[first], npts*SizeOf(TWMFPointXYRecord));
736 inc(p);
737 end;
738 end else
739 begin
740 p := 0;
741 while p < Length(polystarts) do begin
742 first := polystarts[p];
743 last := IfThen(p = High(polystarts), High(pts), polystarts[p+1]-1);
744 len := last - first + 1;
745 isClosed := SamePoint(pts[first], pts[last]);
746 if isClosed and (APath.Brush.Kind = bkSimpleBrush) and (APath.Brush.Style <> bsClear) then
747 WriteWMFRecord(AStream, META_POLYGON, SIZE_OF_WORD + len * SizeOf(TWMFPointXYRecord))
748 else
749 WriteWMFRecord(AStream, META_POLYLINE, SIZE_OF_WORD + len * SizeOf(TWMFPointXYRecord));
750 WriteWMFParams(AStream, len, SIZE_OF_WORD);
751 WriteWMFParams(AStream, pts[first], len * SizeOf(TWMFPointXYRecord));
752 inc(p);
753 end;
754 end;
755 end;
756
757 procedure TvWMFVectorialWriter.WritePen(AStream: TStream; APen: TvPen);
758 var
759 rec: TWMFPenRecord;
760 idx: Word;
761 wmfpen: TWMFPen;
762 begin
763 if SamePen(APen, FCurrPen) then
764 exit;
765
766 idx := FObjList.FindPen(APen);
767 if idx = Word(-1) then begin
768 case APen.Style of
769 psDash : rec.Style := PS_DASH;
770 psDot : rec.Style := PS_DOT;
771 psDashDot : rec.Style := PS_DASHDOT;
772 psDashDotDot : rec.Style := PS_DASHDOTDOT;
773 psClear : rec.Style := PS_NULL;
774 psInsideFrame: rec.Style := PS_INSIDEFRAME;
775 else rec.Style := PS_SOLID;
776 end;
777 rec.Width := ScaleSizeX(APen.Width);
778 rec.Ignored1 := 0;
779 rec.ColorRED := APen.Color.Red shr 8;
780 rec.ColorGREEN := APen.Color.Green shr 8;
781 rec.ColorBLUE := APen.Color.Blue shr 8;
782 rec.Ignored2 := 0;
783 wmfPen := TWMFPen.Create;
784 wmfPen.Pen := APen;
785 idx := FObjList.Add(wmfPen);
786 WriteWMFRecord(AStream, META_CREATEPENINDIRECT, rec, SizeOf(rec));
787 end;
788 WriteWMFRecord(AStream, META_SELECTOBJECT, idx, SizeOf(idx));
789
790 FCurrPen := APen;
791 end;
792
793 procedure TvWMFVectorialWriter.WritePolyFillMode(AStream: TStream;
794 AValue: Word);
795 begin
796 WriteWMFRecord(AStream, META_SETPOLYFILLMODE, AValue, SizeOf(AValue));
797 end;
798
799 procedure TvWMFVectorialWriter.WritePolygon(AStream: TStream;
800 APolygon: TvPolygon);
801 var
802 pts: array of TWMFPointXYRecord;
803 i: Integer;
804 w: Word;
805 begin
806 case APolygon.WindingRule of
807 vcmEvenOddRule : WritePolyFillMode(AStream, ALTERNATE);
808 vcmNonzeroWindingRule : WritePolyFillMode(AStream, WINDING);
809 end;
810
811 WritePen(AStream, APolygon.Pen);
812 WriteBrush(AStream, APolygon.Brush);
813 SetLength(pts, Length(APolygon.Points));
814 for i:=0 to High(APolygon.Points) do begin
815 pts[i].X := ScaleX(APolygon.Points[i].X);
816 pts[i].Y := ScaleY(APolygon.Points[i].Y);
817 UpdateBounds(pts[i].X, pts[i].Y);
818 end;
819
820 // WMF Record header
821 if (APolygon.Brush.Kind = bkSimpleBrush) and (APolygon.Brush.Style = bsClear) then
822 WriteWMFRecord(AStream, META_POLYLINE, Length(pts) * SizeOf(TWMFPointXYRecord) + SIZE_OF_WORD)
823 else
824 WriteWMFRecord(AStream, META_POLYGON, Length(pts) * SizeOf(TWMFPointXYRecord) + SIZE_OF_WORD);
825
826 // Number of points in polygon
827 w := Length(APolygon.Points);
828 WriteWMFParams(AStream, w, SIZE_OF_WORD);
829
830 // Polygon points
831 WriteWMFParams(AStream, pts[0], Length(pts) * SizeOf(TWMFPointXYRecord));
832 end;
833
834 procedure TvWMFVectorialWriter.WriteRectangle(AStream: TStream;
835 ARectangle: TvRectangle);
836 var
837 r: TWMFRectRecord;
838 p: TWMFPointRecord;
839 begin
840 WritePen(AStream, ARectangle.Pen);
841 WriteBrush(AStream, ARectangle.Brush);
842 r.Left := ScaleX(ARectangle.X);
843 r.Top := ScaleY(ARectangle.Y);
844 r.Right := ScaleX(ARectangle.X + ARectangle.CX);
845 r.Bottom := ScaleY(ARectangle.Y - ARectangle.CY);
846 UpdateBounds(r.Left, r.Top);
847 UpdateBounds(r.Right, r.Bottom);
848
849 // WMF record header + parameters
850 if (ARectangle.RX = 0) or (ARectangle.RY = 0) then
851 // "normal" rectangle
852 WriteWMFRecord(AStream, META_RECTANGLE, r, SizeOf(TWMFRectRecord))
853 else begin
854 // rounded rectangle
855 p.X := ScaleSizeX(ARectangle.RX);
856 p.Y := ScaleSizeY(ARectangle.RY);
857 WriteWMFRecord(AStream, META_ROUNDRECT, SizeOf(p) + SizeOf(r));
858 WriteWMFParams(AStream, p, SizeOf(p));
859 WriteWMFParams(AStream, r, SizeOf(r));
860 end;
861 end;
862
863 procedure TvWMFVectorialWriter.WriteText(AStream: TStream; AText: TvText);
864 var
865 s: String;
866 n: Integer;
867 len: SmallInt;
868 rec: TWMFPointRecord;
869 offs: TPoint;
870 P: TPoint;
871 brush: TvBrush;
872 begin
873 brush := AText.Brush;
874 if (brush.Style = bsClear) and (FCurrBkMode = BM_OPAQUE) then
875 WriteBkMode(AStream, BM_TRANSPARENT)
876 else begin
877 if FCurrBkMode = BM_TRANSPARENT then
878 WriteBkMode(AStream, BM_OPAQUE);
879 WriteBrush(AStream, AText.Brush);
880 end;
881
882 WriteFont(AStream, AText.Font);
883
884 if (AText.TextAnchor <> FCurrTextAnchor) then
885 WriteTextAnchor(AStream, AText.TextAnchor);
886
887 s := UTF8ToISO_8859_1(AText.Value.Text);
888 len := Length(s);
889 if odd(len) then begin
890 s := s + #0;
891 inc(len);
892 end;
893
894 rec.X := ScaleX(AText.X);
895 rec.Y := ScaleY(AText.Y);
896 // No vertical font height offset required because text alignment is TA_BASELINE
897
898 { The record structure is
899 - TWMFRecord
900 - Stringlength (SmallInt)
901 - String, no trailing zero
902 - y
903 - x }
904 WriteWMFRecord(AStream, META_TEXTOUT, SizeOf(len) + len + SizeOf(TWMFPointRecord));
905 WriteWMFParams(AStream, len, SizeOf(len));
906 WriteWMFParams(AStream, s[1], Length(s));
907 WriteWMFParams(AStream, rec, SizeOf(rec));
908 end;
909
910 procedure TvWMFVectorialWriter.WriteTextAlign(AStream: TStream; AAlign: word);
911 begin
912 WriteWMFRecord(AStream, META_SETTEXTALIGN, AAlign, SizeOf(AAlign));
913 end;
914
915 procedure TvWMFVectorialWriter.WriteTextAnchor(AStream: TStream;
916 AAnchor: TvTextAnchor);
917 var
918 align: DWord;
919 begin
920 case AAnchor of
921 vtaStart : align := TA_LEFT;
922 vtaMiddle : align := TA_CENTER;
923 vtaEnd : align := TA_RIGHT;
924 end;
925 align := align or TA_BASELINE;
926 WriteTextAlign(AStream, align);
927 FCurrTextAnchor := AAnchor;
928 end;
929
930 procedure TvWMFVectorialWriter.WriteTextColor(AStream: TStream;
931 AColor: TFPColor);
932 var
933 rec: TWMFColorRecord;
934 begin
935 rec := MakeWMFColorRecord(AColor);
936 WriteWMFRecord(AStream, META_SETTEXTCOLOR, rec, SizeOf(rec));
937 FCurrTextColor := AColor;
938 end;
939
940 procedure TvWMFVectorialWriter.WriteToStream(AStream: TStream;
941 AData: TvVectorialDocument);
942 const
943 PAGE_INDEX = 0;
944 var
945 page: TvVectorialPage;
946 begin
947 // Initialize
948 ClearObjList;
949 FErrMsg.Clear;
950 FWMFHeader.MaxRecordSize := 0;
951 FBBox := Rect(0, 0, 0, 0);
952 page := AData.GetPageAsVectorial(PAGE_INDEX);
953 FUseTopLeftCoordinates := page.UseTopLeftCoordinates;
954
955 // Prepare scaling
956 PrepareScaling(page);
957
958 FLogicalBounds := Rect(LongInt($7FFFFFFF), LongInt($7FFFFFFF), LongInt($80000000), LongInt($80000000));
959
960 // Write placeholder for WMF header and placeable header,
961 // will be rewritten with correct values later
962 AStream.Write(FWMFHeader, SizeOf(TWMFHeader));
963 AStream.Write(FPlaceableHeader, SizeOf(TPlaceableMetaHeader));
964
965 // Write the specified page of the document
966 WritePage(AStream, AData, page);
967
968 // Go back to the beginning of the file and write the headers. Use correct
969 // header fields now.
970 with FPlaceableHeader do begin
971 Key := WMF_MAGIC_NUMBER;
972 Handle := 0;
973 Reserved := 0;
974 Inch := ScaleX(ONE_INCH);
975 Left := 0;
976 Top := 0;
977 Right := ScaleSizeX(page.Width);
978 Bottom := ScaleSizeX(page.Height);
979 Checksum := CalcChecksum;
980 end;
981 AStream.Position := 0;
982 AStream.WriteBuffer(FPlaceableHeader, SizeOf(TPlaceableMetaHeader));
983
984 with FWMFHeader do begin
985 FileType := 1;
986 HeaderSize := 9;
987 Version := $0300;
988 NumOfObjects := FObjList.Count;
989 MaxRecordSize := FMaxRecordSize;
990 FileSize := AStream.Size div SIZE_OF_WORD;
991 NumOfParams := 0;
992 end;
993 AStream.WriteBuffer(FWMFHeader, SizeOf(TWMFHeader));
994
995 if FErrMsg.Count > 0 then
996 raise Exception.Create(FErrMsg.Text);
997 end;
998
999 procedure TvWMFVectorialWriter.WriteWindowExt(AStream: TStream);
1000 var
1001 params: Array[0..1] of word;
1002 begin
1003 params[0] := FLogicalMaxY;
1004 params[1] := FLogicalMaxX;
1005 WriteWMFRecord(AStream, META_SETWINDOWEXT, params, SizeOf(params));
1006 end;
1007
1008 procedure TvWMFVectorialWriter.WriteWindowOrg(AStream: TStream);
1009 var
1010 params: Array[0..1] of word;
1011 begin
1012 params[0] := 0;
1013 params[1] := 0;
1014 WriteWMFRecord(AStream, META_SETWINDOWORG, params, Sizeof(params));
1015 end;
1016
1017 { ASize is in bytes }
1018 procedure TvWMFVectorialWriter.WriteWMFRecord(AStream: TStream;
1019 AFunc: Word; ASize: Int64);
1020 var
1021 rec: TWMFRecord;
1022 begin
1023 rec.Size := (SizeOf(TWMFRecord) + ASize) div SIZE_OF_WORD;
1024 rec.Func := AFunc;
1025 AStream.WriteBuffer(rec, SizeOf(TWMFRecord));
1026 FMaxRecordSize := Max(FMaxRecordSize, rec.Size);
1027 end;
1028
1029 { ASize is the size of the parameter part, in bytes }
1030 procedure TvWMFVectorialWriter.WriteWMFRecord(AStream: TStream;
1031 AFunc: Word; const AParams; ASize: Int64);
1032 var
1033 rec: TWMFRecord;
1034 begin
1035 rec.Size := (SizeOf(TWMFRecord) + ASize) div SIZE_OF_WORD;
1036 rec.Func := AFunc;
1037 AStream.WriteBuffer(rec, SizeOf(TWMFRecord));
1038 AStream.WriteBuffer(AParams, ASize);
1039 end;
1040
1041 { ASize is in bytes }
1042 procedure TvWMFVectorialWriter.WriteWMFParams(AStream: TStream;
1043 const AParams; ASize: Int64);
1044 begin
1045 AStream.WriteBuffer(AParams, ASize);
1046 end;
1047
1048 initialization
1049 RegisterVectorialWriter(TvWMFVectorialWriter, vfWindowsMetafileWMF);
1050
1051 end.
1052
1053