supercls.pas

这一系列是我平时收集的pascal深入核心编程

unit SuperCls;

interface

uses Windows;

 // 注册superclass
function SuperCls_RegisterClassEx(pwc: PWndClassEx; pfnWndProcSuperCls: Pointer;
  cbClsAdditional, cbWndAdditional: Integer): ATOM; stdcall;

 // 取基类窗口过程
function SuperCls_GetWndProcBaseCls(hWnd: HWND): Pointer; stdcall;

 // 不影响基类的类别额外内存读写函数集
function SuperCls_SetClassWord(hWnd: HWND; nIndex: Integer; wNewWord: WORD):WORD ; stdcall;
function SuperCls_GetClassWord(hWnd: HWND; nIndex: Integer):WORD ; stdcall;
function SuperCls_SetClassLong(hWnd: HWND; nIndex: Integer; dwNewLong: DWORD):DWORD ; stdcall;
function SuperCls_GetClassLong(hWnd: HWND; nIndex: Integer):DWORD ; stdcall;

 // 不影响基类的窗体额外内存读写函数集
function SuperCls_SetWindowWord(hWnd: HWND; nIndex: Integer; wNewWord: WORD):WORD ; stdcall;
function SuperCls_GetWindowWord(hWnd: HWND; nIndex: Integer):WORD ; stdcall;
function SuperCls_SetWindowLong(hWnd: HWND; nIndex: Integer; dwNewLong: DWORD):DWORD ; stdcall;
function SuperCls_GetWindowLong(hWnd: HWND; nIndex: Integer):DWORD ; stdcall;

implementation

type
 // 类别额外内存结构
 // 此结构体放在尾部
  T_SuperCls_BaseClsInfo = packed record
    pfnWndProcBaseCls: Pointer; // 基类窗体过程
    cbClsExtraBaseCls: Integer; // 基类类别空间
    cbWndExtraBaseCls: Integer; // 基类实例空间
  end;

 // 注册superclass
function SuperCls_RegisterClassEx(pwc: PWndClassEx; pfnWndProcSuperCls: Pointer;
  cbClsAdditional, cbWndAdditional: Integer): ATOM; stdcall;
var
  hWnd: LongWord; // HWND
  pfnWndProcBaseCls: Pointer;
  cbClsExtraBaseCls: Integer;
  cbWndExtraBaseCls: Integer;
begin
 // 基类基本信息
  pfnWndProcBaseCls := pwc.lpfnWndProc; // 基类窗体过程
  cbClsExtraBaseCls := pwc.cbClsExtra;  // 基类类别空间
  cbWndExtraBaseCls := pwc.cbWndExtra;  // 基类实例空间

 // 增加类别空间
  Inc(pwc.cbClsExtra, cbClsAdditional + SizeOf(T_SuperCls_BaseClsInfo));

 // 增加实例空间
  Inc(pwc.cbWndExtra, cbWndAdditional);

 // 现在需要设置类别空间尾部的T_SuperCls_BaseClsInfo结构,
 // 系统并没有提供直接设置的函数, 需要先建一个'傀儡'窗体,
 // DefWindowProc不会设置额外控件, 所以先将窗口过程指向它
  pwc.lpfnWndProc := @DefWindowProc;

 // 注册superclass
  Result := RegisterClassEx(pwc^);
  if (Result = INVALID_ATOM) then Exit;

 // 建立'傀儡'窗口
  hWnd := CreateWindowEx(0, MakeIntAtom(Result), nil,
    0, 0, 0, 0, 0, 0, 0, pwc.hInstance, nil);

  if (IsWindow(hWnd) = FALSE) then
  begin
   // 返回'注册失败'
    UnregisterClass(MakeIntAtom(Result), pwc.hInstance);
    Result := INVALID_ATOM;
  end else
  begin
   // 设置尾部T_SuperCls_BaseClsInfo结构
    SetClassLong(hWnd, pwc.cbClsExtra - SizeOf(Integer) * 3, Integer(pfnWndProcBaseCls));
    SetClassLong(hWnd, pwc.cbClsExtra - SizeOf(Integer) * 2, cbClsExtraBaseCls);
    SetClassLong(hWnd, pwc.cbClsExtra - SizeOf(Integer), cbWndExtraBaseCls);

   // 设置控件类窗口过程为指定窗口过程
   // 注: 现在建立的控件都以pfnWndProcSuperCls为窗口过程 ..
    SetClassLong(hWnd, GCL_WNDPROC, Integer(pfnWndProcSuperCls));


   // 类别额外内存已经设置完毕, 现在清除这个'傀儡'窗口,
   // WM_DESTROY/WM_NCDESTROY消息将发给DefWindowProc(),
   // 因为SetClassLong()不会影响已经建立的窗口 .. :-)
    DestroyWindow(hWnd);
  end;
end;

 // 取基类窗口过程
function SuperCls_GetWndProcBaseCls(hWnd: HWND): Pointer; stdcall;
begin
 // 返回pfnWndProcBaseCls成员
  Result := Pointer(GetClassLong(hWnd, GetClassLong(hWnd, GCL_CBCLSEXTRA) - SizeOf(Integer) * 3));
end;

 // 不影响基类的偏移
function SuperCls_ClassByteIndex(hWnd: HWND; nIndex: Integer): Integer;
var
  cbClsExtraIndexBaseCls, cbClsExtraBaseCls: Integer;
begin
 // 负数为预定常量
  if (nIndex < 0) then begin Result := nIndex; Exit; end;

 // cbClsExtraBaseCls成员位置
  cbClsExtraIndexBaseCls := GetClassLong(hWnd, GCL_CBCLSEXTRA) - SizeOf(Integer) * 2;

 // cbClsExtraBaseCls成员数值
  cbClsExtraBaseCls := GetClassLong(hWnd, cbClsExtraIndexBaseCls);

 // 不影响基类的偏移
  Result := nIndex + cbClsExtraBaseCls;
end;

 // 不影响基类的SetClassWord
function SuperCls_SetClassWord(hWnd: HWND; nIndex: Integer; wNewWord: WORD): WORD; stdcall;
begin
  Result := SetClassWord(hWnd, SuperCls_ClassByteIndex(hWnd, nIndex), wNewWord);
end;

 // 不影响基类的GetClassWord
function SuperCls_GetClassWord(hWnd: HWND; nIndex: Integer): WORD; stdcall;
begin
  Result := GetClassWord(hWnd, SuperCls_ClassByteIndex(hWnd, nIndex));
end;

 // 不影响基类的SetClassLong
function SuperCls_SetClassLong(hWnd: HWND; nIndex: Integer; dwNewLong: DWORD): DWORD; stdcall;
begin
  Result := SetClassLong(hWnd, SuperCls_ClassByteIndex(hWnd, nIndex), dwNewLong);
end;

 // 不影响基类的GetClassLong
function SuperCls_GetClassLong(hWnd: HWND; nIndex: Integer): DWORD; stdcall;
begin
  Result := GetClassLong(hWnd, SuperCls_ClassByteIndex(hWnd, nIndex));
end;

 // 不影响基类的偏移
function SuperCls_WindowByteIndex(hWnd: HWND; nIndex: Integer): Integer;
var
  cbWndExtraIndexBaseCls, cbWndExtraBaseCls: Integer;
begin
 // 负数为预定常量
  if (nIndex < 0) then begin Result := nIndex; Exit; end;

 // cbWndExtraBaseCls成员位置
  cbWndExtraIndexBaseCls := GetClassLong(hWnd, GCL_CBCLSEXTRA) - SizeOf(Integer);

 // cbWndExtraBaseCls成员数值
  cbWndExtraBaseCls := GetClassLong(hWnd, cbWndExtraIndexBaseCls); // GetClassLong **

 // 不影响基类的偏移
  Result := nIndex + cbWndExtraBaseCls;
end;

 // 不影响基类的SetWindowWord
function SuperCls_SetWindowWord(hWnd: HWND; nIndex: Integer; wNewWord: WORD): WORD; stdcall;
begin
  Result := SetWindowWord(hWnd, SuperCls_WindowByteIndex(hWnd, nIndex), wNewWord);
end;

 // 不影响基类的GetWindowWord
function SuperCls_GetWindowWord(hWnd: HWND; nIndex: Integer): WORD; stdcall;
begin
  Result := GetWindowWord(hWnd, SuperCls_WindowByteIndex(hWnd, nIndex));
end;

 // 不影响基类的SetWindowLong
function SuperCls_SetWindowLong(hWnd: HWND; nIndex: Integer; dwNewLong: DWORD): DWORD; stdcall;
begin
  Result := SetWindowLong(hWnd, SuperCls_WindowByteIndex(hWnd, nIndex), dwNewLong);
end;

 // 不影响基类的GetWindowLong
function SuperCls_GetWindowLong(hWnd: HWND; nIndex: Integer): DWORD; stdcall;
begin
  Result := GetWindowLong(hWnd, SuperCls_WindowByteIndex(hWnd, nIndex));
end;

end.