Solved

Transparent Bitmap on a MDIParentForm

Posted on 1998-05-06
10
395 Views
Last Modified: 2013-12-02
How can i paint or add centered a transparent bitmap on a mdiparentform in delphi 1?
And how can i put a text on the mdiparentform in a specific font?
0
Comment
Question by:ponti
  • 5
  • 4
10 Comments
 
LVL 8

Expert Comment

by:ZifNab
ID: 1342064
Can you be more specific?

MDIParentForm is always at the background --> why transparent bitmap?

Text in a specific font??? Where ? On form? Use a Label?

ZiF.
0
 

Author Comment

by:ponti
ID: 1342065
I tried to put a label or bitmap on the mdiparentform but nothing is displayed when starting the application. How can i show a text centered on a mdiparentform? I tried to use the windows api call "textout", but how can you assign a specific font?
0
 
LVL 8

Expert Comment

by:ZifNab
ID: 1342066
If you use textout you've to change the font via the canvas....

Canvas.Font.Style ......

Regards, Zif.
0
 
LVL 8

Accepted Solution

by:
ZifNab earned 100 total points
ID: 1342067
Hi ponti,
Here is some code I found :

MDI Parent Background

From: Dave Horacek <dhoracek@swbell.net>

Here's some code that may prove useful. It is for either a normal form or an MDI form and tiles a bitmap or
produces gradients. The only tricky part is establishing the window message handler for the ClientHandle of the
window that actually manages the child forms. That's where the bitmaps and graphics actually appear in an MDI
form. Just load a bitmap into imgTile at design time and you're ready to go.



unit UMain;

interface

uses
  Windows, Messages, Classes, SysUtils, Graphics, Controls, Forms,
Dialogs,
  ExtCtrls, Menus;

type
  TfrmMain = class(TForm)
    mnuMain: TMainMenu;
    mnuFile: TMenuItem;
    mnuExit: TMenuItem;
    imgTile: TImage;
    mnuOptions: TMenuItem;
    mnuBitmap: TMenuItem;
    mnuGradient: TMenuItem;
    procedure mnuExitClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure mnuBitmapClick(Sender: TObject);
    procedure mnuGradientClick(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure FormResize(Sender: TObject);
    procedure FormPaint(Sender: TObject);
  private
    { Private declarations }
    MDIDefProc:pointer;
    MDIInstance:TFarProc;
    procedure MDIWndProc(var prmMsg:TMessage);
    procedure CreateWnd;override;
    procedure ShowBitmap(prmDC:hDC);
    procedure ShowGradient(prmDC:hDC;prmRed,prmGreen,prmBlue:byte);
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;
  glbImgWidth:integer;
  glbImgHeight:integer;

implementation

{$R *.DFM}

procedure TfrmMain.FormCreate(Sender: TObject);
begin
 glbImgHeight:=imgTile.Picture.Height;
 glbImgWidth:=imgTile.Picture.Width;
end;

procedure TfrmMain.FormResize(Sender: TObject);
begin
 FormPaint(Sender);
end;

procedure TfrmMain.MDIWndProc(var prmMsg:TMessage);
begin
 with prmMsg do
  begin
   if Msg=WM_ERASEBKGND then
    begin
     if mnuBitmap.Checked then
      ShowBitmap(wParam)
     else
      ShowGradient(wParam,255,0,0);
     Result:=1;
    end
   else
    Result:=CallWindowProc(MDIDefProc,ClientHandle,Msg,wParam,lParam);
  end;
end;

procedure TfrmMain.CreateWnd;
begin
 inherited CreateWnd;
 MDIInstance:=MakeObjectInstance(MDIWndProc); { create wrapper }
 MDIDefProc:=pointer(SetWindowLong(ClientHandle,GWL_WNDPROC,
     longint(MDIInstance)) );
end;

procedure TfrmMain.FormCloseQuery(Sender: TObject; var CanClose:
Boolean);
begin
 { restore default window proc }
 SetWindowLong(ClientHandle,GWL_WNDPROC,longint(MDIDefProc));
 { dispose of instance }
 FreeObjectInstance(MDIInstance);
end;

procedure TfrmMain.mnuExitClick(Sender: TObject);
begin
 close;
end;

procedure TfrmMain.mnuBitmapClick(Sender: TObject);
 var
  wrkDC:hDC;
begin
 wrkDC:=GetDC(ClientHandle);
 ShowBitmap(wrkDC);
 ReleaseDC(ClientHandle,wrkDC);
 mnuBitmap.Checked:=true;
 mnuGradient.Checked:=false;
end;

procedure TfrmMain.mnuGradientClick(Sender: TObject);
 var
  wrkDC:hDC;
begin
 wrkDC:=GetDC(ClientHandle);
 ShowGradient(wrkDC,0,0,255);
 ReleaseDC(ClientHandle,wrkDC);
 mnuGradient.Checked:=true;
 mnuBitMap.Checked:=false;
end;

procedure TfrmMain.ShowBitmap(prmDC:hDC);
 var
  wrkSource:TRect;
  wrkTarget:TRect;
  wrkX:integer;
  wrkY:integer;
begin
 {tile bitmap }
 if FormStyle=fsNormal then
  begin
   wrkY:=0;
   while wrkY < ClientHeight do    { go from top to bottom.. }
    begin
     wrkX:=0;
     while wrkX < ClientWidth do   { ..and left to right. }
      begin
       Canvas.Draw(wrkX,wrkY,imgTile.Picture.Bitmap);
       Inc(wrkX,glbImgWidth);
      end;
     Inc(wrkY,glbImgHeight);
    end;
  end
 else if FormStyle=fsMDIForm then
  begin
   Windows.GetClientRect(ClientHandle,wrkTarget);
   wrkY:=0;
   while wrkY < wrkTarget.Bottom do
    begin
     wrkX:=0;
     while wrkX < wrkTarget.Right do
      begin
       BitBlt(longint(prmDC),wrkX,wrkY,imgTile.Width,imgTile.Height,
                imgTile.Canvas.Handle,0,0,SRCCOPY);
       Inc(wrkX,glbImgWidth);
      end;
     Inc(wrkY,glbImgHeight);
    end;
  end;
end;

procedure TfrmMain.ShowGradient(prmDC:hDC;prmRed,prmGreen,prmBlue:byte);
 var
  wrkBrushNew:hBrush;
  wrkBrushOld:hBrush;
  wrkColor:TColor;
  wrkCount:integer;
  wrkDelta:integer;
  wrkRect:TRect;
  wrkSize:integer;
  wrkY:integer;
begin
 { gradient routine }
 wrkDelta:=255 div (1+ClientHeight); { number of shades desired }
 if wrkDelta=0 then wrkDelta:=1;     { yes, usually 1 }
 wrkSize:=ClientHeight div 240;      { size of blended bars }
 if wrkSize=0 then wrkSize:=1;
 for wrkY:=0 to 1+(ClientHeight div wrkSize) do
  begin
   wrkColor:=RGB(prmRed,prmGreen,prmBlue);
   wrkRect:=Rect(0,wrkY*wrkSize,ClientWidth,(wrkY+1)*wrkSize);
   if FormStyle=fsNormal then
    begin
     Canvas.Brush.Color:=wrkColor;
     Canvas.FillRect(wrkRect);
    end
   else if FormStyle=fsMDIForm then
    begin
     wrkBrushNew:=CreateSolidBrush(wrkColor);
     wrkBrushOld:=SelectObject(prmDC,wrkBrushNew);
     FillRect(prmDC,wrkRect,wrkBrushNew);
     SelectObject(prmDC,wrkBrushOld);
     DeleteObject(wrkBrushNew);
    end;
   if prmRed >wrkDelta then Dec(prmRed,wrkDelta);
   if prmGreen > wrkDelta then Dec(prmGreen,wrkDelta);
   if prmBlue  > wrkDelta then Dec(prmBlue,wrkDelta);
  end;
end;

procedure TfrmMain.FormPaint(Sender: TObject);
begin
 if FormStyle=fsNormal then
  if mnuBitMap.Checked then
   mnuBitMapClick(Sender)
  else
   mnuGradientClick(Sender);
end;

end.

Regards, ZiF.

0
 

Author Comment

by:ponti
ID: 1342068
The code is nearly useful. My problem is to set a specific font via the api function selectobject. With tfont.handle it work nearly fine, except that the font color i have set doesnot work. the text is always painted black on white background, whatever i set.
Also a new brush or pen does not help.
0
Top 6 Sources for Identifying Threat Actor TTPs

Understanding your enemy is essential. These six sources will help you identify the most popular threat actor tactics, techniques, and procedures (TTPs).

 
LVL 8

Expert Comment

by:ZifNab
ID: 1342069
Can you send a piece of your code?
0
 

Author Comment

by:ponti
ID: 1342070
Here is a piece of my code. The problem is the color property of tfont, which does not affect the output of the text. It is always painted black on white background.
What is wrong?
 
class MyClass
  ...
private
    fClientInstance, fPrevClient: TFarProc;
    procedure ClientWindow(var aMessage: TMessage);
end;

procedure TMyClass.ClientWindow(var aMessage: TMessage);
var row, col: word; dc: hDC;
    mybrush: TBrush;
    mypen: TPen;
    myFont: TFont;
begin
  with aMessage do
    case Msg of
      WM_ERASEBKGND:
        begin
          dc:= TWMEraseBkGnd(aMessage).dc;
          mybrush:= TBrush.Create;
          mybrush.Color:= clBtnFace;
          mybrush.style:= bsSolid;
          mypen:= TPen.Create;
          mypen.Color:= clBtnFace;
          myfont:= TFont.Create;
          myfont.color:= clGray;
          myfont.size:= 32;
          myfont.name:= 'Arial';
          WinProcs.SelectObject(dc, mybrush.Handle);
          WinProcs.SelectObject(dc, mypen.Handle);
          WinProcs.Rectangle( dc, 0, 0, ClientWidth, ClientHeight );
          WinProcs.SelectObject(dc, myfont.Handle);
          WinProcs.TextOut(dc, 200, 200, 'My Output', 10);
          mybrush.free;
          mypen.free;
          myfont.free;
          result:=1;
        end;
    else result:= CallWindowProc(fPrevClient, Clienthandle, Msg, wParam, lParam);
  end;
end;


At beginning:
   fClientInstance:= MakeObjectInstance(ClientWindow);
   fPrevClient:= Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
   SetWindowLong(ClientHandle, GWL_WNDPROC, Longint(fClientInstance));

At the end:
   SetWindowLong(ClientHandle, GWL_WNDPROC, Longint(fPrevClient));
   FreeObjectInstance(fClientInstance);  

0
 
LVL 8

Expert Comment

by:ZifNab
ID: 1342071
Try to use this with your canvas... Yo do use the same canvas I hope?

                          var
                            OldBkMode : integer;
                          begin
                            with Form1.Canvas do begin
                              Brush.Color := clRed;
                              FillRect(Rect(0, 0, 100, 100));
                              Brush.Color := clBlue;
                              TextOut(10, 20, 'Not Transparent!');
                              OldBkMode := SetBkMode(Handle, TRANSPARENT);
                              TextOut(10, 50, 'Transparent!');
                              SetBkMode(Handle, OldBkMode);
                            end;
                          end;

regards, ZiF.
0
 

Author Comment

by:ponti
ID: 1342072
I have found out how i can do it. I assign the dc to the canvas.handle and it works.
But i will also try your version.

Thanks for helping
0
 

Expert Comment

by:bitgoeul100898
ID: 1342073
Thanks For helping...
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

Introduction Raise your hands if you were as upset with FireMonkey as I was when I discovered that there was no TListview.  I use TListView in almost all of my applications I've written, and I was not going to compromise by resorting to TStringGrid…
In my programming career I have only very rarely run into situations where operator overloading would be of any use in my work.  Normally those situations involved math with either overly large numbers (hundreds of thousands of digits or accuracy re…
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…
Get a first impression of how PRTG looks and learn how it works.   This video is a short introduction to PRTG, as an initial overview or as a quick start for new PRTG users.

758 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

22 Experts available now in Live!

Get 1:1 Help Now