winsubclass.pas

这是VCLSKIN v4.22 的所有的源代码

        if value then begin
          s:=lowercase(GetEnumProp(control,PropInfo));
          if s='true' then parentbk:=true
          else parentbk:=false;
          if parentbk then
             SetProperty(control,'ParentBackground','False');
        end else begin
          if parentbk then
             SetProperty(control,'ParentBackground','True');
        end;
     end;
{$endif}
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;
   kind := 0;
   Twinskinform(skinform).addcontrollist(self);
   isunicode:=IsWindowUnicode(hwnd);
   caption:=getformcaption(hwnd);
   FObjectInst := MakeObjectInstance(NewWndProc);
   if isunicode then begin
      FPrevWndProc := Pointer(GetWindowLongw(hwnd,GWL_WNDPROC));
      SetWindowLongw(hwnd, GWL_WNDPROC,LongInt(FObjectInst));
   end else begin
      FPrevWndProc := Pointer(GetWindowLong(hwnd,GWL_WNDPROC));
      SetWindowLong(hwnd, GWL_WNDPROC,LongInt(FObjectInst));
   end;
   if hwnd<>0 then
      InvalidateRect(hwnd, 0,true)  ;
   inited := true;
   skinstate:=skin_active;
end;

Procedure TSkinControl.Unsubclass;
begin
   if newcolor and (control<>nil) then begin
        setparentbk(false);
        Taccontrol(control).color:=oldcolor;
   end;
end;

Procedure TSkinControl.SkinChange;
begin
   if newcolor and (control<>nil) then
     Taccontrol(control).color:=fsd.colors[csButtonFace];
   Invalidate;
//      setproperty(control,'Color',inttostr(fsd.colors[csButtonFace]));
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
       if isunicode then
         SetWindowLongw(hwnd, GWL_WNDPROC,LongInt(FPrevWndProc))
       else
         SetWindowLong(hwnd, GWL_WNDPROC,LongInt(FPrevWndProc));
       FreeObjectInstance(FObjectInst);
       fobjectinst:=nil;
   end;

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

function TSkinControl.GetParentColor(acolor:Tcolor):Tcolor;
var
  pcontrol:TacControl;
  PropInfo: PPropInfo;
begin
   result:=acolor;
   if Assigned(control) then
   begin
      pcontrol:=TAccontrol(control.parent);
      if Assigned(pcontrol) then
      begin
        PropInfo := GetPropInfo(pcontrol,'Color');
        if (PropInfo <> nil) and (PropInfo.PropType^.Kind = tkInteger) then
            Result := GetOrdProp(pcontrol,PropInfo);
      end
      else
       result:=acolor;
   end
end;

procedure TSkinControl.NewWndProc(var Message: TMessage);
var s:string;
begin
  done:=false;
  if message.msg=CN_SkinEnabled then begin
       skinned:=message.WParam>0;
       if skinned then Invalidate;
  end else
  if skinned then begin
     if BeforeProc(message) then begin
       default(Message);
       AfterProc(message);
     end;
  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.Notification(AComponent: TComponent;Operation: TOperation);
var j:integer;
    sf:TWinskinform;
begin
  inherited Notification(AComponent, Operation);

  if (Operation = opInsert) and (AComponent <> nil)
     and (AComponent is Tcontrol) then begin
      sf:=TWinskinform(skinform);
      sf.AddComp(Tcontrol(acomponent),sf.FForm);
      skinaddlog(format('Notification Insert :%s,%s',[acomponent.classname,acomponent.name]));
  end;
end;  }

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

procedure TSkinControl.Invalidate;
begin
  //if control<>nil then control.Invalidate
  //else
  if gcontrol<>nil then gcontrol.invalidate
  else begin
       InvalidateRect(hwnd,0,true);
       UpdateWindow(hwnd);
  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 begin
          DC := GetWindowDC( hWnd );
          try
             Drawcontrol(dc,rc);
          finally
             ReleaseDC( hwnd, DC );
          end;
      end else begin
         //dc:=adc;
         //boundsrect:=rc;
         //OffsetRect( rc, -rc.left, -rc.top );
         Drawcontrol(adc,rc);
      end;
    except
    end;
  end;
end;

procedure FillColor( dc:HDC; rc:TRect;acolor:Tcolor);
var  Brush: HBrush;
begin
    Brush := CreateSolidBrush(acolor);
    try
      fillrect(dc,rc,brush);
    finally
      DeleteObject(Brush);
    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;

function TSkinControl.GetWindowLongEx(ahWnd: HWND; nIndex: Integer): Longint;
begin
   if isunicode then
       result:=GetWindowLongw( ahWnd, nIndex )
   else
       result:=GetWindowLong( ahWnd, nIndex );
end;

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

procedure TSkinControl.DrawFocus(hDC: HDC; wString: WideString; rc: TRect; uFormat: UINT);

var r1:Trect;
//const
//  Alignments: array[TAlignment] of Word = (DT_LEFT,DT_RIGHT,DT_CENTER );
begin
     r1:=rc;
     Tnt_DrawTextW(hdc,caption,r1,uformat or DT_CALCRECT or DT_NOCLIP);
     if uformat and dt_center >0 then
       OffsetRect(r1, ((rc.right - rc.left) - (r1.right - r1.left)) div 2,
        ((rc.Bottom - rc.Top) - (r1.Bottom - r1.Top)) div 2-1)
     else if uformat and DT_RIGHT >0 then begin
       OffsetRect(r1,((rc.right - rc.left) - (r1.right - r1.left)), 0);
     end;
     InflateRect(r1,2,1);
     if r1.Top<rc.Top then r1.Top:=rc.Top;
     if r1.Bottom>rc.Bottom then r1.Bottom:=rc.Bottom;
     if r1.Right>rc.Right then r1.Right := rc.Right;
     if r1.Left<rc.Left then r1.Left := rc.Left;
     DrawFocusRect(hdc, r1);
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_KILLFOCUS,WM_SETFOCUS:
         Invalidate;
//          PaintControl;
      WM_SETTEXT: begin
           Invalidate;
         end;
      CN_SkinEnabled :skinned := message.WParam>0;
      wm_enable,CM_ENABLEDCHANGED:Invalidate;
    end;
end;

function TSkinControl.BeforeProc(var Message: TMessage):boolean;
begin
   result:=false;
   case message.msg of
      CN_IsSkined : message.result := 1;
      WM_NCDESTROY:begin
          result:=false;
          default(message);
          skinned:=false;
          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:= -1;
   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_5a}
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 }