VPF::XP vs Vista - Форум программистов

aktuba

Дата 24.4.2008, 14:39 (ссылка)

(голосов:2)

Загрузка ...

Смышленный

Профиль
Группа: Завсегдатай
Сообщений: 1915
Регистрация: 24.4.2006
Где: Планета Земля

Репутация: 16
Всего: 38

Проблема с регионами + UpdateLayeredWindow.

Вот скрин в XP: user posted image

Вот он же в Vista: user posted image

Вот код:

Код


unit unit_layer1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, jpeg, ExtCtrls;

type
  TfmLayer1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
    FRgn: HRGN;
    FPanelRgn: HRGN;
    FPanel: TPanel;
    procedure UpdateProc(Sender: TObject);
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  public
    { Public declarations }
  end;

const
  BORDER_WIDTH = 10;
  CAPTION_HEIGHT = 30;

var
  fmLayer1: TfmLayer1;

implementation

{$R *.dfm}

procedure TfmLayer1.UpdateProc(Sender: TObject);
type
  TRGBQArray = array[0..0] of TRGBQuad;
  PRGBQArray = ^TRGBQArray;

var
  lBlend: TBlendFunction;
  lSize: TSize;
  lTopLeft: TPoint;
  i, j: integer;
  lRow: PRGBQArray;
begin
  with TBitmap.Create do
  try
    Width := Self.Width;
    Height := Self.Height;
    PixelFormat := pf32bit;

    with Canvas do
    begin
      Brush.Color := clBlack;
      FillRect(ClipRect);
      Pen.Color := clSilver;
      Brush.Color := $202020;
    end;

    FPanel.PaintTo(Canvas, FPanel.Left, FPanel.Top);
    FrameRgn(Canvas.Handle, FRgn, Canvas.Brush.Handle, 1, 1);
    
    for j := 0 to Height - 1 do
    begin
      lRow := Scanline[j];
      for i := 0 to Width - 1 do
      begin
        if PtInRegion(FRgn, i, j) then
        begin
          with lRow[i] do
            case RGB(rgbRed, rgbGreen, rgbBlue) of
              clBlack: rgbReserved := 5;
              clSilver: rgbReserved := 200;
            else
              rgbReserved := 175;
            end;
        end
        else
          if PtInRegion(FPanelRgn, i, j) then
            lRow[i].rgbReserved := 255
          else
            lRow[i].rgbReserved := 0;
        lRow[i].rgbBlue := Round(lRow[i].rgbBlue * lRow[i].rgbReserved / 255);
        lRow[i].rgbGreen := Round(lRow[i].rgbGreen * lRow[i].rgbReserved / 255);
        lRow[i].rgbRed := Round(lRow[i].rgbRed * lRow[i].rgbReserved / 255);

        // Заглушка, чтобы спрятать уголки панели
        if ((lRow[i].rgbBlue = 175) and
           (lRow[i].rgbGreen = 175) and
           (lRow[i].rgbRed = 175) and
           (lRow[i].rgbReserved = 175)) or
           ((lRow[i].rgbBlue = 88) and
           (lRow[i].rgbGreen = 88) and
           (lRow[i].rgbRed = 88) and
           (lRow[i].rgbReserved = 175)) then
        begin
          lRow[i].rgbBlue := 0;
          lRow[i].rgbGreen := 0;
          lRow[i].rgbRed := 0;
          lRow[i].rgbReserved := 5;
        end;
      end;
    end;

    with lBlend do
    begin
      BlendOp := AC_SRC_OVER;
      BlendFlags := 0;
      SourceConstantAlpha := 255;
      AlphaFormat := AC_SRC_ALPHA;
    end;

    with lSize do
    begin
      cx := Width;
      cy := Height;
    end;

    lTopLeft := Point(0, 0);

    UpdateLayeredWindow(Self.Handle, 0, nil, @lSize, Canvas.Handle,
      @lTopLeft, clNone, @lBlend, ULW_ALPHA);
  finally
    Free;
  end;
end;

procedure TfmLayer1.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style or WS_THICKFRAME;
end;

procedure TfmLayer1.FormCreate(Sender: TObject);
var
  lRgn, lRgn2: HRGN;
  lRound: Integer;
begin
  DoubleBuffered := True;
  Position := poScreenCenter;
  FPanel := TPanel.Create(Self);
  FPanel.Parent := Self;
  FPanel.BoundsRect := Rect(BORDER_WIDTH, CAPTION_HEIGHT + BORDER_WIDTH,
    Width - BORDER_WIDTH, Height - BORDER_WIDTH);
  FPanel.Color := clWhite;
  FPanel.Caption := 'Test Panel';

  FRgn := CreateRectRgn(0, 0, Width, Height);

  lRound := Width div 20;
  if Height div 20 > lRound then
    lRound := Height div 20;
  lRgn := CreateRoundRectRgn(0, CAPTION_HEIGHT,
    Width, Height, lRound, lRound);
  lRound := Width div 20;
  if Height div 20 > lRound then
    lRound := Height div 20;
  lRgn2 := CreateRoundRectRgn(0, 0, 120,
    CAPTION_HEIGHT * 2, lRound, lRound);
  CombineRgn(lRgn, lRgn, lRgn2, RGN_OR);
  CombineRgn(FRgn, FRgn, lRgn, RGN_AND);
  DeleteObject(lRgn);
  DeleteObject(lRgn2);

  lRound := FPanel.Width div 20;
  if FPanel.Height div 20 > lRound then
    lRound := FPanel.Height div 20;
  FPanelRgn := CreateRoundRectRgn(BORDER_WIDTH, CAPTION_HEIGHT + BORDER_WIDTH,
    Width - BORDER_WIDTH, Height - BORDER_WIDTH, lRound, lRound);
  CombineRgn(FRgn, FRgn, FPanelRgn, RGN_DIFF);

  SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or
    WS_EX_LAYERED);
end;

procedure TfmLayer1.FormDestroy(Sender: TObject);
begin
  DeleteObject(FPanelRgn);
  DeleteObject(FRgn);
end;

procedure TfmLayer1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if (Button = mbLeft) and (Tag <> 1) and (Y <= CAPTION_HEIGHT) then
  begin
    ReleaseCapture;
    Perform(WM_SYSCOMMAND, $F012, 0);
  end;
end;

procedure TfmLayer1.FormShow(Sender: TObject);
begin
  UpdateProc(Self);
  OnResize := UpdateProc;
end;

end.

Проект приложил. У кого есть идеи что к чему?

Присоединённый файл ( Кол-во скачиваний: 11 )

VistaTest.rar 214,59 Kb

--------------------

Alexeis

Дата 24.4.2008, 15:34 (ссылка)

(нет голосов)

Загрузка ...

Амеба

Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 109
Всего: 459

Форма создается с каким заголовком? Может стоит создать форму безо всякого заголовка?

--------------------

Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать

VICTAR

Дата 24.4.2008, 15:52 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Участник
Сообщений: 1108
Регистрация: 6.10.2006

Репутация: 37
Всего: 80

Без заголовка. BorderStyle = bsNone

aktuba

Дата 24.4.2008, 18:45 (ссылка)

(нет голосов)

Загрузка ...

Смышленный

Профиль
Группа: Завсегдатай
Сообщений: 1915
Регистрация: 24.4.2006
Где: Планета Земля

Репутация: 16
Всего: 38

Вопрос решен, не углядел кое-что в коде...

--------------------

Alexeis

Дата 24.4.2008, 19:53 (ссылка)

(нет голосов)

Загрузка ...

Амеба

Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 109
Всего: 459

Цитата(aktuba @ 24.4.2008, 17:45

)

Вопрос решен, не углядел кое-что в коде...

Что именно?

--------------------

VICTAR

Дата 24.4.2008, 20:43 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Участник
Сообщений: 1108
Регистрация: 6.10.2006

Репутация: 37
Всего: 80

WS_THICKFRAME было лишним

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: Общие вопросы \| Следующая тема »