Delphi-PRAXiS
Seite 1 von 2  1 2      

Delphi-PRAXiS (https://www.delphipraxis.net/forum.php)
-   GUI-Design mit VCL / FireMonkey / Common Controls (https://www.delphipraxis.net/18-gui-design-mit-vcl-firemonkey-common-controls/)
-   -   Delphi Winproc ärger (https://www.delphipraxis.net/128364-winproc-aerger.html)

EWeiss 28. Jan 2009 16:57


Winproc ärger
 
Delphi-Quellcode:
unit uListBox;

interface

uses Windows, Classes, Messages, uGlobal, uGDIUnit, uSkin, uDrawText,
  uBass, uBassVis, BassVis, SysUtils, StrUtils;

type
  TListBox = class
  private
    FHOwner : HWND;
    LStyle:    DWORD;
    hFDefault:   HWND;
    procedure SubClass(WinHandle: HWND);
    procedure UnSubClass(WinHandle: HWND);
    function DefaultFont: hFont;
    procedure SetCTLFont(hCtL: HWND; Font: hFont);
  public
    constructor Create(hOwner: HWND; FullpathImageName: string; x, y, xW, yH,
      PlayListID: integer; BackColor: COLORREF);
    destructor Destroy; override;
  end;

type
  LBTYPE = Record
    Forecolor        : COLORREF;
    Backcolor        : COLORREF;
    ForeColorSelected : COLORREF;
    BackColorSelected : COLORREF;
    BorderStyle      : Integer;
    DrawStyle        : Integer;
    ItemHeight       : Integer;
    hWnd             : HWND;
    Left             : Integer;
    Top              : Integer;
    Width            : Integer;
    Height           : Integer;
    hFont            : HFONT;
  end;

var
  TMListBox: LBTYPE;
  TempFont: GpFont;
  Img:     cardinal;

function ListBoxProc(WinHandle: HWND; Msg: UINT; wP: WParam; lP: LParam): LRESULT; stdcall;
procedure DrawItem(lP: Integer);

implementation
uses uMainApp;

var
  PrevWndProc, PrevWndProcLB: Integer;

// Erstelle den Default Font.
function TListBox.DefaultFont: hFont;
begin
  if hFDefault = 0 then
    hFDefault := GetStockObject(ANSI_VAR_FONT);

  Result := hFDefault;
end;

// Setze den verwendeten Font zum ausgewählten Control.
procedure TListBox.SetCTLFont(hCtL: HWND; Font: hFont);
begin
  SendMessage(hCtL, WM_SETFONT, Font, 0);
end;

constructor TListBox.Create(hOwner: HWND; FullpathImageName: string; x, y, xW, yH,
  PlayListID: integer; BackColor: COLORREF);

begin

  with SkinEngine do
  begin

      // Erstelle das GDIPLUS image von Datei
      Img := AddResource(PAnsiChar(FullpathImageName));
      if Img <> 0 then
      begin
        // Hole die Thumb GDIPLUS image größe
        GetImageSize(Img, imgW, imgH);
        // LBS_NOTIFY übergeben ohne wird kein Event
        // auf LBN_DBLCLK ausgelößt
        // LBS_OWNERDRAWFIXED verursacht ärger keine ahnung warum
        LStyle := LBS_HASSTRINGS {Or LBS_OWNERDRAWFIXED} Or
                  LBS_NOINTEGRALHEIGHT Or LBS_NOTIFY or WS_CHILD
                  Or WS_BORDER Or WS_VSCROLL;
        // Propertys der Listbox festlegen
        TMListBox.Forecolor := GetSysColor(COLOR_BTNTEXT);
        TMListBox.Backcolor := RGB(255, 255, 255);
        TMListBox.ForeColorSelected := GetSysColor(COLOR_HIGHLIGHTTEXT);
        TMListBox.BackColorSelected := GetSysColor(COLOR_HIGHLIGHT);
        TMListBox.BorderStyle := EDGE_RAISED;
        TMListBox.Left := x;
        TMListBox.Top := y;
        TMListBox.Width := xW;
        TMListBox.Height := yH;

        // ListBox erstellen
        TMListBox.hWnd := CreateWindowEx(WS_EX_CLIENTEDGE or WS_EX_TRANSPARENT,
          SKLISTBOX, nil, LStyle, TMListBox.Left, TMListBox.Top, TMListBox.Width, TMListBox.Height,
          hOwner, PlayListID, skInstance, nil);

        if TMListBox.hWnd <> 0 then
        begin
          // HinterGrundBitmap ListBox
          SetImageProperty(TMListBox.hWnd, PROP_IMAGE_BACK, Img);
          // Font erstellen
          TMListBox.hFont := DefaultFont;
          SetCTLFont(TMListBox.hWnd, TMListBox.hFont);
          // Font Object entfernen
          DeleteObject(TMListBox.hFont);
          // Itemhöhe zuweisen
          TMListBox.ItemHeight := 16;
          SendMessage(TMListBox.hWnd, LB_SETITEMHEIGHT, 0, TMListBox.ItemHeight);
          // DrawStyle zuweisen
          TMListBox.DrawStyle := CreateSolidBrush(TMListBox.Backcolor);
          FHOwner := hOwner;

          SubClass(FHOwner);
        end else
          // Image löschen wenn Fehler
          DeleteResource(Img);
      end;
  end;
end;

destructor TListBox.Destroy;
begin
  UnSubClass(FHOwner);

  inherited Destroy;
end;


procedure DrawItem(lP: Integer);
var
  PDis:    PDrawItemStruct;
  DTP:     TDRAWTEXTPARAMS;
  BColor,
  FColor:  COLORREF;
  hBrush:  Integer;
  ItemText: PChar;
  l:       Integer;

begin

  CopyMemory(@PDis, @lP, SizeOf(@PDis));
  ItemText := nil;

    If PDis.itemState <> 0 And ODS_SELECTED Then
    begin
      BColor := SetBkColor(PDis.hDC, TMListBox.BackColorSelected);
      hBrush := CreateSolidBrush(TMListBox.BackColorSelected);
      FColor := SetTextColor(PDis.hDC, TMListBox.ForeColorSelected);
    end else
    begin
      BColor := SetBkColor(PDis.hDC, TMListBox.Backcolor);
      hBrush := CreateSolidBrush(TMListBox.Backcolor);
      FColor := SetTextColor(PDis.hDC, TMListBox.Forecolor);
    end;

    //Img := SkinEngine.GetProperty(TMListBox.hWnd, PROP_IMAGE_BACK);
    //SkinEngine.GetImageSize(Img, ImgW, ImgH);

    //BitBlt(PDis.hDC, PDis.rcItem.Left + 4, PDis.rcItem.Top + 1, 13, 11,
    //       GetDc(Img.Handle), 0, 0, SRCCopy);

    PDis.rcItem.Left := PDis.rcItem.Left + 20;
    FillRect(PDis.hDC, PDis.rcItem, hBrush);

    l := SendMessage(TMListBox.hWnd, LB_GETTEXTLEN, PDis.itemID, 0);

    if l > 0 Then
    begin
      GetMem(ItemText, l + 1);
      SendMessage(TMListBox.hWnd, LB_GETTEXT, PDis.itemID, integer(ItemText));
    end;

    DTP.cbSize := SizeOf(DTP);
    DrawTextEx(PDis.hDC, ItemText, l, PDis.rcItem, DT_LEFT
      Or DT_VCENTER Or DT_SINGLELINE, @DTP);

    SetTextColor(PDis.hDC, FColor);
    SetBkColor(PDis.hDC, BColor);

    DeleteObject(hBrush);
    CopyMemory(@lP, @PDis, SizeOf(@PDis));

end;

function WndProc(WinHandle: HWND; Msg: UINT; wP: WParam; lP: LParam): LRESULT; stdcall;
var
  hList : HWND;
  nItem: Integer;

begin
  with SkinEngine do
  begin
    case msg of
      WM_COMMAND:
      begin
        case HiWord(wP) of
        LBN_DBLCLK:
          begin
            nItem := ListGetCurSel(TMListBox.hWnd);
            hList := GetMainItem(ID_PLAYLISTBOX);
            ListSelectPlus(hList, nItem);
            if nItem > 0 then
            begin

            hList := GetMainItem(ID_PLAYLISTBOX);
            getAudioFile := ListGetText(hList, nItem);
            BassChannelPlay;
          end;
        end;
        end;
        case LoWord(wP) of
          IDM_PlayList:
          begin
            hList := GetMainItem(ID_PLAYLIST);
            if isWindowVisible(hList) then
              begin
                VisBassVis.StartVis(PAnsiChar(PlgFilename));
                ShowWindow(hList, SW_HIDE)
              end else
              begin
                VisBassVis.StopVis;
                SetAnchorMode(hList, ANCHOR_HEIGHT_WIDTH);
                SetZorder(hList, HWND_TOP);
                ShowWindow(hList, SW_SHOW);
              end;
              nItem := LastPlayListTitle;
              ListSelectPlus(hList,nItem);
          end;
        end;
      end;
      WM_MOUSEWHEEL:
      begin
        hList := GetMainItem(ID_PLAYLIST);
        if isWindowVisible(hList) then
          SendMessage(hList, Msg, wP, lP);
      end;
      WM_CTLCOLORLISTBOX:
      begin
        Result := TMListBox.DrawStyle;
        exit;
      end;
      WM_ERASEBKGND:
      begin
        Result := 1;
        exit;
      end;
      WM_DRAWITEM:
      begin
        DrawItem(lP); //Problem geht auf Main WinProc
        Result := CallWindowProc(Pointer(PrevWndProc), WinHandle, Msg, wP, lP);
        exit;
      end;
    end;
    Result := CallWindowProc(Pointer(PrevWndProc), WinHandle, Msg, wP, lP);
  end;

end;

procedure TListBox.SubClass(WinHandle: HWND);
begin
  PrevWndProc := SetWindowLong(WinHandle, GWL_WNDPROC, integer(@WndProc));
  PrevWndProcLB := SetWindowLong(TMListBox.hWnd, GWL_WNDPROC, integer(@ListBoxProc));

end;

procedure TListBox.UnSubClass(WinHandle: HWND);
begin
  SetWindowLong(WinHandle, GWL_WNDPROC, PrevWndProc);
  SetWindowLong(TMListBox.hWnd, GWL_WNDPROC, integer(@ListBoxProc));
end;

function ListBoxProc(WinHandle: HWND; Msg: UINT; wP: WParam; lP: LParam): LRESULT; stdcall;
begin
    Result := CallWindowProc(Pointer(PrevWndProcLB), WinHandle, Msg, wP, lP);

end;


end.
hab mal die ganze Unit reinkopiert.
Aufruf!
Delphi-Quellcode:
    hPlayList := TListBox.Create(hMain, PAnsiChar(SK_FOLDER + 'Panel.png'),
      19, 56, 583, 423, ID_PLAYLIST, SK_ACTIVECAPTION);
hMain = ApplicationsHandle

Mein Problem ist folgendes .
In der WinProc hMain gibt es so wie in der Listbox die Message 'WM_DRAWITEM:'
Rufe ich nun das Menü auf wird seltsamerweise die Funktion DrawItem(lP); an das Menu anstelle der ListBox
übergeben was sich so auswirkt das alle Einträge des selben um 20 Pixel nach rechts verschoben werden.
Bedingt durch diesen aufruf.

Delphi-Quellcode:
    PDis.rcItem.Left := PDis.rcItem.Left + 20;
    FillRect(PDis.hDC, PDis.rcItem, hBrush);
sag mir mal jemand warum ?
Warum wirkt sich die Proc der ListBox auf die der hMain aus. (ja ne blöde frage) ;)
Finde den Fehler einfach nicht.

gruss Emil

Union 28. Jan 2009 18:49

Re: Winproc ärger
 
Vielleicht deswegen:
Delphi-Quellcode:
FHOwner := hOwner;
SubClass(FHOwner);

EWeiss 28. Jan 2009 18:55

Re: Winproc ärger
 
Zitat:

Zitat von Union
Vielleicht deswegen:
Delphi-Quellcode:
FHOwner := hOwner;
SubClass(FHOwner);

Wie begründest du das ?
Das ist dass ParentHandle auf dem die ListBox aufgesetzt ist.

gruss Emil

Sunlight7 28. Jan 2009 18:56

Re: Winproc ärger
 
Ich lehn mich mal weit aism Fenster... (hoffentlich hat wer n Sprungtuch aufgespannt)

Delphi-Quellcode:
procedure DrawItem(lP: Integer);
   ...
   CopyMemory(@lP, @PDis, SizeOf(@PDis));
end
Ganz durchblicke ich Deinen Code nicht auf die Schnelle, aber überschreibst Du damit am Ende von DrawItem nicht die Strukture, die Du im WndProc/WM_DRAWITEM er lParam bekommst mit den veränderten Werten?
Schon ne? :gruebel:

EWeiss 28. Jan 2009 19:12

Re: Winproc ärger
 
Zitat:

Zitat von Sunlight7
Ich lehn mich mal weit aism Fenster... (hoffentlich hat wer n Sprungtuch aufgespannt)

Delphi-Quellcode:
procedure DrawItem(lP: Integer);
   ...
   CopyMemory(@lP, @PDis, SizeOf(@PDis));
end
Ganz durchblicke ich Deinen Code nicht auf die Schnelle, aber überschreibst Du damit am Ende von DrawItem nicht die Strukture, die Du im WndProc/WM_DRAWITEM er lParam bekommst mit den veränderten Werten?
Schon ne? :gruebel:

Ich schreibe ihn wieder zurück .. Jo
Anfang der Function

Delphi-Quellcode:
CopyMemory(@PDis, @lP, SizeOf(@PDis));
Wenn fertig zurücksetzen.
Delphi-Quellcode:
CopyMemory(@lP, @PDis, SizeOf(@PDis));
Kann mir das vereinfachen in dem ich mit dem PDIS auf lP zeige
könnte mir dann CopyMemory sparen.

PDis := Pointer(lP);

Das problem mit dem Menu hab ich geregelt allerdings bekomme ich so kein Event mehr auf die ListBox.
Muss vorher prüfen ob PDis^.CtlType ODT_LISTBOX oder ODT_MENU ist damit kann ich das falsche OwnerDraw abfangen.

gruss Emil

Sunlight7 28. Jan 2009 19:26

Re: Winproc ärger
 
Nun, wenn Du es bereits geköst hast ists egal, aber ich meine, Du kopierst den lp(wParam) nach DPis, dann änderst Du PDis und kopierst das geänderte zurück, deshalb verschiebt sich die Left Position, bei jedem Aufruf von DrawItem.

Oder war das so gewollt?

EWeiss 28. Jan 2009 19:38

Re: Winproc ärger
 
Zitat:

Zitat von Sunlight7
Nun, wenn Du es bereits geköst hast ists egal, aber ich meine, Du kopierst den lp(wParam) nach DPis, dann änderst Du PDis und kopierst das geänderte zurück, deshalb verschiebt sich die Left Position, bei jedem Aufruf von DrawItem.

Oder war das so gewollt?

Jo.
Weil jede zeile für sich 20 Pixel nach rechts verschoben werden muss.
Vor jeden eintrag sollen ja nachher Bitmaps stehen.

Die Funktion wird also so oft aufgerufen wie sich Zeilen in der ListBox befinden.
Nur ich komm nicht rein in ODT_LISTBOX
Muss mal schaun da noch ein aufruf beim erstellen der listBox fehlt.

gruss Emil

lbccaleb 28. Jan 2009 21:25

Re: Winproc ärger
 
Zitat:

Zitat von EWeiss
Mein Problem ist folgendes .
In der WinProc hMain gibt es so wie in der Listbox die Message 'WM_DRAWITEM:'
Rufe ich nun das Menü auf wird seltsamerweise die Funktion DrawItem(lP); an das Menu anstelle der ListBox
übergeben was sich so auswirkt das alle Einträge des selben um 20 Pixel nach rechts verschoben werden.

Also wenn ich mich recht erinnere, ist das so, wenn der wParam Parameter von WM_DRAWITEM "0" ist, dann wird das Menü der Anwendung bearbeitet!

Ich kann so schnell deine Funktion nicht ganz nachverfolgen, aber baue doch mal ne Abfrage auf "0" ein!

Delphi-Quellcode:
if INTEGER(wP) > 0 then DrawItem(lP);
Eventuell musst du auch an anderer Stelle dafür sorgen das wP in dem Fall nicht 0 ist! Aber wie gesagt so genau kenn ich mich da mit deinem Code nicht aus!

Das ist aber nur eine Vermutung... Kein Gewähr^^

mfg

EWeiss 28. Jan 2009 21:41

Re: Winproc ärger
 
Zitat:

Zitat von lbccaleb
Zitat:

Zitat von EWeiss
Mein Problem ist folgendes .
In der WinProc hMain gibt es so wie in der Listbox die Message 'WM_DRAWITEM:'
Rufe ich nun das Menü auf wird seltsamerweise die Funktion DrawItem(lP); an das Menu anstelle der ListBox
übergeben was sich so auswirkt das alle Einträge des selben um 20 Pixel nach rechts verschoben werden.

Also wenn ich mich recht erinnere, ist das so, wenn der wParam Parameter von WM_DRAWITEM "0" ist, dann wird das Menü der Anwendung bearbeitet!

Ich kann so schnell deine Funktion nicht ganz nachverfolgen, aber baue doch mal ne Abfrage auf "0" ein!

Delphi-Quellcode:
if INTEGER(wP) > 0 then DrawItem(lP);
Eventuell musst du auch an anderer Stelle dafür sorgen das wP in dem Fall nicht 0 ist! Aber wie gesagt so genau kenn ich mich da mit deinem Code nicht aus!

Das ist aber nur eine Vermutung... Kein Gewähr^^

mfg

Es gibt da fertige Flags ODT_MENU für Menüs
und ODT_LISTBOX für ListBoxen und einige mehr
ODT_MENU = 1
ODT_LISTBOX = 2 usw.

Abgfragt werden sie
Delphi-Quellcode:
      WM_DRAWITEM:
      begin
        PDis := Pointer(lP);
        case PDis^.CtlType of
          ODT_MENU: // 1 Ownerdrawn menu item
          begin
Mein Problem ist nun das ich nie in ODT_LISTBOX hineinkommme weiss der Teufel warum.
Alle anderen Messagen der ListBox werden Ordnungsgemäß ausgeführt.
MouseWheel usw..

gruss EMil

lbccaleb 28. Jan 2009 21:45

Re: Winproc ärger
 
Was genau meinst du mit du kommst nicht herrein?
Wie gesagt, wenn der Parameter "0" ist, gehts an Menü...


Alle Zeitangaben in WEZ +1. Es ist jetzt 08:53 Uhr.
Seite 1 von 2  1 2      

Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
LinkBacks Enabled by vBSEO © 2011, Crawlability, Inc.
Delphi-PRAXiS (c) 2002 - 2023 by Daniel R. Wolf, 2024 by Thomas Breitkreuz