winskinform.pas

目前所能找到的VCLSkin控件的源码最新版, 控件功能参见官方网站: http://www.link-rank.com/

function CopyHMenu(amenu:Hmenu):Hmenu;
var hMenuOurs:Hmenu;
    nID: UINT;             // The ID of the menu.
    uMenuState :UINT ;        // The menu state.
    hSubMenu: HMENU ;        // A submenu.
    s:string;
    nmenu:integer;
    szBuf:array[0..127] of char;
begin
   hMenuOurs := CreatePopupMenu;
   nmenu :=0;
   uMenuState :=GetMenuState(aMenu,nMenu,MF_BYPOSITION);
   while uMenustate<>$FFFFFFFF do begin
       GetMenuString(aMenu,nMenu, szBuf,sizeof(szBuf),MF_BYPOSITION);
       if (LOBYTE(uMenuState) and MF_POPUP)>0 then begin
            hSubMenu := GetSubMenu(aMenu,nMenu);
            AppendMenu(hMenuOurs,uMenuState,hSubMenu,szBuf);
       end else begin
            nID := GetMenuItemID(aMenu,nMenu);
            AppendMenu(hMenuOurs,uMenuState,nID,szBuf);
       end;
       inc(nmenu);
       uMenuState :=GetMenuState(aMenu,nMenu,MF_BYPOSITION);
   end;
   result:=hmenuours;
end;

procedure DeleteHMenu(amenu:Hmenu);
var b:boolean;
begin
   b:=RemoveMenu(amenu,0,MF_BYPOSITION);
   while  b do
     b:=RemoveMenu(amenu,0,MF_BYPOSITION);
   DestroyMenu(amenu);
end;

procedure RethinkLines(aitem:Tmenuitem);
var
  I, LLastAt: Integer;
  LLastBar: TMenuItem;
begin
//    for i:= 0 to aitem.Count-1 do
//     aitem.Items[i].AutoHotkeys := maAutomatic;
     
    LLastAt := 0;
    LLastBar := nil;
 with aitem do begin
    for I := LLastAt to Count - 1 do
      if Items[I].Visible then
        if Items[I].IsLine then
        begin
          Items[I].Visible := False;
        end else begin
          LLastAt := I;
          System.Break;
        end;
    for I := LLastAt to Count - 1 do
      if Items[I].IsLine then
      begin
        if (LLastBar <> nil) and (LLastBar.Visible) then
        begin
          LLastBar.Visible := False;
        end;
        LLastBar := Items[I];
      end
      else if Items[I].Visible then
      begin
        if (LLastBar <> nil) and (not LLastBar.Visible) then
        begin
          LLastBar.Visible := True;
        end;
        LLastBar := nil;
        LLastAt := I;
      end;
    for I := Count - 1 downto LLastAt do
      if Items[I].Visible then
        if Items[I].IsLine then
        begin
          Items[I].Visible := False;
        end
        else
          System.Break;
  end;
end;

procedure ActionUpdate(item:Tmenuitem);
var
  i: Integer;
  a: TMenuItem;
begin
{   for i:= 0 to item.Count-1 do begin
     a:=item.Items[i];
     if a.Action<>nil then a.Action.Update;
   end;}
end;

function GetFormCaption(ahwnd:Thandle):widestring;
var  buf:array[0..1000] of char;
begin
  result:='';
  if Win32PlatformIsUnicode then begin
    SetLength(Result, GetWindowTextLengthW(ahwnd) + 1);
    GetWindowTextW(ahwnd, PWideChar(Result), Length(Result));
    SetLength(Result, Length(Result) - 1);
  end else begin
     sendmessage(ahwnd,WM_GETTEXT,1000,integer(@buf));
     result:=strpas(buf);
  end;
end;

function GetFormCaptionA(ahwnd:Thandle):string;
var  buf:array[0..1000] of char;
begin
  sendmessage(ahwnd,WM_GETTEXT,1000,integer(@buf));
  result:=strpas(buf);
end;

function GetFormText(ahwnd:Thandle):string;
var s:widestring;
begin
   s:= GetFormCaption(ahwnd);
  result:=WideStringToStringEx(s);
end;

function TWinSkinForm.CheckMenu(Button: TMenuBtn): Boolean;
var
  Hook: Boolean;
  I: Integer;
  APoint: TPoint;
  aflags:integer;
  mp:tagTPMPARAMS;
begin
    Result := False;
    lastselect:=false;
    mp.cbSize:=sizeof(mp);
    if (button=nil) then Exit;
    postmessage(hwnd,wm_command,button.mid,0);
    if (Button.hsubmenu=0) then Exit;
    if button.menuitem<>nil then  begin
//    error happen 2006.5.04
//       RethinkLines(button.menuitem);
       ActionUpdate(button.menuitem);
    end;
    MenuButtonIndex := Button.Index;
    SkinForm := Self;
    GetWindowRect(hwnd, WTR);
    mp.rcExclude := rect(wtr.Right-5,wtr.Top,GetSystemMetrics(SM_CXMAXIMIZED),wtr.Bottom);
    if not ((Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion = 4)) then
       wminitmenu(button.hsubmenu);
//    skincanlog:=true;
    finmenu:=true;
    APoint := Point(Button.bounds.left+wtr.left,Button.bounds.bottom+wtr.top);
    if bidileft then begin
       APoint := Point(Button.bounds.right+wtr.left,Button.bounds.bottom+wtr.top);
       Aflags:= TPM_RightALIGN or TPM_RIGHTBUTTON or TPM_NONOTIFY;
    end else begin
       APoint := Point(Button.bounds.left+wtr.left,Button.bounds.bottom+wtr.top);
       Aflags:= TPM_LEFTALIGN or TPM_RIGHTBUTTON or TPM_NONOTIFY;
    end;
//    SendMessage(hwnd,WM_INITMENUPOPUP,button.hsubmenu,0);
    skinmanager.menutype:=m_menuitem;
    skinmanager.menuactive:=true;
    activemenu:=button.hsubmenu;
    InitMenuHooks;
    if Button.enabled then begin
//       if bidileft then
//          TrackPopupMenuex(button.hsubmenu, aflags,APoint.X, APoint.Y,hwnd,@mp)
//       else
        TrackPopupMenu(button.hsubmenu, aflags,APoint.X, APoint.Y,0,hwnd,nil );
    end;
    ReleaseMenuHooks;
    finmenu:=false;
    Result := True;
end;


//fixed by Brian Lowe
procedure TWinSkinForm.CMDialogChar(var Message: TMessage); //TCMDialogChar
var
  Button: TMenubtn;
  ShiftState: TShiftState;
  KeyState: TKeyboardState;
begin
  OldWndProc(message);
  if message.result<>0 then exit;

    GetKeyboardState(KeyState);
    ShiftState := KeyboardStateToShiftState(KeyState);
    Button := FindButtonFromAccel(TWMKey(Message).CharCode);
    if (Button <> nil) and (ShiftState = [ssAlt]) then begin
        clickbutton(button);
        Message.Result := 1;
        done2:=true;
    end else begin
      //mdiform mainmenu shortcut
      if (formstyle=sfsmdichild) then begin
         if skinmanager.MDIForm.Perform(CM_DIALOGCHAR,
                TWMKey(Message).CharCode,TWMKey(Message).KeyData)<>0 then exit;
      end else if (fform<>application.MainForm) and (not (fsModal in fform.FormState)) then begin //has problem
          application.MainForm.Perform(CM_DIALOGCHAR,TWMKey(Message).CharCode,TWMKey(Message).KeyData);
      end;
      message.Result:=0;
//      OldWndProc(message);
    end;  
end;

procedure SetAnimation(Value: Boolean);
var
  Info: TAnimationInfo;
begin
  Info.cbSize := SizeOf(TAnimationInfo);
  BOOL(Info.iMinAnimate) := Value;
  SystemParametersInfo(SPI_SETANIMATION, SizeOf(Info), @Info, 0);
end;

constructor TWinSkinForm.Create(AOwner: TComponent);
var i,l:integer;
begin
  inherited create(aowner);
  bstr:='  ';
  SkinCanLog:=true;
  poptime := 0;
  charwidth := 0;
  winrgn := 0;
  DoubleTime := GetDoubleClickTime;
//  SkinCanLog:=false;
  CreateCaptionFont;
  fCanvas:= TCanvas.create;
  fCanvas2:= TCanvas.create;
//  bg:=Tbitmap.create;
  controllist:=Tlist.create;
  IconBmp:=Tbitmap.create;
  CaptionBuf:=Tbitmap.create;
  MenuHeight := 0;
  msglock:=0;
  mode:=0;
  activebtn:=nil;
  creating:=false;
  bidileft:=false;
  NewChildHwnd:=0;
  fwindowactive:=true;
  ActiveBtn:= nil;
  skinstate:=skin_Creating;
  fform:=nil;
  astr:='  ';
 {$IFnDEF demo}
    astr:=' ';
 {$else}
    astr:=' Vclskin Demo';
 {$ENDIF}
end;

destructor TWinSkinForm.Destroy;
begin
  DeleteControls;
  DeleteSysbtn;
  if not IsBadReadPtr(CaptionBuf, InstanceSize) then CaptionBuf.free;
  if timer<>nil then timer.free;
  if menu<>nil then begin
     menu.free;
     menu:=nil;
  end;
  if  sysmenu<>nil then begin
    sysmenu.free;
    sysmenu:=nil;
  end;
  CaptionFont.free;
  controllist.free;
  controllist:=nil;
  Iconbmp.free;
  if skinmanager<>nil then skinmanager.DeleteForm2(hwnd);
  fCanvas.free;
  fCanvas2.free;
//  skinaddlog('Skinform DESTROY '+caption);
  inherited destroy;
end;

  //  TabSheet := TTabSheet.Create(PageControl1);
  // this event happen when owern is form, it is problem
procedure TWinSkinForm.Notification(AComponent: TComponent;Operation: TOperation);
var j:integer;
    sc:Tskincontrol;
begin
  inherited Notification(AComponent, Operation);
  
{  if (Operation = opInsert) and (AComponent <> nil) then begin
     skinaddlog(format('Notification Insert :%s,%s',[acomponent.classname,acomponent.name]));
  end;   }

  {  if (skinstate<>Skin_Active) or (acomponent.tag=c_skintag) then exit;
  if (Operation = opRemove) and (AComponent <> nil) then begin
     skinaddlog(format('Notification Remove :%s',[acomponent.classname]));
     if (AComponent is TGraphicControl) then begin
       for j:= 0 to controllist.count-1 do begin
            sc:= Tskincontrol(controllist.items[j]);
            if sc.GControl = AComponent then begin
               controllist.Delete(j);
               sc.free;
               break;
            end;
       end;
     end;//Tgraphiccontrol
  end else if (Operation = opInsert) and (AComponent <> nil) then begin
//     skinaddlog(format('Notification Insert :%s',[acomponent.classname]));
  end;}
end;

procedure TWinSkinForm.DeleteSysbtn;
var i:integer;
begin
  if high(sysbtn)=0 then exit;
  for i:= 0 to high(SysBtn) do
      SysBtn[i].free;
  setlength(sysbtn,0);
end;

procedure TWinSkinForm.DeleteControl(c:TSkinControl);
var i:integer;
begin
  if controllist=nil then exit;
  for i:= controllist.count-1 downto 0 do begin
     if Controllist.items[i]=c then begin
       controllist.delete(i);
       break;
     end;
  end;
end;

procedure TWinSkinForm.DeleteSkinDeleted;
var i:integer;
    c:TSkinControl;
begin
  for i:= controllist.count-1 downto 0 do begin
     c:=TSkinControl(Controllist.items[i]);
     if c.skinstate=skin_deleted then begin
        controllist.delete(i);
        c.free;
     end;
  end;
end;

procedure TWinSkinForm.DeleteControls;
var i:integer;
    c:TSkinControl;
    acontrol:Tcontrol;
begin
//  for i:= controllist.count-1 to 0 do begin
  while controllist.count>0 do begin
     c:=TSkinControl(Controllist.items[0]);
     if (c.control<>nil) and (c.control is TToolbar) then begin
        Ttoolbar(c.control).OnCustomDrawButton:=nil;
        Ttoolbar(c.control).OnCustomDraw:=nil;
     end;
     if c.skinstate<>skin_deleted then c.unsubclass;
     controllist.delete(0);
     c.free;
  end;
  controllist.clear;
end;

function TWinSkinForm.AddControlList(acontrol:TSkinControl):boolean;
var i:integer;
    c:TSkinControl;
    b:boolean;
begin
  b:=false;
  for i:= 0 to controllist.count-1 do begin
     c:=TSkinControl(Controllist.items[i]);
     if c=acontrol then begin
        b:=true;
        break;
     end;
  end;   
  if not b then controllist.add(acontrol);
  result:=b;
end;

procedure TWinSkinForm.CreateCaptionFont;
var
  NonClientMetrics: TNonClientMetrics;
begin
  If Assigned(CaptionFont) then FreeAndNIL(CaptionFont);
  CaptionFont := TFont.Create;
  NonClientMetrics.cbSize := SizeOf(NonClientMetrics);
  if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then
    CaptionFont.Handle := CreateFontIndirect(NonClientMetrics.lfCaptionFont);

end;

procedure TWinSkinForm.changemdistyle;
var Style: Longint;
begin
    if fform.clienthandle<>0 then begin
      Style := GetWindowLong(fform.ClientHandle, GWL_STYLE);
      Style := Style and not WS_VSCROLL and not WS_HSCROLL;
      SetWindowLong(fform.ClientHandle, GWL_STYLE, Style);

      Style := GetWindowLong(fform.ClientHandle, GWL_EXSTYLE);
      Style := Style and not WS_EX_CLIENTEDGE;
      SetWindowLong(fform.ClientHandle, GWL_EXSTYLE, Style);
      SetWindowPos(fform.ClientHandle, 0, 0,0,0,0, SWP_FRAMECHANGED or SWP_NOACTIVATE or
      SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER);
    end;
end;

procedure TWinSkinForm.SetActive(const Value: boolean);
begin
end;

procedure TWinSkinForm.InitTform(afsd:Tskindata;aform:Tform);
begin
   fform:=aform;

   if assigned(afsd.OnBeforeSkinForm) then
     afsd.OnBeforeSkinForm(fform,hwnd,formclass);

//   fform.autoscroll:=false;
   if (xcMenuitem in afsd.SkinControls) then
      setproperty(fform,'AutoScroll','False');
   InitSkin(afsd);
//   if (xcMainMenu in afsd.SkinControls) then begin
   if sMainMenu then begin   //for midchild border
      OldWndProc:= fform.WindowProc;
      fform.WindowProc := NewWndProc;
   end;