Solved

Convert Panel To Bitmap

Posted on 2002-05-14
25
3,083 Views
Last Modified: 2013-12-02
Hey,

Can some one help me, I want to convert ALL the Controls in a Panel to a image Bitmap/Graphics doesn't matter,

As long as the picture will look like the panel1.
0
Comment
Question by:S_Warrior
  • 13
  • 10
  • +1
25 Comments
 
LVL 1

Expert Comment

by:sundayboys
ID: 7008074
this is simple example:
procedure TForm1.Button1Click(Sender: TObject);
var mycanvas : TCanvas;
    DC : HDC;
begin
     DC := GetDC(Panel1.Handle);
     mycanvas := Tcanvas.create;
     myCanvas.Handle := DC;
     image1.Canvas.CopyRect(Rect(0,0,Panel1.Width,panel1.Height),myCanvas,Rect(0,0,Panel1.Width,panel1.Height));
     mycanvas.Free;
     ReleaseDC(Panel1.Handle,DC);
end;

0
 
LVL 8

Accepted Solution

by:
Cesario earned 200 total points
ID: 7008094
Hello S Warrior

try this code :

Function PanelToBmp ( Panel:TPanel):TBitmap;
VAR
  bmp : tBitmap;
  DC  : HDC;
Begin
  bmp := tBitmap.Create;
  bmp.width := Panel.Width;
  bmp.Height := Panel.Height;
  DC := GetDc ( Panel.Handle );
  Bitblt(bmp.canvas.handle,0,0,Panel.Width,Panel.Height,Dc,0,0,srccopy);
  Releasedc (Panel.handle,dc);
  result := bmp;
End;

procedure TForm1.Button1Click(Sender: TObject);
VAR
  bmp : TBitmap;
begin
  bmp := PanelToBmp ( Panel1);
  canvas.draw ( 0,0,bmp);
  bmp.free;
end;
0
 
LVL 8

Expert Comment

by:Cesario
ID: 7008201
With this exmaple you can get all the controls as Bitmap:

procedure TForm1.Button2Click(Sender: TObject);
VAR
  bmp : tBitmap;
  cnt : Integer;
  Dc  : HDC;
  R   : TRect;
begin
  DC := GetDC ( Panel1.handle);
  For Cnt := 0 To Panel1.Controlcount-1 do
  Begin
    R := Panel1.Controls[cnt].boundsRect;
    bmp := tBitmap.create;
    bmp.width := R.Right-R.Left;
    bmp.Height := R.Bottom - R.Top;
    Bitblt(bmp.canvas.handle,0,0,bmp.Width,bmp.height,dc,r.left,r.top,srccopy);
    bmp.saveToFile ( 'C:\Control'+IntTostr(cnt)+'.bmp');
    bmp.free;
  End;
  releasedc(panel1.handle,dc);
end;


Best Regards

Cesario
0
 

Author Comment

by:S_Warrior
ID: 7008323
the answer's working great with normal Delphi Panels,

But I am using this panel called TMyRTDesignerPanel, maby you know it.

and some why this panel dont want to copy it self to the image I just can a blank panel.
0
 

Author Comment

by:S_Warrior
ID: 7008325
unit MyDBGrid;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Grids, DBGrids, StdCtrls, DB, dbctrls, CRTFD, ToolEdit, RxDBCtrl, XStringgrid;

type
  TMyDBGrid = class(TDBGrid)
  private
    { Private declarations }
  protected
    { Protected declarations }
    procedure WmSize(var Message: TMessage); message wm_Size;
    procedure ColWidthsChanged; override;
    procedure DrawCell(ACol, ARow: Longint; ARect: TRect;
                                            AState: TGridDrawState); override;
  public
    { Public declarations }
  published
    { Published declarations }
  end;

  TMyXStringGrid = class(TXStringGrid)
  private
    { Private declarations }
  protected
    { Protected declarations }
    procedure WmSize(var Message: TMessage); message wm_Size;
    procedure ColWidthsChanged; override;
//    procedure DrawCell(ACol, ARow: Longint; ARect: TRect;
//                                            AState: TGridDrawState); override;
  public
    { Public declarations }
  published
    { Published declarations }
  end;

  TClientAlignedEdit = class(TDBEdit)
  public
    constructor Create(AOwner: TComponent); override;
  end;

  TClientAlignedComboBox = class(TDBLookupComboBox)
  public
    constructor Create(AOwner: TComponent); override;
  end;

  TMyComboBox = class(TComboBox)
  public
    constructor Create(AOwner: TComponent); override;
  end;

  TMyRTDesignerPanel = class(TRTDesignerPanel)
  public
    procedure SetScaleSize(sngWidthCm, sngHeightCm: Single; gintScaleRatio: Integer);
    procedure SelectNext(CurControl: TWinControl;
      GoForward, CheckTabStop: Boolean);
  end;

  TMyFilenameEdit = class(TFilenameEdit)
  public
    constructor Create(AOwner: TComponent); override;
  end;

  TMyDirectoryEdit = class(TDirectoryEdit)
  public
    constructor Create(AOwner: TComponent); override;
  end;

procedure Register;

var
  DrawBitmap: TBitmap;

implementation
 
uses Math;//, DBConsts, Dialogs;

procedure TMyDBGrid.WmSize(var Message: TMessage);
begin
  inherited;
  Columns[2].Width := ClientWidth - Columns[0].Width - 1;
end;

procedure TMyDBGrid.ColWidthsChanged;
begin
  inherited ColWidthsChanged;
  Columns[2].Width := ClientWidth - Columns[0].Width - 1;
end;

procedure WriteText(ACanvas: TCanvas; ARect: TRect; DX, DY: Integer;
  const Text: string; Alignment: TAlignment; ARightToLeft: Boolean);
const
  AlignFlags : array [TAlignment] of Integer =
    ( DT_LEFT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
      DT_RIGHT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
      DT_CENTER or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX );
  RTL: array [Boolean] of Integer = (0, DT_RTLREADING);
var
  B, R: TRect;
  Hold, Left: Integer;
  I: TColorRef;
begin
  I := ColorToRGB(ACanvas.Brush.Color);
  if GetNearestColor(ACanvas.Handle, I) = I then
  begin                       { Use ExtTextOut for solid colors }
    { In BiDi, because we changed the window origin, the text that does not
      change alignment, actually gets its alignment changed. }
    if (ACanvas.CanvasOrientation = coRightToLeft) and (not ARightToLeft) then
      ChangeBiDiModeAlignment(Alignment);
    case Alignment of
      taLeftJustify:
        Left := ARect.Left + DX;
      taRightJustify:
        Left := ARect.Right - ACanvas.TextWidth(Text) - 3;
    else { taCenter }
      Left := ARect.Left + (ARect.Right - ARect.Left) shr 1
        - (ACanvas.TextWidth(Text) shr 1);
    end;
    ACanvas.TextRect(ARect, Left, ARect.Top + DY, Text);
  end
  else begin                  { Use FillRect and Drawtext for dithered colors }
    DrawBitmap.Canvas.Lock;
    try
      with DrawBitmap, ARect do { Use offscreen bitmap to eliminate flicker and }
      begin                     { brush origin tics in painting / scrolling.    }
        Width := Max(Width, Right - Left);
        Height := Max(Height, Bottom - Top);
        R := Rect(DX, DY, Right - Left - 1, Bottom - Top - 1);
        B := Rect(0, 0, Right - Left, Bottom - Top);
      end;
      with DrawBitmap.Canvas do
      begin
        Font := ACanvas.Font;
        Font.Color := ACanvas.Font.Color;
        Brush := ACanvas.Brush;
        Brush.Style := bsSolid;
        FillRect(B);
        SetBkMode(Handle, TRANSPARENT);
        if (ACanvas.CanvasOrientation = coRightToLeft) then
          ChangeBiDiModeAlignment(Alignment);
        DrawText(Handle, PChar(Text), Length(Text), R,
          AlignFlags[Alignment] or RTL[ARightToLeft]);
      end;
      if (ACanvas.CanvasOrientation = coRightToLeft) then
      begin
        Hold := ARect.Left;
        ARect.Left := ARect.Right;
        ARect.Right := Hold;
      end;
      ACanvas.CopyRect(ARect, DrawBitmap.Canvas, B);
    finally
      DrawBitmap.Canvas.Unlock;
    end;
  end;
end;

procedure TMyDBGrid.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
var
  FrameOffs: Byte;

  procedure DrawTitleCell(ACol, ARow: Integer; Column: TColumn; var AState: TGridDrawState);
  const
    ScrollArrows: array [Boolean, Boolean] of Integer =
      ((DFCS_SCROLLRIGHT, DFCS_SCROLLLEFT), (DFCS_SCROLLLEFT, DFCS_SCROLLRIGHT));
  var
    MasterCol: TColumn;
    TitleRect, TextRect, ButtonRect: TRect;
    I: Integer;
    InBiDiMode: Boolean;
  begin
    TitleRect := CalcTitleRect(Column, ARow, MasterCol);

    if MasterCol = nil then
    begin
      Canvas.FillRect(ARect);
      Exit;
    end;

    Canvas.Font := MasterCol.Title.Font;
    Canvas.Brush.Color := MasterCol.Title.Color;
    if [dgRowLines, dgColLines] * Options = [dgRowLines, dgColLines] then
      InflateRect(TitleRect, -1, -1);
    TextRect := TitleRect;
    I := GetSystemMetrics(SM_CXHSCROLL);
    if ((TextRect.Right - TextRect.Left) > I) and MasterCol.Expandable then
    begin
      Dec(TextRect.Right, I);
      ButtonRect := TitleRect;
      ButtonRect.Left := TextRect.Right;
      I := SaveDC(Canvas.Handle);
      try
        Canvas.FillRect(ButtonRect);
        InflateRect(ButtonRect, -1, -1);
        IntersectClipRect(Canvas.Handle, ButtonRect.Left,
          ButtonRect.Top, ButtonRect.Right, ButtonRect.Bottom);
        InflateRect(ButtonRect, 1, 1);
        { DrawFrameControl doesn't draw properly when orienatation has changed.
          It draws as ExtTextOut does. }
        InBiDiMode := Canvas.CanvasOrientation = coRightToLeft;
        if InBiDiMode then { stretch the arrows box }
          Inc(ButtonRect.Right, GetSystemMetrics(SM_CXHSCROLL) + 4);
        DrawFrameControl(Canvas.Handle, ButtonRect, DFC_SCROLL,
          ScrollArrows[InBiDiMode, MasterCol.Expanded] or DFCS_FLAT);
      finally
        RestoreDC(Canvas.Handle, I);
      end;
    end;
    with MasterCol.Title do
      WriteText(Canvas, TextRect, FrameOffs, FrameOffs, Caption, Alignment,
        IsRightToLeft);
    if [dgRowLines, dgColLines] * Options = [dgRowLines, dgColLines] then
    begin
      InflateRect(TitleRect, 1, 1);
      DrawEdge(Canvas.Handle, TitleRect, BDR_RAISEDINNER, BF_BOTTOMRIGHT);
      DrawEdge(Canvas.Handle, TitleRect, BDR_RAISEDINNER, BF_TOPLEFT);
    end;
    AState := AState - [gdFixed];  // prevent box drawing later
  end;

var
  OldActive: Integer;
  Highlight: Boolean;
  Value: string;
  DrawColumn: TColumn;
begin
  if csLoading in ComponentState then
  begin
    Canvas.Brush.Color := Color;
    Canvas.FillRect(ARect);
    Exit;
  end;

  Dec(ARow, 1);

  if (gdFixed in AState) and ([dgRowLines, dgColLines] * Options =
    [dgRowLines, dgColLines]) then
  begin
    InflateRect(ARect, -1, -1);
    FrameOffs := 1;
  end
  else
    FrameOffs := 2;

  if (gdFixed in AState) and (ACol < 0) then
  begin
    Canvas.Brush.Color := FixedColor;
    Canvas.FillRect(ARect);
    if Assigned(DataLink) and DataLink.Active  then
    begin
      if ARow >= 0 then
      begin
        OldActive := DataLink.ActiveRecord;
        try
          Datalink.ActiveRecord := ARow;
        finally
          Datalink.ActiveRecord := OldActive;
        end;
      end;
    end;
  end
  else with Canvas do
  begin
    DrawColumn := Columns[ACol];
    if not DrawColumn.Showing then Exit;
    if not (gdFixed in AState) then
    begin
      Font := DrawColumn.Font;
      Brush.Color := DrawColumn.Color;
    end;
    if ARow < 0 then
      DrawTitleCell(ACol, ARow + 1{FTitleOffset}, DrawColumn, AState)
    else if (DataLink = nil) or not DataLink.Active then
      FillRect(ARect)
    else
    begin
      Value := '';
      OldActive := DataLink.ActiveRecord;
      try
        DataLink.ActiveRecord := ARow;
        if Assigned(DrawColumn.Field) then
          Value := DrawColumn.Field.Text;
        Highlight := HighlightCell(ACol, ARow, Value, AState);
        if Highlight then
        begin
          Brush.Color := clHighlight;
          Font.Color := clHighlightText;
        end;
        if not Enabled then
          Font.Color := clGrayText;
        if DefaultDrawing then
          WriteText(Canvas, ARect, 2, 2, Value, DrawColumn.Alignment,
            UseRightToLeftAlignmentForField(DrawColumn.Field, DrawColumn.Alignment));
        if Columns.State = csDefault then
          DrawDataCell(ARect, DrawColumn.Field, AState);
        DrawColumnCell(ARect, ACol, DrawColumn, AState);
      finally
        DataLink.ActiveRecord := OldActive;
      end;
      if DefaultDrawing and (gdSelected in AState)
        and ((dgAlwaysShowSelection in Options) or Focused)
        and not (csDesigning in ComponentState)
        and not (dgRowSelect in Options)
        and (UpdateLock = 0)
        and (ValidParentForm(Self).ActiveControl = Self) then
        Windows.DrawFocusRect(Handle, ARect);
    end;
  end;
  if (gdFixed in AState) and ([dgRowLines, dgColLines] * Options =
    [dgRowLines, dgColLines]) then
  begin
    InflateRect(ARect, 1, 1);
    DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_BOTTOMRIGHT);
    DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_TOPLEFT);
  end;
end;

procedure TMyXStringGrid.WmSize(var Message: TMessage);
begin
  inherited;
  Columns[1].Width := ClientWidth - Columns[0].Width - 1;
end;

procedure TMyXStringGrid.ColWidthsChanged;
begin
  inherited ColWidthsChanged;
  if Columns.Count > 1 then
  begin
    Columns[1].Width := ClientWidth - Columns[0].Width - 1;
    if CellEditor <> nil then
      TMetaCellEditor(CellEditor).Editor.Width := Columns[1].Width;
  end;
end;

constructor TClientAlignedEdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);  { Call inherited constructor ! }

  Align := alClient;
end;

constructor TClientAlignedComboBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);  { Call inherited constructor ! }

  Align := alClient;
end;

constructor TMyComboBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);  { Call inherited constructor ! }

  Align := alClient;
end;

procedure TMyRTDesignerPanel.SetScaleSize(sngWidthCm, sngHeightCm: Single;
                         gintScaleRatio: Integer);
begin
  Width := Round(sngWidthCm * gintScaleRatio / 100 * Screen.PixelsPerInch/2.54);
  Height := Round(sngHeightCm * gintScaleRatio / 100 * Screen.PixelsPerInch/2.54);
end;

procedure TMyRTDesignerPanel.SelectNext(CurControl: TWinControl;
  GoForward, CheckTabStop: Boolean);
begin
  CurControl := FindNextControl(CurControl, GoForward,
    CheckTabStop, not CheckTabStop);
  if CurControl <> nil then //CurControl.SetFocus;
    if CurControl is TRTDesigner then
      SelectNext(CurControl, True, False)
    else
      RTDesigner.SelectControl(CurControl, True);
end;

constructor TMyFilenameEdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);  { Call inherited constructor ! }

  Align := alTop;
end;

constructor TMyDirectoryEdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);  { Call inherited constructor ! }

  Align := alTop;
end;

procedure Register;
begin
  RegisterComponents('Samples', [TMyDBGrid]);
  RegisterComponents('Samples', [TClientAlignedEdit]);
  RegisterComponents('Samples', [TClientAlignedComboBox]);
  RegisterComponents('Samples', [TMyComboBox]);
  RegisterComponents('Samples', [TMyRTDesignerPanel]);
  RegisterComponents('Samples', [TMyFilenameEdit]);
  RegisterComponents('Samples', [TMyDirectoryEdit]);
  RegisterComponents('Samples', [TMyXStringGrid]);
end;

end.
0
 
LVL 1

Expert Comment

by:pede
ID: 7008494
Hi, I was playing around with the code from this thread, and tried to write a form to a bitmap but it didnt work if the form was minimized. Any idea why the following doesnt work?

Function FormToBmp(Form:TForm):TBitmap;
VAR
 bmp : tBitmap;
 DC  : HDC;
 i   : integer;
Begin
 bmp := tBitmap.Create;
 bmp.width := Form.Width;
 bmp.Height := Form.Height;
 DC := GetDc( Form.Handle );
// Bitblt(bmp.canvas.handle,0,0,Form.Width,Form.Height,Dc,0,0,srccopy);
 Form.PaintTo(bmp.Canvas, 0, 0);
 for i:=0 to Form.ControlCount-1 do
  TWinControl(Form.Controls[i]).PaintTo(bmp.Canvas, Form.Controls[i].Left, Form.Controls[i].Top);
 Releasedc(Form.handle,dc);
 result := bmp;
End;

procedure TForm1.Button1Click(Sender: TObject);
var
  B : TBitmap;
begin
  B := FormToBmp(Form2);
  B.SaveToFile('e:\temp\form.bmp');
  B.Free;
  Close;
end;

I dont get the form border because it's the client areas DC (even if the form is visible), but when its minimized I dont even get the controls on it either. PaintTo doesnt seem to work.

0
 
LVL 8

Expert Comment

by:Cesario
ID: 7008509
Dear S Warrior,

I dont know  TMyRTDesignerPanel. Where can I download this component ?

Cesario
0
 
LVL 8

Expert Comment

by:Cesario
ID: 7008519
Can you post me the source code of  TMyRTDesignerPanel to C_Lababidi@hotmail.com
0
 

Author Comment

by:S_Warrior
ID: 7010407
I am sorry guy's, I just tred to add the control's to a normal panel and it didnt work 2.

I will tell you exactly what I am doing.
I am tring to make a preview windows like you have in ImageDialog only I am loading Objects to a panel in the Dialog, and the I want it to convert to an image so I will have options like "Stretch"

at this point all I am geting is images from my Main Form.

maby there is a prob with dialogs?
0
 

Author Comment

by:S_Warrior
ID: 7010409
the code is working very good what I am calling the function from a normal panel, but whan it come's to the dialog its dont work.
0
 
LVL 8

Expert Comment

by:Cesario
ID: 7010441
Still now I have no Idea how to get a Bitmap form an invisible Window.

The Methode PaintTo send wm_paint but if the control is not visible the methode call the exit procedure :-(
The same Problem with Bitblt.

But I know its possible. There is a nice Component
"Billenium Effects" http://www.billeniumsoft.com/download.htm and the can capture the invisible form.

I hope this article can help you

Best Regards

Cesario


0
 
LVL 8

Expert Comment

by:Cesario
ID: 7010444
0
6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

 

Author Comment

by:S_Warrior
ID: 7010462
I just seen some thing very strange, whan I put showmessage() in the Function FormToBmp the **** is working.

Why is that??!?!?
0
 

Author Comment

by:S_Warrior
ID: 7010463
I just seen some thing very strange, whan I put showmessage() in the Function FormToBmp the **** is working.

Why is that??!?!?
0
 
LVL 8

Expert Comment

by:Cesario
ID: 7010487
Which Controls are on Form2?
0
 
LVL 8

Expert Comment

by:Cesario
ID: 7010507
Now you can try this code :

Function FormToBmp(Form:TForm):TBitmap;
VAR
bmp : tBitmap;
DC  : HDC;
i   : integer;
oldTop,OldLeft : Integer;
Begin
  oldleft := Form.left;
  oldTop  := Form.top;
  form.Left := screen.width+5;
  form.Top  := 5;
  form.show;
  bmp := form.GetFormImage;
  form.hide;
  form.Left := oldleft;
  form.top  := oldtop;
  result := bmp;
End;

procedure TForm1.Button1Click(Sender: TObject);
var
 B : TBitmap;
begin
 B := FormToBmp(Form2);
 B.SaveToFile('c:\form.bmp');
 B.Free;
 shellexecute(handle,'OPEN','c:\form.bmp','','',sw_shownormal);
end;

end.
0
 

Author Comment

by:S_Warrior
ID: 7010636
What will it give me to open a new form?

did u read all of my comments?
0
 
LVL 8

Expert Comment

by:Cesario
ID: 7010904
Can you post me your code ?
0
 

Author Comment

by:S_Warrior
ID: 7013148
unit PBPreview;

interface

uses
      Windows, Messages, SysUtils, Classes,GlobalUnit, Graphics,forms, Controls,CRTFD, FileDefinition, Dialogs,DemoWarning,
      ExtCtrls, StdCtrls, MyEdit, MyShape, MyImage,MyBarcode, MyMemo,LabelControl, Buttons, ComCtrls, MMSystem,MyDBGrid, CommDlg, ShellAPI, LabelForm;

type
      TPBOpenPreviewDialog = class;

      TPreviewNotify = procedure(Sender:TPBOpenPreviewDialog; Ext : string) of object;

      TPBOpenPreviewDialog = class(TOpenDialog)
      private
            { Private declarations }
            FPanel2 : TPanel;
            FMainPanelBox : TPanel;
                VScrolbar : TScrollBar;
                HScrolbar : TScrollBar;
                FPreviewPanel : TPanel;
                FPreviewImage : Timage;
                FNoPreviewTexts, FPreviewCaptions, FScaleHints, FWordWrapHints : TStringlist;
            FShowPreviewButtonHints, FTitles : TStringlist;
            FOnPreview : TPreviewNotify;
            FPreviewCustomExt, FPreviewDefaultExt : TStringlist;
            FVersion, FLocale : string;
            FWordWrapButton, FShowPreviewButton : TSpeedButton;
            FShow, FWordWrapAndScale : Boolean;
            function LocaleText(List : TStringlist) : string;
            function StoreNoPreview : Boolean;
            function StoreCaptions : Boolean;
            function StoreScaleHints : Boolean;
            function StoreWrapHints : Boolean;
            function StorePreviewHints : Boolean;
                Function PanelToBmp(Panel:TPanel):TBitmap;
                function LoadLabelPanel(const FileName: String;Panel : TPanel): TPanel;
            procedure FPreview;
            procedure SetPreviewCaptions(Value : TStringlist);
            procedure SetScaleHints(Value : TStringlist);
            procedure SetWordWrapHints(Value : TStringlist);
            procedure Dummy(Value: String);
            procedure SetCustomPreviewExt(Value : TStringlist);
            procedure ShowPreviewClick(Sender : TObject);
            procedure WordWrapClick(Sender : TObject);
            procedure SetShowPreviewButtonHints(Value : TStringlist);
            procedure SetNoPreviewTexts(Value : TStringlist);
            procedure SetTitles(Value : TStringlist);
            procedure SetShow(Value : Boolean);
            procedure SetWordWrapAndScale(Value : Boolean);
      protected
            { Protected declarations }
            procedure DoClose; override;
            procedure DoSelectionChange; override;
            procedure DoShow; override;
      public
            { Public declarations }
                 Tmp_Form : TForm;
            constructor Create(AOwner: TComponent); override;
//            pro
            destructor Destroy; override;
            function Execute: Boolean; override;
                property PreviewPanel : TPanel read FPreviewPanel Write FPreviewPanel;
                property PreviewImage : Timage read FPreviewImage Write FPreviewImage;
      published
{The localized hint-list for the ShowPreview-button.}
{See the 'International codes.txt'-file to find the codes.}
{At runtime the text that fits the Windows-language is used.}
{If the Windows-localeversion is not found in the list the 'Default'-value is used.}
            property ShowPreviewButtonHints : TStringlist read FShowPreviewButtonHints
                  write SetShowPreviewButtonHints stored StorePreviewHints;
{NoPreviewTexts is the localized list for the text displayed - centered - when there is
 nothing else to preview.}
{See the 'International codes.txt'-file to find the codes.}
{At runtime the text that fits the Windows-language is used.}
{If the Windows-localeversion is not found in the list the 'Default'-value is used.}
            property NoPreviewTexts : TStringlist read FNoPreviewTexts
                  write SetNoPreviewTexts stored StoreNoPreview;
{PreviewCaptions is the localized caption-list for the caption above the previewarea.}
{See the 'International codes.txt'-file to find the codes.}
{At runtime the text that fits the Windows-language is used.}
{If the Windows-localeversion is not found in the list the 'Default'-value is used.}
            property PreviewCaptions : TStringlist read FPreviewCaptions
                  write SetPreviewCaptions stored StoreCaptions;
{ScaleHints is the localized hint-list for the Scale-button.
The scale-button is visble when PreviewImage is visible.}
{See the 'International codes.txt'-file to find the codes.}
{At runtime the text that fits the Windows-language is used.}
{If the Windows-localeversion is not found in the list the 'Default'-value is used.}
            property ScaleHints : TStringlist read FScaleHints
                  write SetScaleHints stored StoreScaleHints;
{WordWrapHints is the localized hint-list for the WordWrap-button.
The WordWrap-button is visible when PreviewText is visible.}
{See the 'International codes.txt'-file to find the codes.}
{At runtime the text that fits the Windows-language is used.}
{If the Windows-localeversion is not found in the list the 'Default'-value is used.}
            property WordWrapHints : TStringlist read FWordWrapHints
                  write SetWordWrapHints stored StoreWrapHints;
{OnPreview event occurs when the dialog needs information on what to display in
 previewarea - in other words when a file is selected.}
{Here you write code that puts some text into 'PreviewText' or some graphic into
 'PreviewImage'.}
{First assign a procedure to this event.}
{Then you check the extension to see if it is the right kind of file.
 Then open and read some or all of the file into 'PreviewText' or
 'PreviewImage'. Close the file.}
{The Extension of the filetype, for which you write the previewcode, has to be
 included in 'CustomPreviewExtensions' - for filetypes not included in
 CustomPreviewExtensions the event is not triggered - a common mistake!!!}
{See the demo for an example - compare the preview with the textfiles 'File.xxx'
and 'File.yyy' to get the idea.}
            property OnPreview : TPreviewNotify read FOnPreview write FOnPreview;
{The FileExtensions for which you write preview-code in the 'OnPreview'-procedure.}
{The OnPreview-event is only triggered for these extensions.}
{The extensions should be in the form 'xxx' - lowercase (without '').}
{For Filetypes in this list YOU deside what to preview - even if the extension
is in DefaultPreviewExtensions, too. Then the default preview is skipped.}
{(Off course the filetypes have to be included in 'Filter'-Property to be
displayed in the dialog).}
            property CustomPreviewExtensions : TStringlist read FPreviewCustomExt write SetCustomPreviewExt;
{The Localization list for the Title property. Always leave the Title property
empty. Windows automatic assigns a localized value of 'Open' or 'Save as' to
Title when left empty.}
{If you have a special wish to the Title, put the localized texts into this
list and then the Title is also localized.}
{See the 'International codes.txt'-file to find the codes.}
{At runtime the text that fits the Windows-language is used.}
            property Titles : TStringlist read FTitles write SetTitles;
{Determines whether the ShowPreview-Button is down - True (Preview will be shown) or
up - False (No preview).}
{Users can change this by clicking the button at runtime.}
            property ShowPreview : Boolean read FShow write SetShow;
{Determines whether the Word-wrap and scale-button is down - True (words will be wrapped
and images scaled to fit) or up - False (Scroll-boxes will be shown if lines are too
long or images to large to fit).}
{Users can change this by clicking the button at runtime.}
            property WordWrapAndScale : Boolean read FWordWrapAndScale write SetWordWrapAndScale;
//ReadOnly property.
            property Version : string read FVersion write Dummy stored False;
      end;

{TPBSavePreviewDialog is the classname for PBSavePreviewDialog.}
      TPBSavePreviewDialog = class(TPBOpenPreviewDialog)
            function Execute: Boolean; override;
      end;

procedure Register;

implementation

{$R PBPreview.RES}


const
             NoPreviewDefault = '"Default=No preview","0009=No preview",' +
            '"0406=Ingen visning","0407=Keine Vorschau","0409=No preview",' +
            '"040C=Rien de montrer","0413=Geen voorbeeld"';
      CaptionsDefault = 'Default=Preview:,0009=Preview:,0406=Prxvevisning:,' +
            '0407=Vorschau:,0409=Preview:,040C=Ipreuve:,0413=Voorbeeld:';
          ScaleHintsDefault = '"Default=Scale to fit","0009=Scale to fit",' +
            '"0406=Komprimir stxrrelse","0407=Grv_e anpassen","0409=Scale to fit",' +
            '040C=Compression,0413=Opschalen';
      WrapHintsDefault = 'Default=Word-wrap,0009=Word-wrap,0406=Liniedeling,' +
            '0407=Zeilenumbruch,0409=Word-wrap,"040C=Division de lignes",' +
            '"0413=Regels afbreken"';
      PreviewHintsDefault = '"Default=Show Preview","0009=Show Preview",' +
            '"0406=Vis prxve",0407=Vorschau,"0409=Show Preview",' +
            '"040C=Montrer l''epreuve","0413=Toon Voorbeeld"';

var
      Rect1, Rect2 : TRect;
      Ext : string;


constructor TPBOpenPreviewDialog.Create(AOwner: TComponent);
begin
      inherited Create(AOwner);
       FPreviewCustomExt := TStringList.Create;
      FPreviewDefaultExt := TStringList.Create;
        Tmp_Form := TFormClass.Create(Self);
      FPreviewDefaultExt.CommaText := 'stk';
      FNoPreviewTexts := TStringList.Create;
      FNoPreviewTexts.CommaText := NoPreviewDefault;
      FPreviewCaptions := TStringList.Create;
      FPreviewCaptions.CommaText := CaptionsDefault;
      FScaleHints := TStringList.Create;
      FScaleHints.CommaText := ScaleHintsDefault;
      FWordWrapHints := TStringList.Create;
      FWordWrapHints.CommaText := WrapHintsDefault;
      FShowPreviewButtonHints := TStringList.Create;
      FShowPreviewButtonHints.CommaText := PreviewHintsDefault;
      FTitles := TStringList.Create;

      FTitles.CommaText := 'Default=';
      FVersion := '4.00.00.00';
      FMainPanelBox := TPanel.Create(Self);
      with FMainPanelBox do
      begin
            Name := 'PreviewBox';
            Ctl3D := True;
            BorderStyle := bsSingle;
      end;


      FPanel2 := TPanel.Create(Self);
      with FPanel2 do
      begin
            Name := 'CaptionPanel';
            Caption := LocaleText(FPreviewCaptions);
            Alignment := taCenter;
            Ctl3D := False;
            BevelOuter := bvNone;
            BevelInner := bvNone;
            BorderStyle := bsNone;
            BorderWidth := 0;
            FWordWrapButton := TSpeedButton.Create(Self);
            with FWordWrapButton do
            begin
                  Name := 'FWordWrapButton';
                  Parent := FPanel2;
                  Caption := '';
            end;
            FShowPreviewButton := TSpeedButton.Create(Self);
            with FShowPreviewButton do
            begin
                  Name := 'FShowPreviewButton';
                  Parent := FPanel2;
                  Caption := '';
            end;
      end;
      FShow := True;
      FWordWrapAndScale := True;
end;

destructor TPBOpenPreviewDialog.Destroy;
begin
      FTitles.Free;
        Tmp_Form.free;
      FNoPreviewTexts.Free;
      FPreviewCaptions.Free;
      FScaleHints.Free;
      FWordWrapHints.Free;
      FShowPreviewButtonHints.Free;
        FPreviewPanel.Free;
        FPreviewImage.Free;
      FPreviewDefaultExt.Free;
      FPreviewCustomExt.Free;
      FShowPreviewButton.Free;
      FWordWrapButton.Free;
      FPanel2.Free;
        VScrolbar.free;
        HScrolbar.free;
      FMainPanelBox.Free;
      inherited Destroy;
end;




procedure TPBOpenPreviewDialog.DoSelectionChange;
begin
      inherited DoSelectionChange;
      FPreview;
end;

procedure TPBOpenPreviewDialog.DoShow;
var
      StaticRect : TRect;
begin
      inherited DoShow;

      FLocale := IntToHex(GetSystemDefaultLangID, 4);
      GetClientRect(Handle, Rect1);
      StaticRect := GetStaticRect;
      with Rect1 do
      begin
            Left := StaticRect.Right + 8;
            Top := Top + 33;
            Right := Right - 8;
            Bottom := Bottom - 8;
      end;

      FMainPanelBox.ParentWindow := Handle;
      with FMainPanelBox do
      begin
            BringToFront;
            BoundsRect := Rect1;
            Color := clBtnFace;
            ParentFont := True;
      end;

      FPanel2.ParentWindow := Handle;
      FPanel2.BringToFront;
      GetClientRect(Handle, Rect2);
      Rect2.Left := Rect1.Left;
      Rect2.Right := Rect1.Right;
      Rect2.Bottom := Rect1.Top - 1;
      FPanel2.BoundsRect := Rect2;

      with FWordWrapButton do
      begin
            Width := 22;
            Height := 22;
            Left := FPanel2.ClientRect.Right - Width;
            Top := (FPanel2.ClientHeight - Height) div 2;
            NumGlyphs := 1;
            OnClick := WordWrapClick;
            Hint := LocaleText(FWordWrapHints);
            ShowHint := True;
            GroupIndex := 3;
            AllowAllUp := True;
            Down := FWordWrapAndScale;
      end;
      with FShowPreviewButton do
      begin
            Width := 22;
            Height := 22;
            Top := (FPanel2.ClientHeight - Height) div 2;
            Glyph.LoadFromResourceName(HInstance, 'SHOWPREVIEWBUTTON');
            Hint := LocaleText(FShowPreviewButtonHints);
            ShowHint := True;
            GroupIndex := 2;
            AllowAllUp := True;
            Down := FShow;
            OnClick := ShowPreviewClick;
      end;
      FPreview;
end;

procedure TPBOpenPreviewDialog.DoClose;
begin
      Application.HideHint;
      try
            sndPlaySound(PChar(''), SND_ASYNC or SND_NODEFAULT);
      except
            Dummy('');
      end;
      inherited DoClose;
end;



function TPBOpenPreviewDialog.LoadLabelPanel(const FileName: String;Panel : TPanel): TPanel;
var
  FileStream: TFileStream;
  Control: TControl;
  Save_Cursor : TCursor;
  i : Integer;
  TMP_PANEL : TMyRTDesignerPanel;
  intScaleRatio: Integer;
begin

  Save_Cursor := Screen.Cursor;
  Screen.Cursor := crHourglass;    { Show hourglass cursor }

  try
    FileStream := TFileStream.Create(FileName, fmOpenRead);
    try
      FileStream.Read(CurVersion, SizeOf(Integer));

      TLabelForm(owner).FillPropertiesTable;

      while FileStream.Position < FileStream.Size do
      begin
        Control := TControl(FileStream.ReadComponent(nil));
        InsertComponent(Control);
        if FindWindowedComponent(Control) then
        with Control do
          Control.Parent := Panel;

        if Control is TLabelProperties then
          TLabelForm(owner).LabelProperties := TLabelProperties(Control)
        else if Control is TExtFileComponent then
          TLabelForm(owner).ExtFileComponent := TExtFileComponent(Control);

        if Control is TMyEdit then
          TMyEdit(Control).FillPropertiesTable(Handle)
        else if Control is TMyImage then
          TMyImage(Control).FillPropertiesTable(Handle)
        else if Control is TMyBarcode then
          TMyBarcode(Control).FillPropertiesTable(Handle)
        else if Control is TMyMemo then
          TMyMemo(Control).FillPropertiesTable(Handle)
        else if Control is TMyShape then
          TMyShape(Control).FillPropertiesTable(Handle);

      end;
    finally
      FileStream.Free;
      Screen.Cursor := Save_Cursor;  { Always restore to  normal }
    end;
  except
  end;


  for i := 0 to Panel.ControlCount - 1 do
    if FindWindowedComponent(Panel.Controls[i]) then
      if TLabelControl(Panel.Controls[i]).blnSetBackGround then
        TLabelControl(Panel.Controls[i]).SendToBack;


  intScaleRatio :=  integer(gintScaleRatio);

  TMP_PANEL := TMyRTDesignerPanel.Create(self);
  TMP_PANEL.SetScaleSize(TLabelForm(owner).LabelProperties.sngWidthCm,
                              TLabelForm(owner).LabelProperties.sngHeightCm, intScaleRatio);
  Panel.Width  := TMP_PANEL.Width;
  Panel.Height := TMP_PANEL.Height;
  TMP_PANEL.Free;

//  GetSelectedComponents;
end;


Function TPBOpenPreviewDialog.PanelToBmp(Panel:TPanel):TBitmap;
VAR
 bmp : tBitmap;
 DC  : HDC;
Begin
 Panel.Top := 0;
 Panel.left := 0;
 Tmp_Form.Width := Panel.Width;
 Tmp_Form.Height := Panel.Height;
 Tmp_Form.Show;
 ShowMessage('');
 bmp := tBitmap.Create;
 bmp.width := Panel.Width;
 bmp.Height := Panel.Height;
 DC := GetDc ( Panel.Handle );
 Bitblt(bmp.canvas.handle,0,0,Panel.Width,Panel.Height,Dc,0,0,srccopy);
 Releasedc(Panel.handle,dc);
 result := bmp;
 Tmp_Form.Close;
End;


procedure TPBOpenPreviewDialog.FPreview;
begin


        FPreviewImage.free;
        FPreviewImage := nil;
        FPreviewImage := TImage.Create(self);
        with FPreviewImage do
          begin
            Align := alNone;
            Name := 'FPreviewImage';
            Parent := FMainPanelBox;
            Stretch := true;
            BringToFront;
            Transparent := true;
          end;



        FPreviewPanel.Free;
      FPreviewPanel := NIL;
      FPreviewPanel := TPanel.Create(Self);
      with FPreviewPanel do
      begin
            Name := 'FPreviewPanel';
            Parent := Tmp_Form;
                Caption := 'Hello World';
            Left := 0;
                Top := 0;
                //FMainPanelBox.Color := $00CEFFFF;
            Color := $00CEFFFF;
            Visible := True;
                //Align := alClient;
      end;


       Ext := LowerCase(Copy(ExtractFileExt(FileName), 2, 9999));

      if (FileExists(FileName)) and (FShowPreviewButton.Down) then
      begin
                if (FPreviewDefaultExt.IndexOf(Ext) <> -1) then
               begin
                       if pos(Ext, 'stk') > 0 then
                  //try
                        LoadLabelPanel(FileName, FPreviewPanel);
                        FPreviewImage.Picture.Bitmap := PanelToBmp(FPreviewPanel);
                        FPreviewImage.Align := alClient;
                        FPreviewPanel.Visible := false;
                        //except
                   //      Dummy('');
                  //end
               end
                   else
                     FPreviewPanel.Visible := false;
      end;

//WordWrapClick(Self);

      FMainPanelBox.Update;
      FPanel2.Caption := LocaleText(FPreviewCaptions);
      FPanel2.Update;
end;






procedure TPBOpenPreviewDialog.SetPreviewCaptions(Value : TStringlist);
begin
      if Value <> FPreviewCaptions then
      begin
            FPreviewCaptions.Assign(Value);
            FPanel2.Caption := LocaleText(FPreviewCaptions);
      end;
end;

procedure TPBOpenPreviewDialog.SetScaleHints(Value : TStringlist);
begin
      if Value.Text <> FScaleHints.Text then
      begin
            FScaleHints.Assign(Value);
      end;
end;

procedure TPBOpenPreviewDialog.SetWordWrapHints(Value : TStringlist);
begin
      if Value.Text <> FWordWrapHints.Text then
      begin
            FWordWrapHints.Assign(Value);
      end;
end;

procedure TPBOpenPreviewDialog.SetShowPreviewButtonHints(Value : TStringlist);
begin
      if Value <> FShowPreviewButtonHints then
      begin
            FShowPreviewButtonHints.Assign(Value);
            FShowPreviewButton.Hint := LocaleText(FShowPreviewButtonHints);
      end;
end;

procedure TPBOpenPreviewDialog.SetNoPreviewTexts(Value : TStringlist);
begin
      if Value.Text <> FNoPreviewTexts.Text then
      begin
            FNoPreviewTexts.Assign(Value);
      end;
end;

procedure TPBOpenPreviewDialog.Dummy(Value: String);
begin
//      Read only !
end;

procedure TPBOpenPreviewDialog.SetCustomPreviewExt(Value : TStringlist);
begin
      if Value.Text <> FPreviewCustomExt.Text then FPreviewCustomExt.Assign(Value);
end;

procedure TPBOpenPreviewDialog.ShowPreviewClick(Sender : TObject);
begin
      FShow := FShowPreviewButton.Down;
      FPreview;
end;

procedure TPBOpenPreviewDialog.WordWrapClick(Sender : TObject);
begin
      FWordWrapAndScale := FWordWrapButton.Down;
end;

function TPBOpenPreviewDialog.Execute : Boolean;
begin
      if ofOldStyleDialog in Options then Options := Options -[ofOldStyleDialog];
      Template := 'PREVIEWTEMPLATE';
      if LocaleText(FTitles) <> '' then Title := LocaleText(FTitles);
      Result := inherited Execute;
end;

function TPBSavePreviewDialog.Execute : Boolean;
begin
      if ofOldStyleDialog in Options then Options := Options -[ofOldStyleDialog];
      Template := 'PREVIEWTEMPLATE';
      if LocaleText(FTitles) <> '' then Title := LocaleText(FTitles);
      Result := DoExecute(@GetSaveFileName);
end;

function TPBOpenPreviewDialog.LocaleText(List : TStringlist) : string;
begin
      if List.Count = 0 then Result := ''
      else
      begin
            if List.IndexOfName(FLocale) <> -1 then Result := List.Values[FLocale]
            else if List.IndexOfName('Default') <> -1 then Result := List.Values['Default']
            else Result := List.Values[List.Names[0]];
      end;
end;

procedure TPBOpenPreviewDialog.SetTitles(Value : TStringlist);
begin
      if FTitles.Text <> Value.Text then FTitles.Assign(Value);
end;

procedure TPBOpenPreviewDialog.SetShow(Value : Boolean);
begin
      if FShow <> Value then
      begin
            FShow := Value;
            FShowPreviewButton.Down := Value;
      end;
end;

procedure TPBOpenPreviewDialog.SetWordWrapAndScale(Value : Boolean);
begin
      if FWordWrapAndScale <> Value then
      begin
            FWordWrapAndScale := Value;
            FWordWrapButton.Down := Value;
      end;
end;

function TPBOpenPreviewDialog.StoreNoPreview : Boolean;
begin
      if FNoPreviewTexts.CommaText = NoPreviewDefault then Result := False
      else Result := True;
end;

function TPBOpenPreviewDialog.StoreCaptions : Boolean;
begin
      if FPreviewCaptions.CommaText = CaptionsDefault then Result := False
      else Result := True;
end;

function TPBOpenPreviewDialog.StoreScaleHints : Boolean;
begin
      if FScaleHints.CommaText = ScaleHintsDefault then Result := False
      else Result := True;
end;

function TPBOpenPreviewDialog.StoreWrapHints : Boolean;
begin
      if FWordWrapHints.CommaText = WrapHintsDefault then Result := False
      else Result := True;
end;

function TPBOpenPreviewDialog.StorePreviewHints : Boolean;
begin
      if FShowPreviewButtonHints.CommaText = PreviewHintsDefault then Result := False
      else Result := True;
end;

procedure Register;
begin
      RegisterComponents('PB', [TPBOpenPreviewDialog, TPBSavePreviewDialog]);
end;

end.
0
 

Author Comment

by:S_Warrior
ID: 7013150
its is the dialog component that I want to load the object's into the preview panel
0
 

Author Comment

by:S_Warrior
ID: 7013206
Maby there is some why to draw the panel without using DC?
0
 
LVL 8

Expert Comment

by:Cesario
ID: 7013213
S warrior,

I will check you code and come back soon ;-)
0
 

Author Comment

by:S_Warrior
ID: 7013226
I thing I found what is the prob, whan the panel I want to copy is under anther panel then its copy's the panel that is over the panel I want to copy.

there have to be some function to get only the pabel I want to copy.
0
 

Author Comment

by:S_Warrior
ID: 7019383
I want to reask the question!
0
 

Author Comment

by:S_Warrior
ID: 7019547
0

Featured Post

Highfive + Dolby Voice = No More Audio Complaints!

Poor audio quality is one of the top reasons people don’t use video conferencing. Get the crispest, clearest audio powered by Dolby Voice in every meeting. Highfive and Dolby Voice deliver the best video conferencing and audio experience for every meeting and every room.

Join & Write a Comment

A lot of questions regard threads in Delphi.   One of the more specific questions is how to show progress of the thread.   Updating a progressbar from inside a thread is a mistake. A solution to this would be to send a synchronized message to the…
Objective: - This article will help user in how to convert their numeric value become words. How to use 1. You can copy this code in your Unit as function 2. than you can perform your function by type this code The Code   (CODE) The Im…
Internet Business Fax to Email Made Easy - With eFax Corporate (http://www.enterprise.efax.com), you'll receive a dedicated online fax number, which is used the same way as a typical analog fax number. You'll receive secure faxes in your email, fr…
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

760 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

19 Experts available now in Live!

Get 1:1 Help Now