1: 2: 3: 4: 5: 6: 7: 8: 9: 10: 11: 12: 13: 14: 15: 16: 17: 18: 19: 20: 21: 22: 23: 24: 25: 26: 27: 28: 29: 30: 31: 32: 33: 34: 35: 36: 37: 38: 39: 40: 41: 42: 43: 44: 45: 46: 47: 48: 49: 50: 51: 52: 53: 54: 55: 56: 57: 58: 59: 60: 61: 62: 63: 64: 65: 66: 67: 68: 69: 70: 71: 72: 73: 74: 75: 76: 77: 78: 79: 80: 81: 82: 83: 84: 85: 86: 87: 88: 89: 90: 91: 92: 93: 94: 95: 96: 97: 98: 99: 100: 101: 102: 103: 104: 105: 106: 107: 108: 109: 110: 111: 112: 113: 114: 115: 116: 117: 118: 119: 120: 121: 122: 123: 124: 125: 126: 127: 128: 129: 130: 131: 132: 133: 134: 135: 136: 137: 138: 139: 140: 141: 142: 143: 144: 145: 146: 147: 148: 149: 150: 151: 152: 153: 154: 155: 156: 157: 158: 159: 160: 161: 162: 163: 164: 165: 166: 167: 168: 169: 170: 171: 172: 173: 174: 175: 176: 177: 178: 179: 180: 181: 182: 183: 184: 185: 186: 187: 188: 189: 190: 191: 192: 193: 194: 195: 196: 197: 198: 199: 200: 201: 202: 203: 204: 205: 206: 207: 208: 209: 210: 211: 212: 213: 214: 215: 216: 217: 218: 219: 220: 221: 222: 223: 224: 225: 226: 227: 228: 229: 230: 231: 232: 233: 234: 235: 236: 237: 238: 239: 240: 241: 242: 243: 244: 245: 246: 247: 248: 249: 250: 251: 252: 253: 254: 255: 256: 257: 258: 259: 260: 261: 262: 263: 264: 265: 266: 267: 268: 269: 270: 271: 272: 273: 274: 275: 276: 277: 278: 279: 280: 281: 282: 283: 284: 285: 286: 287: 288: 289: 290: 291: 292: 293: 294: 295: 296: 297: 298: 299: 300: 301: 302: 303: 304: 305: 306: 307: 308: 309: 310: 311: 312: 313: 314: 315: 316: 317: 318: 319: 320: 321: 322: 323: 324: 325: 326: 327: 328: 329: 330: 331: 332: 333: 334: 335: 336: 337: 338: 339: 340: 341: 342: 343: 344: 345: 346: 347: 348: 349: 350: 351: 352: 353: 354: 355: 356: 357: 358: 359: 360: 361: 362: 363: 364: 365: 366: 367: 368: 369: 370: 371: 372: 373: 374: 375: 376: 377: 378: 379: 380: 381: 382: 383: 384: 385: 386: 387: 388: 389: 390: 391: 392: 393: 394: 395: 396: 397: 398: 399: 400: 401: 402: 403: 404: 405: 406: 407: 408: 409: 410: 411: 412: 413: 414: 415: 416: 417: 418: 419: 420: 421: 422: 423: 424: 425: 426: 427: 428: 429: 430: 431: 432: 433: 434: 435: 436: 437: 438: 439: 440: 441: 442: 443: 444: 445: 446: 447: 448: 449: 450: 451: 452: 453: 454: 455: 456: 457: 458: 459: 460: 461: 462: 463: 464: 465: 466: 467: 468: 469: 470: 471: 472: 473: 474: 475: 476: 477: 478: 479: 480: 481: 482: 483: 484: 485: 486: 487: 488: 489: 490: 491: 492: 493: 494: 495: 496: 497: 498: 499: 500: 501: 502: 503: 504: 505: 506: 507: 508: 509: 510: 511: 512: 513: 514: 515: 516: 517: 518: 519: 520: 521: 522: 523: 524: 525: 526: 527: 528: 529: 530: 531: 532: 533: 534: 535: 536: 537: 538: 539: 540: 541: 542: 543: 544: 545: 546: 547: 548: 549: 550: 551: 552: 553: 554: 555: 556: 557: 558: 559: 560: 561: 562: 563: 564: 565: 566: 567: 568: 569: 570: 571: 572: 573: 574: 575: 576: 577: 578: 579: 580: 581: 582: 583: 584: 585: 586: 587: 588:
|
unit Print;
interface
uses Windows, SysUtils, Dialogs, Printers, Constants, Main, Kontakt;
type TPrint = class(TObject) private FHorzSize: Integer; FVerSize: Integer; FTitle: string; FHeaderLeft: string; FHeaderRight: string; FFooterLeft: string; FFooterCenter: string; FColCount: Integer; FColWidth: Integer; FRecordsPerPage: Integer; FLinesPerPage: Integer;
procedure SetTitle(Title: string); procedure SetHeaderLeft(Headerleft: string); procedure SetHeaderRight(HeaderRight: string); procedure SetFooterLeft(Footerleft: string); procedure SetFootCenter(FooterCenter: string); procedure SetColCount(ColCount: Cardinal); procedure SetColWidth(ColWidth: Cardinal); procedure SetRecordsPerPage(RecordsPerPage: Cardinal); procedure SetLinesPerPage(LinesPerPage: Cardinal);
function ReplaceTokens(s: string): string;
function MakeFont(Font: string; Size: Integer; Weight: Integer): HFONT; procedure PrintHeader(hDC: THandle; Lineheight: Integer); procedure PrintFooter(hDC: THandle; LineHeight: Integer; Page: Integer); function PrintContact(hDC: THandle; Left, Top, LineHeight: Integer; Contact: TContactRec): Integer; function PrintTelephoneListContact(hDC: THandle; Contact: TContactRec; Left, Top, LineHeight: Integer): Integer; public constructor Create; property Title: string write SetTitle; property HeaderLeft: string write SetHeaderleft; property HeaderRight: string write SetHeaderRight; property FooterLeft: string write SetFooterLeft; property FooterCenter: string write SetFootCenter; property ColCount: cardinal write SetColCount; property ColWidth: Cardinal write SetColWidth; property RecordsPerPage: Cardinal write SetRecordsPerPage; property LinesPerPage: Cardinal write SetLinesPerPage; procedure PrintCurrentRecord(PrintDialog: TPrintDialog; Contact: TContactRec); procedure PrintAllRecords(PrintDialog: TPrintDialog; Contacts: TContactList); procedure PrintTelephoneList(PrintDialog: TPrintDialog; Contacts: TContactList); end;
var TokenArray: array[0..1] of string = ('%DATE%', '%TIME%');
implementation
constructor TPrint.Create; begin inherited Create; FColCount := COLS; FColWidth := COL_WIDTH * 10; FRecordsPerPage := RPP; FLinesPerPage := LPP; end;
procedure TPrint.SetTitle(Title: string); begin FTitle := Title; end;
procedure TPrint.SetHeaderLeft(HeaderLeft: string); begin FHeaderLeft := HeaderLeft; end;
procedure TPrint.SetHeaderRight(HeaderRight: string); begin FHeaderRight := HeaderRight; end;
procedure TPrint.SetFooterLeft(FooterLeft: string); begin FFooterLeft := FooterLeft; end;
procedure TPrint.SetFootCenter(FooterCenter: string); begin FFooterCenter := FooterCenter; end;
procedure TPrint.SetColCount(ColCount: Cardinal); begin FColCount := ColCount; end;
procedure TPrint.SetColWidth(ColWidth: Cardinal); begin FColWidth := ColWidth * 10; end;
procedure TPrint.SetRecordsPerPage(RecordsPerPage: Cardinal); begin FRecordsPerPage := RecordsPerPage end;
procedure TPrint.SetLinesPerPage(LinesPerPage: Cardinal); begin FLinesPerPage := LinesPerPage; end;
function TPrint.ReplaceTokens(s: string): string; var Dummy: string; begin dummy := StringReplace(s, TokenArray[0], DateToStr(now), [rfReplaceALL]); dummy := StringReplace(dummy, TokenArray[1], TimeToStr(now), [rfReplaceALL]); result := dummy; end;
function TPrint.MakeFont(Font: string; Size: Integer; Weight: Integer): HFONT; begin result := CreateFont(Size, 0, 0, 0, Weight, 0, 0, 0, ANSI_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH, PChar(Font)); end;
procedure TPrint.PrintHeader(hDC: THandle; LineHeight: Integer); var rec: TRect; MyFont: HFONT; OldFont: HFONT; s: string; begin SetMapMode(hDC, MM_LOMETRIC); rec.Top := -TOPBORDER * SCALE; rec.Left := LEFTBORDER * SCALE; rec.Bottom := -(TOPBORDER * SCALE) - Lineheight; rec.Right := (FHorzSize - RIGHTBORDER) * SCALE; s := ReplaceTokens(FTitle); MyFont := MakeFont(FONTNAME, FONTSIZE, 700); OldFont := SelectObject(hDC, MyFont); DrawText(hDC, PChar(s), length(s), rec, DT_CENTER); SelectObject(hDC, OldFont); DeleteObject(MyFont); s := ReplaceTokens(FHeaderleft); MyFont := MakeFont(FONTNAME, FONTSIZE, 400); OldFont := SelectObject(HDC, MyFont); DrawText(hDC, PChar(s), length(s), rec, DT_LEFT); s := ReplaceTokens(FHeaderRight); DrawText(hDC, PChar(s), length(s), rec, DT_RIGHT); SelectObject(hDC, OldFont); DeleteObject(MyFont); end;
procedure TPrint.PrintFooter(hDC: THandle; LineHeight: Integer; Page: Integer); var rec: TRect; MyFont: HFONT; OldFont: HFONT; begin SetMapMode(hDC, MM_LOMETRIC); rec.Top := -((FVerSize - BOTTOMBORDER) * SCALE); rec.Left := LEFTBORDER * SCALE; rec.Right := (FHorzSize - RIGHTBORDER) * SCALE; rec.Bottom := -((FVerSize - BOTTOMBORDER) * SCALE) - LineHeight * 2; MyFont := MakeFont(FONTNAME, FONTSIZE, 400); OldFont := SelectObject(HDC, MyFont); DrawText(hDC, PChar(FFooterLeft), length(FFooterLeft), rec, DT_LEFT); DrawText(hDC, PChar(FFooterCenter), length(FFooterCenter), rec, DT_CENTER); DrawText(hDC, PChar(IntToStr(Page)), length(IntToStr(Page)), rec, DT_RIGHT); SelectObject(hDC, OldFont); DeleteObject(MyFont); end;
function TPrint.PrintContact(hDC: THandle; Left, Top, LineHeight: Integer; Contact: TContactRec): Integer; var rec: TRect; MyFont: HFONT; OldFont: HFONT; s: string; begin SetMapMode(hDC, MM_LOMETRIC); rec.Top := -Top; rec.Left := Left; rec.Bottom := -Top - Lineheight; rec.Right := (FHorzSize - RIGHTBORDER) * SCALE; MyFont := MakeFont(FONTNAME, FONTSIZE, 700); OldFont := SelectObject(hDC, MyFont); s := 'Name: ' + Contact.Firma + ' ' + Contact.Name + ' ' + Contact.Vorname; DrawText(hDC, PChar(s), length(s), rec, 0); SelectObject(hDC, OldFont); DeleteObject(MyFont); rec.Top := rec.Top - Lineheight; rec.Bottom := rec.Bottom - Lineheight; MyFont := MakeFont(FONTNAME, FONTSIZE, 400); OldFont := SelectObject(hDC, MyFont); s := 'Strasse: ' + Contact.Strasse; DrawText(hDC, PChar(s), length(s), rec, 0); rec.Top := rec.Top - Lineheight; rec.Bottom := rec.Bottom - Lineheight; s := 'Ort: ' + Contact.PLZ + ' ' + Contact.Ort; DrawText(hDC, PChar(s), length(s), rec, 0); rec.Top := rec.Top - Lineheight; rec.Bottom := rec.Bottom - Lineheight; s := 'Land: ' + Contact.Land; DrawText(hDC, PChar(s), length(s), rec, 0); rec.Top := rec.Top - Lineheight; rec.Bottom := rec.Bottom - Lineheight; s := 'Telefon 1: ' + Contact.Telefon1; DrawText(hDC, PChar(s), length(s), rec, 0); rec.Top := rec.Top - Lineheight; rec.Bottom := rec.Bottom - Lineheight; s := 'Telefon 2: ' + Contact.Telefon2; DrawText(hDC, PChar(s), length(s), rec, 0); rec.Top := rec.Top - Lineheight; rec.Bottom := rec.Bottom - Lineheight; s := 'Fax: ' + Contact.Fax; DrawText(hDC, PChar(s), length(s), rec, 0); rec.Top := rec.Top - Lineheight; rec.Bottom := rec.Bottom - Lineheight; s := 'E-Mail 1: ' + Contact.EMail1; DrawText(hDC, PChar(s), length(s), rec, 0); rec.Top := rec.Top - Lineheight; rec.Bottom := rec.Bottom - Lineheight; s := 'E-Mail 2: ' + Contact.EMail2; DrawText(hDC, PChar(s), length(s), rec, 0); rec.Top := rec.Top - Lineheight; rec.Bottom := rec.Bottom - Lineheight; s := 'Geburtsdatum: ' + Contact.GebDat; DrawText(hDC, PChar(s), length(s), rec, 0); SelectObject(hDC, OldFont); DeleteObject(MyFont); result := -rec.Bottom; end;
function TPrint.PrintTelephoneListContact(hDC: THandle; Contact: TContactRec; Left, Top, LineHeight: Integer): Integer; var rec: TRect; MyFont: HFont; OldFont: HFONT; s: string; begin SetMapMode(hDC, MM_LOMETRIC); rec.Left := LEFTBORDER * SCALE; rec.Right := (FHorzSize - RIGHTBORDER) * SCALE; rec.Top := Top; rec.Bottom := Top - Lineheight; with Contact do begin if (Name <> '') and (Vorname <> '') and (Firma <> '') then s := Firma + ' (' + Name + ', ' + Vorname + ')'; if (Name <> '') and (Vorname = '') and (Firma <> '') then s := Firma + ' (' + Name + ')'; if (Name = '') and (Vorname = '') and (Firma <> '') then s := Firma; if (Name = '') and (Vorname <> '') and (Firma <> '') then s := Firma; if (Name <> '') and (Vorname <> '') and (Firma = '') then s := Name + ', ' + Vorname; if (Name <> '') and (Vorname = '') and (Firma = '') then s := Name; if (Name = '') and (Vorname <> '') and (Firma = '') then s := Vorname; end; MyFont := MakeFont(FONTNAME, FONTSIZE, 400); OldFont := SelectObject(hDC, MyFont); DrawText(hDC, PChar(s), length(s), rec, 0); rec.Left := rec.Left + FColWidth; s := Contact.Telefon1; DrawText(hDC, PChar(s), length(s), rec, 0); rec.Left := rec.Left + FColWidth; s := Contact.Telefon2; DrawText(hDC, PChar(s), length(s), rec, 0); result := rec.Bottom; SelectObject(hDC, OldFont); DeleteObject(MyFont); end;
procedure TPrint.PrintCurrentRecord(PrintDialog: TPrintDialog; Contact: TContactRec); var MyFont: HFONT; OldFont: HFONT; tm: TTEXTMETRIC; Lineheight: Integer; resourcestring rsTitle = 'Datensatz von: '; begin if PrintDialog.Execute then begin with Printer do begin Title := APPNAME; BeginDoc; MyFont := MakeFont(FONTNAME, FONTSIZE, 400); OldFont := SelectObject(Canvas.Handle, MyFont); GetTextMetrics(Canvas.Handle, tm); SelectObject(Canvas.Handle, OldFont); DeleteObject(MyFont); LineHeight := (tm.tmHeight + tm.tmExternalLeading); FHorzSize := GetDeviceCaps(Canvas.Handle, HORZSIZE); FVerSize := GetDeviceCaps(Canvas.Handle, VERTSIZE); PrintHeader(Canvas.Handle, LineHeight); PrintContact(Canvas.Handle, LEFTBORDER * SCALE, LineHeight * 6, LineHeight, Contact); EndDoc; end; end; end;
procedure TPrint.PrintAllRecords(PrintDialog: TPrintDialog; Contacts: TContactList); var MyFont: HFONT; OldFont: HFONT; tm: TTEXTMETRIC; LineHeight: Integer; i: Integer; n: Integer; Top, Dummy: Integer; Max: Integer; Page: Integer; begin if PrintDialog.Execute then begin with Printer do begin Title := APPNAME; BeginDoc; MyFont := MakeFont(FONTNAME, FONTSIZE, 400); OldFont := SelectObject(Canvas.Handle, MyFont); GetTextMetrics(Canvas.Handle, tm); SelectObject(Canvas.Handle, OldFont); DeleteObject(MyFont); LineHeight := tm.tmHeight + tm.tmExternalLeading; FHorzSize := GetDeviceCaps(Canvas.Handle, HORZSIZE); FVerSize := GetDeviceCaps(Canvas.Handle, VERTSIZE); PrintHeader(Canvas.Handle, LineHeight); Page := 1; PrintFooter(Canvas.Handle, LineHeight, Page); Dummy := LineHeight * 8; Top := Dummy; i := 0; Max := length(Contacts); while i < Max do begin for n := 0 to FColCount - 1 do begin if i >= length(Contacts) then break; Dummy := PrintContact(Canvas.Handle, (n * FColWidth + 250), Top, LineHeight, Contacts[i]); inc(i); if i <> 0 then begin if (i mod FColCount = 0) then Top := Dummy + 2 * LineHeight; end; end; if (i mod FRecordsPerPage = 0) then begin NewPage; PrintHeader(Canvas.Handle, LineHeight); Inc(Page); PrintFooter(Canvas.Handle, LineHeight, Page); Top := LineHeight * 8; end; end; EndDoc; end; end; end;
procedure TPrint.PrintTelephoneList(PrintDialog: TPrintDialog; Contacts: TContactList); var OldFont: HFONT; MyFont: HFONT; tm: TTextMetric; LineHeight: Integer; Page: Integer; i: Integer; Top: Integer; begin if PrintDialog.Execute then begin with Printer do begin Title := APPNAME; BeginDoc; MyFont := MakeFont(FONTNAME, FONTSIZE, 400); OldFont := SelectObject(Canvas.Handle, MyFont); GetTextMetrics(Canvas.Handle, tm); SelectObject(Canvas.Handle, OldFont); DeleteObject(MyFont); LineHeight := tm.tmHeight + tm.tmExternalLeading; FHorzSize := GetDeviceCaps(Canvas.Handle, HORZSIZE); FVerSize := GetDeviceCaps(Canvas.Handle, VERTSIZE); PrintHeader(Canvas.Handle, LineHeight); Page := 1; PrintFooter(Canvas.Handle, LineHeight, Page); Top := -LineHeight * 6; for i := 0 to length(Contacts) - 1 do begin Top := PrintTelephoneListContact(Canvas.Handle, Contacts[i], LEFTBORDER, Top, LineHeight); if (i <> 0) and (i mod FLinesPerPage = 0) then begin NewPage; PrintHeader(Canvas.Handle, LineHeight); Inc(Page); PrintFooter(Canvas.Handle, LineHeight, Page); Top := LineHeight * 6; end; end; EndDoc; end; end; end;
end. |