winsubclass.pas

一个仓库管理软件系统

//Unsubclass : used for unskin, restore old color.

Procedure TSkinControl.Init(sf:Tcomponent;sd:TSkinData;acanvas:TCanvas;acolor:boolean=false);
begin
   if inited then exit;
   newcolor:=acolor;
   fsd:=sd;
   skinform:=sf;
   fCanvas:=acanvas;
   control:=Twincontrol(owner);
   hwnd := control.handle;
   OldWndProc:= Control.WindowProc;
   Control.WindowProc := NewWndProc;
   control.DoubleBuffered:=true;
   Twinskinform(skinform).addcontrollist(self);

   Focused := (GetFocus= hWnd);
   enabled := (GetWindowLong(hWnd,GWL_STYLE) and WS_DISABLED)=0;
   caption:=getformcaption(hwnd);
   if newcolor then begin
      oldcolor:=Taccontrol(control).color;
      Taccontrol(control).color:=fsd.colors[csButtonFace];
   end;
   control.Invalidate;
   inited:=true;
   skinstate:=skin_active;
end;

Procedure TSkinControl.SetColor;
begin
end;

Procedure TSkinControl.RestoreColor;
begin
end;

Procedure TSkinControl.Inithwnd(ahwnd:Thandle;sd:TSkinData;acanvas:TCanvas;sf:Tcomponent);
begin
   fsd:=sd;
   fCanvas:=acanvas;
   skinform:=sf;
   hwnd := ahwnd;
   enabled:=true;
   Twinskinform(skinform).addcontrollist(self);
   caption:=getformcaption(hwnd);
   FObjectInst := MakeObjectInstance(NewWndProc);
   FPrevWndProc := Pointer(GetWindowLong(hwnd,GWL_WNDPROC));
   SetWindowLong(hwnd, GWL_WNDPROC,LongInt(FObjectInst));
   inited := true;
   skinstate:=skin_active;
end;

Procedure TSkinControl.Unsubclass;
begin
   if newcolor then begin
         Taccontrol(control).color:=oldcolor;
   end;
end;

Procedure TSkinControl.SkinChange;
begin
   if newcolor and (control<>nil) then
     Taccontrol(control).color:=fsd.colors[csButtonFace];
   if hwnd<>0 then
     InvalidateRect(hwnd, 0,true)
   else if GControl<>nil then
      gcontrol.Invalidate;
end;

destructor TSkinControl.Destroy;
var s:string;
begin
{     s:=caption;
     if control<>nil then s:=s+' '+control.ClassName;
     if gcontrol<>nil then s:=s+' '+gcontrol.ClassName;
     skinaddlog('skincontrol destory '+s); }

   if assigned(oldwndproc) then begin
         if control<>nil then Control.WindowProc := OldWndProc;
         oldwndproc:=nil;
   end;
   if fobjectinst<>nil then begin
         SetWindowLong(hwnd, GWL_WNDPROC,LongInt(FPrevWndProc));
         FreeObjectInstance(FObjectInst);
         fobjectinst:=nil;
   end;

   if skinform<>nil then Twinskinform(skinform).DeleteControl(self);
   inherited destroy;
end;

{procedure TSkinControl.NewWndProc(var Message: TMessage);
begin
  done:=false;
  BeforeProc(message);
  if done then exit;
  OldWndProc(Message);
  AfterProc(message);
end;}

procedure TSkinControl.NewWndProc(var Message: TMessage);
var s:string;
begin
  done:=false;
  if skinned then begin
     if BeforeProc(message) then begin
       default(Message);
       AfterProc(message);
     end;
  end else if message.msg=CN_SkinEnabled then begin
       skinned:=message.WParam>0;
       if skinned then Invalidate;
  end else default(Message);
end;

procedure TSkinControl.Default(Var Msg: TMessage);
begin
  if assigned(oldwndproc) then
         OldWndProc(Msg)
  else
     msg.result:=CallWindowProc(FPrevWndProc,hwnd,Msg.msg,msg.WParam,msg.LParam);
end;

procedure TSkinControl.MouseLeave;
begin
  if hwnd>0 then sendmessage(hwnd,CM_MOUSELEAVE,0,0);
//  Twinskinform(owner).activeskincontrol:=nil;
end;

procedure TSkinControl.Invalidate;
var phwnd:Thandle;
    r:Trect;
begin
//  PaintControl;
//  phwnd:= getparent(hwnd);
  if getwindowrect(hwnd,r) then begin
    offsetrect(r,-r.left,-r.top);
    if phwnd<>0 then begin
       InvalidateRect(hwnd, @R,false);
       UpdateWindow(hwnd);
    end;
  end;
end;

procedure TSkinControl.PaintControl(adc:HDC=0);
var dc:HDC ;
    rc:TRect;
begin
  if GetWindowRect( hWnd, rc ) then begin;
    try
      boundsrect:=rc;
      OffsetRect( rc, -rc.left, -rc.top );
      if adc=0 then  DC := GetWindowDC( hWnd )
      else dc:=adc;
      try
         Drawcontrol(dc,rc);
      finally
         if adc=0 then ReleaseDC( hwnd, DC );
      end;
    except
    end;
  end;
end;

procedure TSkinControl.FillBG( dc:HDC; rc:TRect);
var  Brush: HBrush;
begin
    Brush := CreateSolidBrush(fsd.colors[csButtonFace]);
    try
      fillrect(dc,rc,brush);
    finally
      DeleteObject(Brush);
    end;
end;

procedure TSkinControl.doLogMsg(aid:string;msg:TMessage);
var s:string;
begin
  {$IFDEF test}
    s:=MsgtoStr(msg);
    if s='' then exit;
    if SkinCanLog then Logstring.add(aid+s);
  {$ENDIF}
end;

procedure TSkinControl.AfterProc(var Message: TMessage);
begin
    case message.msg of
      WM_Paint:
         PaintControl(message.WParam);
{      WM_NCPaint:
         PaintControl(message.WParam);
      WM_Print:
         PaintControl(message.WParam);  }
      WM_KILLFOCUS,WM_SETFOCUS:Invalidate;
//          PaintControl;
      WM_SETTEXT: begin
           caption := strpas(pchar(message.lParam));
           Invalidate;
         end;
      CN_SkinEnabled :skinned := message.WParam>0;
      wm_enable,CM_ENABLEDCHANGED:Invalidate;
{      WM_NCDESTROY:begin
          //Unsubclass;
         end; }
    end;
end;

function TSkinControl.BeforeProc(var Message: TMessage):boolean;
begin
   result:=false;
   case message.msg of
      WM_NCDESTROY:begin
          result:=false;
          default(message);
          skinstate:=skin_deleted;
          Unsubclass;
          //can't free,leave it,until skinform free;
          //         free;
         end;
      else result:=true;
   end;
end;

procedure TSkinControl.DrawControl( dc:HDC; rc:TRect);
begin
end;

function  TSkinControl.GetState:integer;
begin
   result:=1;
end;

function  GetProperty(control: TObject ;aprop:string):string;
var PropInfo:PPropInfo;
    s:string;
    i:integer;
begin
   s:='';
   i:=0;
   if  control<>nil then begin
      PropInfo:=GetPropInfo(control,aprop);
      if PropInfo<>nil then  begin
         if propinfo^.PropType^.Kind= tkEnumeration then
          s:=GetEnumProp(control,PropInfo)
         else if propinfo^.PropType^.Kind = tkInteger then begin
//           i:= GetInt64Prop(control,PropInfo);
           i:=GetOrdProp(control,PropInfo);
           s:=inttostr(i);
         end;
      end;
   end;
   result := s;
end;

function  GetIntProperty(control: TObject ;aprop:string):integer;
var PropInfo:PPropInfo;
begin
   result:= 0;
   if  control<>nil then begin
      PropInfo:=GetPropInfo(control,aprop);
      if (PropInfo<>nil) and
         (propinfo^.PropType^.Kind = tkInteger) then begin
//           i:= GetInt64Prop(control,PropInfo);
           result :=GetOrdProp(control,PropInfo);
      end;
   end;
end;

function  GetEnumProperty(control: TObject;aprop:string):string;
var PropInfo:PPropInfo;
begin
   result:= '';
   if  control<>nil then begin
      PropInfo:=GetPropInfo(control,aprop);
      if (PropInfo<>nil) then
           result := GetEnumProp(control,PropInfo);
   end;
end;

{$IFNDEF COMPILER_6_UP}
procedure AssignWideStr(var Dest: WideString; const Source: WideString);
begin
  Dest := Source;
end;

procedure IntGetWideStrProp(Instance: TObject; PropInfo: PPropInfo;
  var Value: WideString); assembler;
asm
        { ->    EAX Pointer to instance         }
        {       EDX Pointer to property info    }
        {       ECX Pointer to result string    }

        PUSH    ESI
        PUSH    EDI
        MOV     EDI,EDX

        MOV     EDX,[EDI].TPropInfo.Index       { pass index in EDX }
        CMP     EDX,$80000000
        JNE     @@hasIndex
        MOV     EDX,ECX                         { pass value in EDX }
@@hasIndex:
        MOV     ESI,[EDI].TPropInfo.GetProc
        CMP     [EDI].TPropInfo.GetProc.Byte[3],$FE
        JA      @@isField
        JB      @@isStaticMethod

@@isVirtualMethod:
        MOVSX   ESI,SI                          { sign extend slot offset }
        ADD     ESI,[EAX]                       { vmt + slot offset }
        CALL    DWORD PTR [ESI]
        JMP     @@exit

@@isStaticMethod:
        CALL    ESI
        JMP     @@exit

@@isField:
  AND  ESI,$00FFFFFF
  MOV  EDX,[EAX+ESI]
  MOV  EAX,ECX
  CALL  AssignWideStr

@@exit:
        POP     EDI
        POP     ESI
end;

function GetWideStrProp(Instance: TObject; PropInfo: PPropInfo): WideString;
begin
  IntGetWideStrProp(Instance, PropInfo, Result);
end;

procedure SetWideStrProp(Instance: TObject; PropInfo: PPropInfo;
  const Value: WideString); assembler;
asm
        { ->    EAX Pointer to instance         }
        {       EDX Pointer to property info    }
        {       ECX Pointer to string value     }

        PUSH    ESI
        PUSH    EDI
        MOV     ESI,EDX

        MOV     EDX,[ESI].TPropInfo.Index       { pass index in EDX }
        CMP     EDX,$80000000
        JNE     @@hasIndex
        MOV     EDX,ECX                         { pass value in EDX }
@@hasIndex:
        MOV     EDI,[ESI].TPropInfo.SetProc
        CMP     [ESI].TPropInfo.SetProc.Byte[3],$FE
        JA      @@isField
        JB      @@isStaticMethod

@@isVirtualMethod:
        MOVSX   EDI,DI
        ADD     EDI,[EAX]
        CALL    DWORD PTR [EDI]
        JMP     @@exit

@@isStaticMethod:
        CALL    EDI
        JMP     @@exit

@@isField:
  AND  EDI,$00FFFFFF
  ADD  EAX,EDI
  MOV  EDX,ECX
  CALL  AssignWideStr

@@exit:
        POP     EDI
        POP     ESI
end;
{$ENDIF}

function  GetStringProp(control: TObject;aprop:string):widestring;
var PropInfo:PPropInfo;
    s:string;
begin
   result:='';
   if  control<>nil then begin
      PropInfo:=GetPropInfo(control,aprop);
      if PropInfo<>nil then  begin
        case PropInfo^.PropType^.Kind of
          tkWString: result := GetWideStrProp(control,PropInfo);
          else  result:=StrToWideStr(GetStrProp(control,PropInfo));
        end;
      end;
   end;
end;

function  GetObjMethod(control: TObject;aprop:string): TMethod;
var PropInfo:PPropInfo;
begin
//   result:=nil;
   if  control<>nil then begin
      PropInfo:=GetPropInfo(control,aprop);
      if PropInfo<>nil then  begin
        result:=GetMethodProp(control,PropInfo);
      end;
   end;
end;

function GetObjProp(control: TObject;aprop:string; MinClass: TClass):Tobject;
var PropInfo:PPropInfo;
begin
   result:=nil;
   if  control<>nil then begin
      PropInfo:=GetPropInfo(control,aprop);
      if PropInfo<>nil then  begin
        result:=GetObjectProp(control,PropInfo,MinClass);
      end;
   end;
end;

function TSkinButton.BeforeProc(var Message: TMessage):boolean;
 var s:string;
     sf: Twinskinform;
begin
  {$IFDEF buttontest}