~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to components/lazreport/source/lr_barc.pas

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
71
71
  TfrBarCodeView = class(TfrView)
72
72
  private
73
73
    BarC: TBarCode;
 
74
    FText: string;
74
75
    
75
76
    function GetBarType: TBarcodeType;
76
77
    function GetCheckSum: Boolean;
80
81
    procedure SetCheckSum(const AValue: Boolean);
81
82
    procedure SetShowText(const AValue: Boolean);
82
83
    procedure SetZoom(const AValue: Double);
 
84
    function CreateBarcode: TBitmap;
 
85
    function CreateLabelFont(aCanvas: TCanvas): TFont;
 
86
    procedure DrawLabel(aCanvas: TCanvas; R: TRect);
83
87
  public
84
88
    Param: TfrBarCode;
85
89
    
86
90
    constructor Create; override;
87
91
    destructor Destroy; override;
88
92
    procedure Assign(From: TfrView); override;
 
93
    function GenerateBitmap: TBitmap;
89
94
    procedure LoadFromStream(Stream: TStream); override;
90
95
    procedure SaveToStream(Stream: TStream); override;
91
96
    procedure Draw(aCanvas: TCanvas); override;
92
97
    procedure Print(Stream: TStream); override;
93
 
    procedure DefinePopupMenu(Popup: TPopupMenu); override;
94
 
    function  GenerateBitmap: TBitmap;
 
98
    procedure DefinePopupMenu({%H-}Popup: TPopupMenu); override;
95
99
    
96
100
    procedure LoadFromXML(XML: TLrXMLConfig; const Path: String); override;
97
101
    procedure SaveToXML(XML: TLrXMLConfig; const Path: String); override;
129
133
    RB2: TRadioButton;
130
134
    RB3: TRadioButton;
131
135
    RB4: TRadioButton;
132
 
    procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
 
136
    procedure FormClose(Sender: TObject; var {%H-}CloseAction: TCloseAction);
133
137
    procedure FormCreate(Sender: TObject);
134
138
    procedure VarBtnClick(Sender: TObject);
135
139
    procedure DBBtnClick(Sender: TObject);
145
149
 
146
150
{$R *.lfm}
147
151
 
148
 
uses LR_Var, LR_Flds, LR_Const, LR_Utils;
 
152
uses LR_Var, LR_Flds, LR_Const, LR_Utils, InterfaceBase;
149
153
 
150
154
 
151
155
var
182
186
      {$ENDIF}
183
187
      );
184
188
 
 
189
   defaultFontSize = 10;
185
190
 
186
191
{$HINTS OFF}
 
192
{$NOTES OFF}
187
193
function isNumeric(St: String): Boolean;
188
194
var
189
 
  R: Double;
 
195
  {%H-}R: Double;
190
196
  E: Integer;
191
197
begin
192
198
  Val(St, R, E);
193
199
  Result := (E = 0);
194
200
end;
 
201
{$NOTES ON}
195
202
{$HINTS ON}
196
203
 
197
204
function TfrBarCodeView.GetBarType: TBarcodeType;
238
245
  invalidate;
239
246
end;
240
247
 
241
 
constructor TfrBarCodeView.Create;
242
 
begin
243
 
  inherited Create;
244
 
 
245
 
  BarC := TBarCode.Create(nil);
246
 
  Param.cCheckSum := True;
247
 
  Param.cShowText := True;
248
 
  Param.cCadr     := False;
249
 
  Param.cBarType  := bcCode39;
250
 
  Param.cModul    := 2;
251
 
  Param.cRatio    := 1;
252
 
  Param.cAngle    := 0;
253
 
  Memo.Add(cbDefaultText);
254
 
  Typ := gtAddIn;
255
 
  BaseName := 'Bar';
256
 
end;
257
 
 
258
 
destructor TfrBarCodeView.Destroy;
259
 
begin
260
 
  BarC.Free;
261
 
  inherited Destroy;
262
 
end;
263
 
 
264
 
procedure TfrBarCodeView.Assign(From:TfrView);
265
 
begin
266
 
  inherited Assign(From);
267
 
  Param := (From as TfrBarCodeView).Param;
268
 
end;
269
 
 
270
 
procedure TfrBarCodeView.LoadFromStream(Stream:TStream);
271
 
begin
272
 
  inherited LoadFromStream(Stream);
273
 
  Stream.Read(Param, SizeOf(Param));
274
 
end;
275
 
 
276
 
procedure TfrBarCodeView.SaveToStream(Stream:TStream);
277
 
begin
278
 
  inherited SaveToStream(Stream);
279
 
  Stream.Write(Param, SizeOf(Param));
280
 
end;
281
 
 
282
 
function TfrBarCodeView.GenerateBitmap: TBitmap;
283
 
var
284
 
  Txt: String;
285
 
  hg: Integer;
286
 
  h, oldh: HFont;
287
 
  newdx,newdy : Integer;
288
 
begin
 
248
function TfrBarCodeView.CreateBarcode: TBitmap;
 
249
begin
 
250
 
 
251
  Result := nil;
 
252
  if Trim(Memo.Text) = '' then
 
253
    Exit;
 
254
 
 
255
  {Assign Barcode text}
289
256
  Memo1.Assign(Memo);
290
257
 
291
 
  if (Memo1.Count>0) and (Memo1[0][1]<>'[') then
292
 
    Txt := Memo1.Strings[0]
 
258
  if (Memo1.Text <> '') and (pos('[',Memo1.Strings[0])=0) and
 
259
    ((bcNames[Param.cBarType, 1] = 'A') or IsNumeric(Memo1.Strings[0]) or
 
260
      Barc.BarcodeTypeChecked(Param.cBarType) )  then
 
261
  begin
 
262
      BarC.Text := Memo1.Strings[0];
 
263
      BarC.Checksum := Param.cCheckSum;
 
264
  end
293
265
  else
294
 
    Txt := cbDefaultText;
295
 
 
 
266
  begin
 
267
    BarC.Text := cbDefaultText;
 
268
    BarC.Checksum := true;
 
269
  end;
 
270
 
 
271
  if Trim(BarC.Text)='0' then Exit;
 
272
 
 
273
  {Barcode Properties}
 
274
  BarC.Left:= 0;
 
275
  BarC.Top := 0;
296
276
  BarC.Typ := Param.cBarType;
297
277
  BarC.Angle := Param.cAngle;
298
 
  BarC.Ratio := 2; //Param.cRatio;
299
 
  BarC.Modul := 1; //Param.cModul;
300
 
  BarC.Checksum := Param.cCheckSum;
 
278
  BarC.Ratio := 2; // param.cRatio <>2 renders some codes unreadable
 
279
  BarC.Modul := 1; // param.cModul
301
280
  {$IFDEF BC_1_25}
302
281
  BarC.ShowTextPosition:=stpBottomCenter;
303
282
  BarC.ShowText := bcoNone;
311
290
  BarC.ShowText:=False;
312
291
  {$ENDIF}
313
292
 
314
 
  if bcNames[Param.cBarType, 1] = 'A' then
315
 
    BarC.Text := Txt
316
 
  else
317
 
    begin
318
 
      if IsNumeric(Txt) then
319
 
        BarC.Text := Txt
320
 
      else
321
 
        BarC.Text := cbDefaultText;
322
 
    end;
323
 
 
324
 
 
325
 
  newdx:=dx;
326
 
  newdy:=dy;
 
293
 
 
294
  {Barcode width is determined by type of barcode and text. Update
 
295
   object dimensions to suit barcode}
 
296
 
327
297
  if (Param.cAngle = 90) or (Param.cAngle = 270) then
328
 
  begin
329
 
    dy := BarC.Width;
330
 
    newdy:=Round(dy*Param.cRatio);
331
 
  end
 
298
    dy := BarC.Width
332
299
  else
333
 
  begin
334
300
    dx := BarC.Width;
335
 
    newdx:=Round(dx*Param.cRatio);
336
 
  end;
337
301
 
338
 
  if Trim(BarC.Text)='0' then Exit;
339
302
 
340
303
  if (Param.cAngle = 90) or (Param.cAngle = 270) then
341
 
    if Param.cShowText then
342
 
      hg := dx - 14
343
 
    else
344
 
      hg := dx
 
304
       BarC.Height := dx
345
305
  else
346
 
    if Param.cShowText then
347
 
      hg := dy - 14
348
 
    else
349
 
      hg := dy;
350
 
 
351
 
  BarC.Left:=0;
352
 
  BarC.Top :=0;
353
 
  BarC.Height:=hg;
 
306
       BarC.Height := dy;
354
307
 
355
308
  if (BarC.Typ=bcCodePostNet) and (Param.cAngle=0) then
356
309
  begin
357
 
    BarC.Top:=hg;
358
 
    BarC.Height:=-hg;
 
310
    BarC.Top:=BarC.Height;
 
311
    BarC.Height:=-BarC.Height;
359
312
  end;
360
313
 
361
 
  if Param.cAngle = 180 then
362
 
    BarC.Top:=dy-hg
363
 
  else
364
 
  if Param.cAngle = 270 then
365
 
    BarC.Left:=dx-hg;
 
314
  if  Param.cAngle = 90 then
 
315
    begin
 
316
      BarC.Top:= Round(Height);
 
317
      BarC.Left:=0;
 
318
    end
 
319
  else
 
320
  if  Param.cAngle = 180 then
 
321
    begin
 
322
      BarC.Top:= dy;
 
323
      BarC.Left:= dx;
 
324
    end
 
325
  else
 
326
  if  Param.cAngle = 270 then
 
327
    begin
 
328
      BarC.Top:= 0;
 
329
      BarC.Left:= dx;
 
330
    end;
366
331
 
367
332
  Result:=TBitMap.Create;
368
333
 
370
335
  Result.Height:=dy;
371
336
  Result.Canvas.Brush.Style:=bsSolid;
372
337
  Result.Canvas.Brush.Color:=clWhite;
373
 
  Result.Canvas.FillRect(Rect(0,0,Dx,Dy));
374
 
 
375
 
  BarC.DrawBarcode(Result.Canvas);
376
 
 
 
338
  Result.Canvas.FillRect(Rect(0,0,dx,dy));
 
339
 
 
340
  try
 
341
    BarC.DrawBarcode(Result.Canvas);
 
342
    if BarC.Checksum then
 
343
      FText := BarC.CodeText
 
344
    else
 
345
      FText := BarC.Text;
 
346
  except on E: Exception do
 
347
    FText := E.Message
 
348
  end;
 
349
 
 
350
 
 
351
end;
 
352
 
 
353
function TfrBarCodeView.CreateLabelFont(aCanvas: TCanvas) :TFont;
 
354
begin
 
355
  with aCanvas do
 
356
  begin
 
357
    Result := TFont.Create;
 
358
    Result.Assign(aCanvas.Font);
 
359
    Result.Color := clBlack;
 
360
    Result.Name := 'Arial';
 
361
    Result.Style := [];
 
362
    Result.Size := -defaultFontSize;
 
363
 
 
364
    if Param.cAngle = 90 then
 
365
      Result.Orientation := 900
 
366
    else
 
367
    if Param.cAngle = 180 then
 
368
      Result.Orientation := 1800
 
369
    else
 
370
    if Param.cAngle = 270 then
 
371
      Result.Orientation := 2700
 
372
    else
 
373
      Result.Orientation := 0;
 
374
  end;
 
375
 
 
376
end;
 
377
 
 
378
 
 
379
procedure TfrBarCodeView.DrawLabel(aCanvas: TCanvas; R: TRect);
 
380
var fs: integer;
 
381
begin
377
382
  if Param.cShowText then
378
383
  begin
379
 
    with Result.Canvas do
 
384
    with aCanvas do
380
385
    begin
381
 
      Font.Color := clBlack;
382
 
      Font.Name := 'Courier New';
383
 
      Font.Height := -12;
384
 
      Font.Style := [];
 
386
      fs := Font.Height;
385
387
 
386
388
      if Param.cAngle = 0 then
387
389
      begin
388
390
        Brush.Color:=clWhite;
389
391
        Brush.Style:=bsSolid;
390
 
        FillRect(Rect(0,dy-12,dx,dy));
391
 
        TextOut((dx - TextWidth(Txt)) div 2, dy - 12, Txt);
 
392
        FillRect(Rect(R.Left,R.Top + dy-fs ,R.Right, R.Bottom));
 
393
        TextOut(R.Left + (dx - TextWidth(FText)) div 2, R.Top + dy - fs, FText);
392
394
      end
393
395
      else
394
396
        if Param.cAngle = 90 then
395
397
        begin
396
398
          Brush.Color:=clWhite;
397
399
          Brush.Style:=bsSolid;
398
 
          FillRect(Rect(dx - 12,0,dx,dy));
 
400
          FillRect(Rect(R.Left + dx - fs,R.Top,R.Right, R.Bottom));
 
401
          Font.Orientation := 900;
399
402
 
400
 
          TextOut(dx - 12, dy - (dy - TextWidth(Txt)) div 2, Txt);
 
403
          if (WidgetSet.LCLPlatform = lpGtk2) and IsPrinting then
 
404
            {GTK2 vertical printing correction}
 
405
            TextOut(R.Right ,R.Bottom - fs - (dy - TextWidth(FText)) div 2, FText)
 
406
          else
 
407
            TextOut(R.Right - fs,R.Bottom - (dy - TextWidth(FText)) div 2, FText)
401
408
        end
402
409
        else
403
410
          if Param.cAngle = 180 then
404
411
          begin
405
412
            Brush.Color:=clWhite;
406
413
            Brush.Style:=bsSolid;
407
 
            FillRect(Rect(0,0,dx,12));
408
 
 
409
 
            TextOut((dx - TextWidth(Txt)) div 2, 1, Txt);
 
414
            FillRect(Rect(R.Left,R.Top,R.Right,R.Top + fs));
 
415
            Font.Orientation := 1800;
 
416
            TextOut(R.left + (dx + TextWidth(FText)) div 2,  R.Top + fs, FText);
410
417
          end
411
418
          else
412
419
          begin
413
420
            Brush.Color:=clWhite;
414
421
            Brush.Style:=bsSolid;
415
 
            FillRect(Rect(0,0,12,dy));
416
 
 
417
 
            //here text it's write in barcode :o( TextOut(12, (dy - TextWidth(Txt)) div 2, Txt);
 
422
            Font.Orientation := 2700;
 
423
            FillRect(Rect(R.Left,R.Top,R.Left + fs,R.Bottom));
 
424
            if (WidgetSet.LCLPlatform = lpGtk2) and IsPrinting then
 
425
            {GTK2 vertical printing correction}
 
426
              TextOut(R.Left, R.Top + fs + (dy -TextWidth(FText)) div 2, FText)
 
427
            else
 
428
              TextOut(R.Left + fs, R.Top + (dy -TextWidth(FText)) div 2, FText)
418
429
          end;
419
430
    end;
420
431
  end;
421
432
 
422
 
  dx:=newdx;
423
 
  dy:=newdy;
 
433
end;
 
434
 
 
435
constructor TfrBarCodeView.Create;
 
436
begin
 
437
  inherited Create;
 
438
 
 
439
  BarC := TBarCode.Create(nil);
 
440
  Param.cCheckSum := True;
 
441
  Param.cShowText := True;
 
442
  Param.cCadr     := False;
 
443
  Param.cBarType  := bcCode39;
 
444
  Param.cModul    := 2;
 
445
  Param.cRatio    := 1;
 
446
  Param.cAngle    := 0;
 
447
  Memo.Add(cbDefaultText);
 
448
  Typ := gtAddIn;
 
449
  BaseName := 'Bar';
 
450
end;
 
451
 
 
452
destructor TfrBarCodeView.Destroy;
 
453
begin
 
454
  BarC.Free;
 
455
  inherited Destroy;
 
456
end;
 
457
 
 
458
procedure TfrBarCodeView.Assign(From:TfrView);
 
459
begin
 
460
  inherited Assign(From);
 
461
  Param := (From as TfrBarCodeView).Param;
 
462
end;
 
463
 
 
464
function TfrBarCodeView.GenerateBitmap: TBitmap;
 
465
var R: TRect;
 
466
begin
 
467
  Result := CreateBarcode;
 
468
  R := Rect(0,0, Result.Width,Result.Height);
 
469
  DrawLabel(Result.Canvas,r)
 
470
end;
 
471
 
 
472
procedure TfrBarCodeView.LoadFromStream(Stream:TStream);
 
473
begin
 
474
  inherited LoadFromStream(Stream);
 
475
  Stream.Read(Param, SizeOf(Param));
 
476
end;
 
477
 
 
478
procedure TfrBarCodeView.SaveToStream(Stream:TStream);
 
479
begin
 
480
  inherited SaveToStream(Stream);
 
481
  Stream.Write(Param, SizeOf(Param));
424
482
end;
425
483
 
426
484
procedure TfrBarCodeView.Draw(aCanvas:TCanvas);
427
485
var
428
486
  Bmp : TBitMap;
 
487
  R: TRect;
 
488
  fh: integer;
 
489
  barcodeFont: TFont;
 
490
  oldFont: TFont;
429
491
begin
430
492
  BeginDraw(aCanvas);
431
493
 
432
 
  Bmp := GenerateBitmap;
 
494
  Bmp := CreateBarcode;
 
495
  if Bmp <> nil then
433
496
  try
 
497
    // dx/dy is calculated in CreateBarCode using as base
 
498
    // barcdode type, angle, zoom and data
 
499
    if (Param.cAngle = 90) or (Param.cAngle = 270) then
 
500
      dy := round(dy * param.cRatio)
 
501
    else
 
502
      dx := round(dx * Param.cRatio);
434
503
    CalcGaps;
435
504
    ShowBackground;
436
 
    aCanvas.StretchDraw(DRect,Bmp);
 
505
    if Param.cShowText then
 
506
    begin
 
507
      barcodeFont := CreateLabelFont(aCanvas);
 
508
      try
 
509
        oldFont := aCanvas.Font;
 
510
        aCanvas.Font := barcodeFont;
 
511
        if not IsPrinting then
 
512
        begin
 
513
          if (Param.cAngle = 90) or (Param.cAngle = 270) then
 
514
            ACanvas.Font.Height := -Round(ACanvas.Font.Size * ACanvas.Font.PixelsPerInch / 72 * ScaleX)
 
515
          else
 
516
            ACanvas.Font.Height := -Round(ACanvas.Font.Size * ACanvas.Font.PixelsPerInch / 72 * ScaleY);
 
517
          fh := Round(aCanvas.Font.Height);
 
518
        end
 
519
        else
 
520
          fh := aCanvas.Font.Height;
 
521
 
 
522
        if (Param.cAngle = 90)  then
 
523
          R := Rect(DRect.Left,DRect.Top,
 
524
                    DRect.Right - fh,
 
525
                    DRect.Bottom)
 
526
        else
 
527
        if (Param.cAngle = 180)  then
 
528
          R := Rect(DRect.Left,DRect.Top + fh,
 
529
                    DRect.Right ,
 
530
                    DRect.Bottom)
 
531
        else
 
532
        if (Param.cAngle = 270)  then
 
533
          R := Rect(DRect.Left + fh,
 
534
                  DRect.Top,
 
535
                  DRect.Right,
 
536
                  DRect.Bottom)
 
537
        else
 
538
          R := Rect(DRect.Left,DRect.Top,
 
539
                  DRect.Right ,
 
540
                  DRect.Bottom -  fh);
 
541
      aCanvas.StretchDraw(R,Bmp);
 
542
      DrawLabel(aCanvas, DRect);
 
543
      finally
 
544
        aCanvas.Font := oldFont;
 
545
        barcodeFont.Free
 
546
      end;
 
547
    end
 
548
    else
 
549
      aCanvas.StretchDraw(DRect,Bmp);
 
550
 
 
551
    ShowFrame;
 
552
 
437
553
  finally
438
554
    Bmp.Free;
 
555
    RestoreCoord;
439
556
  end;
440
 
  
441
 
  ShowFrame;
442
 
  RestoreCoord;
443
557
end;
444
558
 
445
559
procedure TfrBarCodeView.Print(Stream: TStream);
451
565
  if not Visible then Exit;
452
566
 
453
567
  if Memo1.Count > 0 then
454
 
    if (Length(Memo1[0]) > 0) and (Memo1[0][1] = '[') then
 
568
    if (Length(Memo1[0]) > 0) and (Pos('[',Memo1[0])<>0) then
455
569
      Memo1[0] := frParser.Calc(Memo1[0]);
456
570
  Stream.Write(Typ, 1);
457
571
  frWriteString(Stream, ClassName);
483
597
  XML.SetValue(Path+'BarCode/Zoom', GetSaveProperty('Zoom'));
484
598
end;
485
599
 
486
 
 
487
600
//--------------------------------------------------------------------------
488
601
procedure TfrBarCodeForm.FormCreate(Sender: TObject);
489
602
var
520
633
 
521
634
procedure TfrBarCodeForm.edZoomKeyPress(Sender: TObject; var Key: char);
522
635
begin
523
 
  If (Key>#31) and not (Key in ['0'..'9']) then
 
636
  If (Key>#31) and not (Key in ['0'..'9','.']) then {AJW}
524
637
    Key:=#0;
525
638
end;
526
639
 
541
654
      RB3.Checked := True
542
655
    else
543
656
      RB4.Checked := True;
544
 
    edZoom.Text:=SysUtils.Format('%.0f',[Param.cRatio]);
 
657
    edZoom.Text:=SysUtils.Format('%.1f',[Param.cRatio]);
545
658
 
546
659
    if ShowModal = mrOk then
547
660
    begin
593
706
  bc: TBarCode;
594
707
  Bmp: TBitmap;
595
708
begin
 
709
  Bmp := nil;
596
710
  bc := TBarCode.Create(nil);
597
 
  bc.Text := M1.Text;
598
 
  bc.CheckSum  := ckCheckSum.Checked;
599
 
  bc.Typ := TBarcodeType(cbType.ItemIndex);
600
 
  Bmp := TBitmap.Create;
601
 
  Bmp.Width := 16; Bmp.Height := 16;
602
711
  try
603
 
   Bmp.Canvas.Brush.Style:=bsSolid;
604
 
   Bmp.Canvas.Brush.Color:=clWhite;
605
 
   Bmp.Canvas.FillRect(Rect(0,0,Bmp.Width,Bmp.Height));
606
 
 
607
 
    bc.DrawBarcode(Bmp.Canvas);
608
 
  except
609
 
    MessageDlg(sBarcodeError,mtError,[mbOk],0);
610
 
    ModalResult := 0;
611
 
  end;
612
 
  Bmp.Free;
613
 
end;
614
 
 
 
712
    if Pos('[',M1.Text) <> 0 then
 
713
    begin
 
714
      bc.Text := cbDefaultText;
 
715
      bc.checksum := true
 
716
    end
 
717
    else
 
718
    begin
 
719
      bc.Text := M1.Text;
 
720
      bc.CheckSum  := ckCheckSum.Checked;
 
721
    end;
 
722
    bc.Ratio := StrToFloatDef(edZoom.Text,1);
 
723
    bc.Typ := TBarcodeType(cbType.ItemIndex);
 
724
    Bmp := TBitmap.Create;
 
725
    Bmp.Width := 16; Bmp.Height := 16;
 
726
    try
 
727
     Bmp.Canvas.Brush.Style:=bsSolid;
 
728
     Bmp.Canvas.Brush.Color:=clWhite;
 
729
     Bmp.Canvas.FillRect(Rect(0,0,Bmp.Width,Bmp.Height));
 
730
 
 
731
      bc.DrawBarcode(Bmp.Canvas);
 
732
    except
 
733
      MessageDlg(sBarcodeError,mtError,[mbOk],0);
 
734
      ModalResult := 0;
 
735
    end;
 
736
  finally
 
737
    Bmp.Free;
 
738
    bc.Free;
 
739
  end;
 
740
end;
 
741
 
 
742
procedure InitializeBarcAddin;
 
743
begin
 
744
  if not assigned(frBarCodeForm) {and not (csDesigning in ComponentState)} then
 
745
  begin
 
746
    frBarCodeForm := TfrBarCodeForm.Create(nil);
 
747
    frSetAddinEditor(TfrBarcodeView, frBarcodeForm);
 
748
    frSetAddinIcon(TfrBarcodeView, frBarCodeForm.Image1.Picture.Bitmap);
 
749
    frSetAddinHint(TfrBarcodeView, sInsBarcode);
 
750
  end;
 
751
end;
615
752
 
616
753
{ TfrBarCodeObject }
617
754
 
618
755
constructor TfrBarCodeObject.Create(aOwner: TComponent);
619
756
begin
620
757
  inherited Create(aOwner);
621
 
  
622
 
  if not assigned(frBarCodeForm) {and not (csDesigning in ComponentState)} then
623
 
  begin
624
 
    frBarCodeForm := TfrBarCodeForm.Create(nil);
625
 
    frRegisterObject(TfrBarCodeView, frBarCodeForm.Image1.Picture.Bitmap,
626
 
                           sInsBarcode, frBarCodeForm);
627
 
  end;
 
758
  InitializeBarcAddin;
628
759
end;
629
760
 
630
761
initialization
 
762
  frBarcodeForm := nil;
 
763
  frRegisterObject(TfrBarCodeView, nil, '', nil, @InitializeBarcAddin);
631
764
 
632
 
  frBarCodeForm:=nil;
633
765
finalization
634
766
  if Assigned(frBarCodeForm) then
635
767
    frBarCodeForm.Free;