Версия для печати темы
Нажмите сюда для просмотра этой темы в оригинальном формате
Форум программистов > Delphi: Звук, графика и видео > Нарисовать на рабочем столе свой битмап


Автор: Zlo 15.9.2006, 19:53
Нашел вот такой код
Код

procedure PaintDesk;
var
  c: TCanvas;
begin
  c := TCanvas.Create;
       
  c.Handle := GetDC(GetWindow(GetDesktopWindow, GW_OWNER));

       //теперь на рабочем столе можно рисовать как на форме
  c.FillRect(rect(10,10,300,450));


  c.free;
end;

как бы сделать так чтобы он нарисовал мой бмп?

Автор: Alexeis 15.9.2006, 21:19
Код

procedure TForm1.Button1Click(Sender: TObject);
var
  b : TBitmap;
  c: TCanvas;

begin
  c := TCanvas.Create;
  c.Handle := GetDC(GetWindow(GetDesktopWindow, GW_OWNER));
  b := TBitmap.Create;
  b.Height := 200;
  b.Width := 200;
  b.Canvas.Ellipse(10, 10, 200, 200);
  c.Draw(10, 10, b);
  c.free;
  b.Free;
end;

Автор: Zlo 15.9.2006, 23:07
Спасибо большое, сделал вот так:
Код

procedure PaintDesk;
var
  b : TBitmap;
  c: TCanvas;

begin
  c := TCanvas.Create;
  c.Handle := GetDC(GetWindow(GetDesktopWindow, GW_OWNER));
  b := TBitmap.Create;
  b.Height := 50;
  b.Width := 50;
  b.Canvas.Ellipse(10, 10, 200, 200);
  b.LoadFromFile('G:\Program Files\Borland\Delphi7\Projects\picture7196683884486.bmp');
  c.Draw(10, 10, b);
  c.free;
  b.Free;
end;
{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
   PaintDesk;
end;


А как можно сделать что бы фон под рисунким был цвета фона рабочего стола?

Автор: Alexeis 15.9.2006, 23:14
Цитата(Zlo @  15.9.2006,  23:07 Найти цитируемый пост)

А как можно сделать что бы фон под рисунким был цвета фона рабочего стола?

Скопировать фрагмент канваса рабочего стола на битмап перед рисованием при помощи функции copyRect

Автор: Zlo 15.9.2006, 23:16
попробовал млодифицировать пример из DRKB вывод текста на битмапе с фоном битмапа но не получилось вот код:

Код примера из DRKB
Код

{Как разместить прозрачную надпись на TBitmap? }

procedure TForm1.Button1Click(Sender: TObject); 
var 
   OldBkMode : integer; 
begin 
   Image1.Picture.Bitmap.Canvas.Font.Color := clBlue; 
   OldBkMode := SetBkMode(Image1.Picture.Bitmap.Canvas.Handle,TRANSPARENT); 
   Image1.Picture.Bitmap.Canvas.TextOut(10, 10, 'Hello'); 
   SetBkMode(Image1.Picture.Bitmap.Canvas.Handle,OldBkMode); 
end; 


Вот то что сделал я (может что-то не так сделал?)
Код

procedure PaintDesk;
var
  b : TBitmap;
  c: TCanvas;
  OldBkMode : integer;

begin
  c := TCanvas.Create;
  c.Handle := GetDC(GetWindow(GetDesktopWindow, GW_OWNER));
  b := TBitmap.Create;
  b.Height := 50;
  b.Width := 50;
  //b.Canvas.Ellipse(10, 10, 200, 200);

  b.LoadFromFile('G:\Program Files\Borland\Delphi7\Projects\picture7196683884486.bmp');
  OldBkMode := SetBkMode(b.Canvas.Handle,TRANSPARENT);
  c.Draw(10, 10, b);
  SetBkMode(b.Canvas.Handle,OldBkMode);
  c.free;
  b.Free;
end;


Добавлено @ 23:17 

Цитата(alexeis1 @  15.9.2006,  23:14 Найти цитируемый пост)
Скопировать фрагмент канваса рабочего стола на битмап перед рисованием при помощи функции copyRect

а можно пример?

Автор: Alexeis 15.9.2006, 23:34
Цитата(Zlo @  15.9.2006,  23:16 Найти цитируемый пост)
а можно пример?

Код

procedure TForm1.Button1Click(Sender: TObject);
var
  b : TBitmap;
  c : TCanvas;
begin
  c := TCanvas.Create;
  c.Handle := GetDC(GetWindow(GetDesktopWindow, GW_OWNER));
  b := TBitmap.Create;
  b.Height := 200;
  b.Width := 200;
  b.Canvas.CopyRect(rect(-10, -10, 200, 200), c, rect(0, 0, 210, 210));
  b.Canvas.Ellipse(10, 10, 200, 200);
  c.Draw(10, 10, b);
  c.free;
  b.Free;
end;

Автор: Zlo 15.9.2006, 23:41
Код

var
  b : TBitmap;
  c : TCanvas;
begin
  c := TCanvas.Create;
  c.Handle := GetDC(GetWindow(GetDesktopWindow, GW_OWNER));
  b := TBitmap.Create;
  b.Height := 50;
  b.Width := 50;
  //b.LoadFromFile('G:\Program Files\Borland\Delphi7\Projects\picture7196683884486.bmp');

  b.Canvas.CopyRect(rect(-10, -10, 200, 200), c, rect(0, 0, 210, 210));
  //b.Canvas.Ellipse(10, 10, 200, 200);
  b.LoadFromFile('G:\Program Files\Borland\Delphi7\Projects\picture7196683884486.bmp');
  c.Draw(10, 10, b);
  c.free;
  b.Free;
end;

вот так всеравно черный фон остается

Добавлено @ 23:45 
а картинка вот эта
user posted image

Автор: Alexeis 15.9.2006, 23:48
Zlo, конечно остается, ведь исходная картинка с фоном рабочего стола заменяется новой smile 
Нужно новую накладывать на старую с прозрачностью, причем эта картинка должна быть 32 бита на пиксель с установленым альфа каналом. Как накладывать картинку с прозрачностью как то уже показывал Snowy.

Добавлено @ 23:50 
Код

procedure TForm1.Button1Click(Sender: TObject);    
var    
  bmp1, bmp2: TBitMap;    
  Blend: TBlendFunction;    
begin    
  bmp1 := TBitMap.Create;    
  bmp2 := TBitMap.Create;    
  bmp1.LoadFromFile('C:\1.bmp'); // загружаем 1 битмап    
  bmp2.LoadFromFile('C:\2.bmp'); // и второй битмап    
  bmp1.PixelFormat := pf32bit; // переводим оба в 32 бит    
  bmp2.PixelFormat := pf32bit;    
  Blend.BlendOp := AC_SRC_OVER;    
  Blend.BlendFlags := 0;    
  Blend.SourceConstantAlpha := 128; // прозрачность 50% (0 - 255)    
  Blend.AlphaFormat := AC_SRC_ALPHA;    
  // накладываем битмап 2 на битмап 1    
  if Windows.AlphaBlend(bmp1.Canvas.Handle, 0, 0, bmp1.Width, bmp1.Height,    
                        bmp2.Canvas.Handle, 0, 0, bmp2.Width, bmp2.Height, Blend) then    
    Canvas.Draw(0, 0, bmp1) // рисуем результат на форме    
  else ShowMessage(IntToStr(GetLastError)); // или код ошибки, если наложить не удалось    
  bmp1.Free; bmp2.Free; // уничтожаем битмапы    
end;

Автор: Zlo 15.9.2006, 23:51
Странно а если сделать рисунок 16 бит (до этого был 24) то выводится полупрозрачный прямоугольник

Автор: Alexeis 15.9.2006, 23:55
Вообще тут придется поиграться с параметром 
Blend.AlphaFormat 
и установить 
Blend.SourceConstantAlpha := 255;  или 0; в зависимости от типа операции.

Автор: Zlo 15.9.2006, 23:59
Все равно не получилось smile
Но спасибо большое что возишся со мной!
Если не Влом то помоги плиз

Добавлено @ 00:01 
а какие параметры могут принимать Blend.AlphaFormat  ?

Автор: Alexeis 16.9.2006, 01:17
Вот сюда я закачал весь проект целиком (с рисунками) для наложения дельфина, на облака
http://alexei-s1.narod.ru/Samples/trans.rar
Код

type
  TRGBA = packed record
           case Byte of
           0: (B, G, R, A : Byte);
           1: (Acolor : Cardinal);
  end;

  T32bitarr = array[0..32000] of TRGBA;
  P32bitarr = ^T32bitarr;

procedure TForm1.Button1Click(Sender: TObject);
var    
  bmp1, bmp2: TBitMap;    
  Blend: TBlendFunction;
  i, j : Integer;
  Line : P32bitarr;

begin    
  bmp1 := TBitMap.Create;    
  bmp2 := TBitMap.Create;

  bmp1.LoadFromFile(ExtractFilePath(Application.ExeName) +
                    'Облака.bmp'); // загружаем 1 битмап
  bmp2.LoadFromFile(ExtractFilePath(Application.ExeName) +
                    'img.bmp'); // и второй битмап

  bmp1.PixelFormat := pf32bit; // переводим оба в 32 бит
  bmp2.PixelFormat := pf32bit;

  for j := 0 to bmp2.Height - 1   
  do
    begin
      Line := bmp2.ScanLine[j];
      for i := 0 to bmp2.Width - 1
      do
        if Line[i].Acolor <> 0  //картинку не прозрачной
        then
          Line[i].A := 255;
    end;

  Blend.BlendOp := AC_SRC_OVER;
  Blend.BlendFlags := 0;
  Blend.SourceConstantAlpha := 255; // прозрачность 50% (0 - 255)
  Blend.AlphaFormat := AC_SRC_ALPHA;
  // накладываем битмап 2 на битмап 1
  if Windows.AlphaBlend(bmp1.Canvas.Handle, 0, 0, bmp1.Width, bmp1.Height,    
                                       bmp2.Canvas.Handle, 0, 0, bmp2.Width, bmp2.Height, Blend) then    
    Canvas.Draw(0, 0, bmp1) // рисуем результат на форме
  else ShowMessage(IntToStr(GetLastError)); // или код ошибки, если наложить не удалось    

  bmp1.Free;
  bmp2.Free; // уничтожаем битмапы
end;


для рабочего стола все аналогично, вместо облаков будет фрагмент фона (только его уже не нужно никуда загружать, просто передать Handle (канваса десктопа) вместо первой картинки), а второй битмап будет загруженым. Т.о. будет произведено наложение изображений двух контекстов.

Если не получится буду доделывать дальше (а то так не интересно же програмировать, если все будет готово smile )

Автор: Zlo 16.9.2006, 15:12
Чето не могу понять как переделать код чтоб на десктопе рисовать дельфина

Автор: Alexeis 16.9.2006, 16:16
Ладно, вот уже полностью рабочий пример

Код

type
  TRGBA = packed record
           case Byte of
           0: (B, G, R, A : Byte);
           1: (Acolor : Cardinal);
  end;

  T32bitarr = array[0..32000] of TRGBA;
  P32bitarr = ^T32bitarr;

procedure TForm1.Button1Click(Sender: TObject);
var
  bmp: TBitMap;
  Blend: TBlendFunction;
  i, j : Integer;
  Line : P32bitarr;

begin
  bmp := TBitMap.Create;
  bmp.LoadFromFile(ExtractFilePath(Application.ExeName) + 'img.bmp');
  bmp.PixelFormat := pf32bit;  // переводим оба  32 бит

  for j := 0 to bmp.Height - 1
  do
    begin
      Line := bmp.ScanLine[j];
      for i := 0 to bmp.Width - 1
      do
        if Line[i].Acolor <> 0  //картинку не прозрачной
        then
          Line[i].A := 255;
    end;

  Blend.BlendOp := AC_SRC_OVER;
  Blend.BlendFlags := 0;
  Blend.SourceConstantAlpha := 255;
  Blend.AlphaFormat := AC_SRC_ALPHA;
  // накладываем битмап на битмап на рабочий стол
  if not Windows.AlphaBlend(GetDC(GetWindow(GetDesktopWindow, GW_OWNER)),
                        0, 0, bmp.Width, bmp.Height,
                        bmp.Canvas.Handle, 0, 0, bmp.Width, bmp.Height,
                        Blend)

  then ShowMessage(IntToStr(GetLastError));
       // или код ошибки, если наложить не удалось

  bmp.Free;
end;

Автор: Zlo 16.9.2006, 20:24
alexeis1
СПАСИБО БОЛЬШОЕ!!!

Powered by Invision Power Board (http://www.invisionboard.com)
© Invision Power Services (http://www.invisionpower.com)