Klassenmethode in einem Event aufrufen.

[KodeZwerg]

Hallo liebe Gemeinde, ich versuche gerade eine nicht visuelle Klasse zu erstellen mit der man wild Knipsen kann.
Es klappt soweit alles ganz gut.
Als ich mir einen Hotkey-Handler eingebaut habe, funktioniert kein Aufruf dieser Klassenmethode.
Kann mir jemand bitte etwas Hilfestellung geben?

Die betroffene Quelltext-Stelle:

Delphi-Quellcode:

  function MsgWndProc(fWnd: HWND; fMsg: UINT; fWParam: WPARAM; fLParam: LPARAM): LRESULT; stdcall;
  begin
    Result := 0;
    if (fWParam = kzHotkeyID) then
    begin
      MessageBox(0, 'Hotkey', 'Hotkey', MB_OK); // nur um zu sehen ob ich im Hotkey bin
      Shot; // hier knallt es
      Result := 1;
    end
    else
      Result := DefWindowProc(fWnd, fMsg, fWParam, fLParam);
  end;

Der Komplette Quelltext:

Delphi-Quellcode:

unit kz.Windows.ScreenShot;

interface

uses
  Winapi.Windows, Winapi.Messages,
  System.SysUtils, System.Classes,
  Vcl.Clipbrd, Vcl.Graphics;

function GetProcessImageFileName(hProcess: THandle; lpImageFileName: LPTSTR; nSize: DWORD): DWORD; stdcall; external 'PSAPI.dll' name 'GetProcessImageFileNameW';

const
  kzHotkeyID = WM_APP + 1234;

type
  TkzMessageEvent = procedure(ASender: TObject) of object;
  TkzScreenShot = class(TObject)
    const
      CMsgWindowClassName : string = 'KZMsgWndCls';
      CWindowName         : string = 'KZHidden';
    strict private
      FOnMessage:      TkzMessageEvent;
      FImageHeight:    Integer;
      FImageWidth:     Integer;
      FBorderHeight:   Integer;
      FBorderWidth:    Integer;
      FImage:          TBitmap;
      FCanvas:         TCanvas;
      FClientRect:     TRect;
      FRect:           TRect;
      FCaption:        string;
      FFilename:       string;
      FPID:            DWORD;
      FHWND:           HWND;
      FGetFocused:     Boolean;
      FCutAllBorders:  Boolean;
      FCutLeft:        Boolean;
      FCutRight:       Boolean;
      FCutTop:         Boolean;
      FCutBottom:      Boolean;
      FSuccess:        Boolean;
      FHotkey:         Cardinal;
      FModAlt:         Boolean;
      FModCtrl:        Boolean;
      FModShift:       Boolean;
      FModWin:         Boolean;
      FModNR:          Boolean;
      FModifier:       UINT;
      FAutoClipboard:  Boolean;
      FMsgWindowClass: TWndClass;
      FMessageHandle:  THandle;
    private
      function GetBorderHeight: Integer;
      function GetBorderWidth: Integer;
      procedure SetCutAllBorders(const AValue: Boolean);
      procedure SetCutLeft(const AValue: Boolean);
      procedure SetCutRight(const AValue: Boolean);
      procedure SetCutTop(const AValue: Boolean);
      procedure SetCutBottom(const AValue: Boolean);
      procedure SetHotkey(const AValue: Cardinal);
      procedure SetModAlt(const AValue: Boolean);
      procedure SetModCtrl(const AValue: Boolean);
      procedure SetModShift(const AValue: Boolean);
      procedure SetModWin(const AValue: Boolean);
      procedure SetModNR(const AValue: Boolean);
    protected
      function AllocateHWND: THandle;
    public
      constructor Create(const AFormHWND: HWND);
      destructor Destroy; Override;
      procedure Reset;
      procedure Shot;
      procedure CopyToClipboard;
    public
      property OnMessage: TkzMessageEvent read FOnMessage write FOnMessage;
      property Success: Boolean read FSuccess;
      property Image: TBitmap read FImage;
      property AutoToClipboard: Boolean read FAutoClipboard write FAutoClipboard;
      property ImageHeight: Integer read FImageHeight;
      property ImageWidth: Integer read FImageWidth;
      property BorderHeight: Integer read GetBorderHeight write FBorderHeight;
      property BorderWidth: Integer read GetBorderWidth write FBorderWidth;
      property GetFocused: Boolean read FGetFocused write FGetFocused;
      property Caption: string read FCaption;
      property Filename: string read FFilename;
      property ProcessID: DWORD read FPID;
      property ProcessHWND: HWND read FHWND;
      property CutAllBorders: Boolean read FCutAllBorders write SetCutAllBorders;
      property CutLeftBorder: Boolean read FCutLeft write SetCutLeft;
      property CutRightBorder: Boolean read FCutRight write SetCutRight;
      property CutTopBorder: Boolean read FCutTop write SetCutTop;
      property CutBottomBorder: Boolean read FCutBottom write SetCutBottom;
      property Hotkey: Cardinal read FHotkey write SetHotkey;
      property HotkeyModifierAlt: Boolean read FModAlt write SetModAlt;
      property HotkeyModifierControl: Boolean read FModCtrl write SetModCtrl;
      property HotkeyModifierShift: Boolean read FModShift write SetModShift;
      property HotkeyModifierWin: Boolean read FModWin write SetModWin;
      property HotkeyModifierNoRepeat: Boolean read FModNR write SetModNR;
  end;

implementation

resourcestring
  SFailedToRegisterWindowClass = 'Failed to register message window class';
  SFailedToCreateWindow        = 'Failed to create message window %s';
const
  MSG_WND_CLASSNAME : PChar = 'KZMsgWindowCls';

constructor TkzScreenShot.Create;
begin
  inherited Create;
  Reset;
  FImage             := TBitmap.Create;
  FImage.PixelFormat := TPixelFormat.pfDevice;
  FCanvas            := TCanvas.Create;
  FOnMessage         := nil;
  FHotkey            := 0;
  FModifier          := 0;
  FModAlt            := False;
  FModCtrl           := False;
  FModShift          := False;
  FModWin            := False;
  FModNR             := False;
  FMessageHandle     := AllocateHWND;
  GetBorderHeight;
  GetBorderWidth;
end;

destructor TkzScreenShot.Destroy;
begin
  UnregisterHotKey(FMessageHandle, kzHotkeyID);
  Reset;
  FOnMessage := nil;
  FImage.Free;
  FCanvas.Free;
  DestroyWindow(FMessageHandle);
  inherited Destroy;
end;

procedure TkzScreenShot.Reset;
begin
  FImageHeight   := 0;
  FImageWidth    := 0;
  FBorderHeight  := 0;
  FBorderWidth   := 0;
  FPID           := 0;
  FHWND          := 0;
  FCaption       := '';
  FFilename      := '';
  FGetFocused    := True;
  FSuccess       := False;
  FAutoClipboard := False;
  FCutAllBorders := False;
  FCutLeft       := False;
  FCutRight      := False;
  FCutTop        := False;
  FCutBottom     := False;
  FClientRect.Empty;
  FRect.Empty;
end;

function TkzScreenShot.GetBorderHeight: Integer;
begin
  FBorderHeight := GetSystemMetrics(SM_CXDLGFRAME) + GetSystemMetrics(SM_CXSIZEFRAME) + GetSystemMetrics(SM_CXEDGE);
  Result := FBorderHeight;
end;

function TkzScreenShot.GetBorderWidth: Integer;
begin
  FBorderWidth := GetSystemMetrics(SM_CYDLGFRAME) + GetSystemMetrics(SM_CYSIZEFRAME) + GetSystemMetrics(SM_CYEDGE);
  Result := FBorderWidth;
end;

procedure TkzScreenShot.SetCutAllBorders(const AValue: Boolean);
begin
  FCutAllBorders := AValue;
  if AValue then
    begin
      FCutLeft       := False;
      FCutRight      := False;
      FCutTop        := False;
      FCutBottom     := False;
    end;
end;

procedure TkzScreenShot.SetCutLeft(const AValue: Boolean);
begin
  FCutLeft := AValue;
  if AValue then
    FCutAllBorders := False;
end;

procedure TkzScreenShot.SetCutRight(const AValue: Boolean);
begin
  FCutRight := AValue;
  if AValue then
    FCutAllBorders := False;
end;

procedure TkzScreenShot.SetCutTop(const AValue: Boolean);
begin
  FCutTop := AValue;
  if AValue then
    FCutAllBorders := False;
end;

procedure TkzScreenShot.SetCutBottom(const AValue: Boolean);
begin
  FCutBottom := AValue;
  if AValue then
    FCutAllBorders := False;
end;

procedure TkzScreenShot.Shot;
  function GetWindowPath(const AHWND: HWND): string;
    function GetPIDbyHWND(const AHWND: HWND): DWORD;
    var
      PID: DWORD;
    begin
      if (AHWND <> 0) then
        begin
          GetWindowThreadProcessID(AHWND, @PID);
          Result := PID;
        end
        else
          Result := 0;
      FPID := Result;
    end;
    function PhysicalToVirtualPath(APath: string): string;
    var
      i          : integer;
      ADrive     : string;
      ABuffer    : array[0..MAX_PATH - 1] of Char;
      ACandidate : string;
    begin
      {$I-}
      for I := 0 to 25 do
        begin
          ADrive := Format('%s:', [Chr(Ord('A') + i)]);
          if (QueryDosDevice(PWideChar(ADrive), ABuffer, MAX_PATH) = 0) then
            Continue;
          ACandidate := string(ABuffer).ToLower();
          if (string(Copy(APath, 1, Length(ACandidate))).ToLower() = ACandidate) then
            begin
              Delete(APath, 1, Length(ACandidate));
              Result := Format('%s%s', [ADrive, APath]);
            end;
        end;
      {$I+}
    end;
  var
    AHandle: THandle;
    ALength    : Cardinal;
    AImagePath : String;
  const
    PROCESS_QUERY_LIMITED_INFORMATION = $00001000;
  begin
    Result := '';
    AHandle := OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION, False, GetPIDbyHWND(AHWND));
    if (AHandle = 0) then
      Exit;
    try
      SetLength(AImagePath, MAX_PATH);
      ALength := GetProcessImageFileName(AHandle, @AImagePath[1], MAX_PATH);
      if (ALength > 0) then
        begin
          SetLength(AImagePath, ALength);
          Result := PhysicalToVirtualPath(AImagePath);
        end;
    finally
      CloseHandle(AHandle);
    end;
  end;
  function GetWindowTitle(const AHWND: HWND): string;
  var
    LTitle: string;
    LLen: Integer;
  begin
    Result := '';
    LLen := GetWindowTextLength(AHWND) + 1;
    SetLength(LTitle, LLen);
    GetWindowText(AHWND, PChar(LTitle), LLen);
    Result := Trim(LTitle);
  end;
var
  ShotDC: HDC;
begin
  FSuccess := False;
  if FGetFocused then
    FHWND := GetForegroundWindow
    else
    FHWND := GetDesktopWindow;
  try
    FCaption := GetWindowTitle(FHWND);
    FFilename := GetWindowPath(FHWND);
    GetWindowRect(FHWND, FRect);
    GetClientRect(FHWND, FClientRect);
    if (FCutAllBorders or FCutLeft or FCutRight or FCutTop or FCutBottom) then
      if FCutAllBorders then
        begin
          FRect.Left   := FRect.Left + BorderWidth;
          FRect.Right  := FRect.Right - BorderWidth;
          FRect.Top    := FRect.Top + BorderHeight;
          FRect.Bottom := FRect.Bottom - BorderHeight;
        end
        else
        begin
          if FCutLeft then
            FRect.Left   := FRect.Left + BorderWidth;
          if FCutRight then
            FRect.Right  := FRect.Right - BorderWidth;
          if FCutTop then
            FRect.Top    := FRect.Top + BorderHeight;
          if FCutBottom then
            FRect.Bottom := FRect.Bottom - BorderHeight;
        end;
    FImageWidth  := FRect.Right - FRect.Left;
    FImageHeight := FRect.Bottom - FRect.Top;
    ShotDC := GetDCEx(0, 0, DCX_WINDOW or DCX_PARENTCLIP or DCX_CLIPSIBLINGS or DCX_CLIPCHILDREN);
    try
      FImage.Width := FImageWidth;
      FImage.Height := FImageHeight;
      FCanvas.Handle := ShotDC;
      FImage.Canvas.CopyMode := cmSrcCopy;
      FImage.Canvas.CopyRect(
            Rect(0, 0, FImageWidth, FImageHeight),
            FCanvas,
            Rect(FRect.Left,
                 FRect.Top,
                 FRect.Right,
                 FRect.Bottom));
      if FAutoClipboard then
        CopyToClipboard;
      FImage.Dormant;
      FImage.FreeImage;
    finally
      ReleaseDC(0, ShotDC);
    end;
  finally
    if Assigned(FOnMessage) then
      FOnMessage(Self);
    FSuccess := True;
  end;
end;

procedure TkzScreenShot.SetHotkey(const AValue: Cardinal);
begin
  UnregisterHotKey(FMessageHandle, kzHotkeyID);
  FHotkey := AValue;
  RegisterHotkey(FMessageHandle, kzHotkeyID, FModifier, FHotkey);
end;

procedure TkzScreenShot.SetModAlt(const AValue: Boolean);
begin
  FModAlt := AValue;
  if FModAlt then
    FModifier := FModifier + MOD_ALT
    else
    FModifier := FModifier - MOD_ALT;
  SetHotkey(FHotkey);
end;

procedure TkzScreenShot.SetModCtrl(const AValue: Boolean);
begin
  FModCtrl := AValue;
  if FModCtrl then
    FModifier := FModifier + MOD_CONTROL
    else
    FModifier := FModifier - MOD_CONTROL;
  SetHotkey(FHotkey);
end;

procedure TkzScreenShot.SetModShift(const AValue: Boolean);
begin
  FModShift := AValue;
  if FModShift then
    FModifier := FModifier + MOD_SHIFT
    else
    FModifier := FModifier - MOD_SHIFT;
  SetHotkey(FHotkey);
end;

procedure TkzScreenShot.SetModWin(const AValue: Boolean);
begin
  FModWin := AValue;
  if FModWin then
    FModifier := FModifier + MOD_WIN
    else
    FModifier := FModifier - MOD_WIN;
  SetHotkey(FHotkey);
end;

procedure TkzScreenShot.SetModNR(const AValue: Boolean);
begin
  FModNR := AValue;
  if FModNR then
    FModifier := FModifier or MOD_NOREPEAT
    else
    FModifier := FModifier and not MOD_NOREPEAT;
  SetHotkey(FHotkey);
end;

procedure TkzScreenShot.CopyToClipboard;
var
  Clipboard: TClipboard;
begin
  if (not FSuccess) then
    Exit;
  Clipboard := TClipBoard.Create;
  try
    Clipboard.Assign(FImage);
  finally
    ClipBoard.Free;
  end;
end;

function TkzScreenShot.AllocateHWND: THandle;
  function MsgWndProc(fWnd: HWND; fMsg: UINT; fWParam: WPARAM; fLParam: LPARAM): LRESULT; stdcall;
  begin
    Result := 0;
    if (fWParam = kzHotkeyID) then
    begin
      MessageBox(0, 'Hotkey', 'Hotkey', MB_OK); // nur um zu sehen ob ich im Hotkey bin
      Shot; // hier knallt es
      Result := 1;
    end
    else
      Result := DefWindowProc(fWnd, fMsg, fWParam, fLParam);
  end;
var
  WC : TWndClass;
  msg: TMsg;
begin
  Pointer(FMsgWindowClass.lpfnWndProc) := @MsgWndProc;
  FMsgWindowClass.hInstance            := HInstance; // Handle of this instance
  FMsgWindowClass.lpszClassName        := PChar(CMsgWindowClassName);
  if not GetClassInfo(HInstance, MSG_WND_CLASSNAME, WC)
    and (Winapi.Windows.RegisterClass(FMsgWindowClass) = 0) then
      raise Exception.Create(SFailedToRegisterWindowClass);
  Result := CreateWindowEx(
    WS_EX_TOOLWINDOW,
    PChar(CMsgWindowClassName),
    PChar(CWindowName),
    WS_POPUP,
    0,
    0,
    0,
    0,
    0,
    0,
    HInstance,
    nil
  );
  if Result <> 0 then
    SetWindowLongPtr(Result, 0, NativeInt(Self))
  else
    raise Exception.CreateFmt(SFailedToCreateWindow, [CWindowName]);
end;

end.