unit1.pas

来自「IConDate」· PAS 代码 · 共 136 行

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, CommCtrl, StdCtrls, Buttons, ExtCtrls, DateUtils, Math;

type
  PIConArray = ^TIConArray;
  TIConArray = Array of TRect;
  TUseDate = Record
    Disp :Boolean;
    Day  :Integer;
    Value:String;
  end;
  TForm1 = class(TForm)
    MBtn: TSpeedButton;
    CBtn: TSpeedButton;
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormPaint(Sender: TObject);
    procedure CBtnClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Panel28Click(Sender: TObject);
  private
    { Private declarations }
  public
    procedure WMMove(var Msg:TMessage);message WM_MOVE;
    procedure SetRgnRec;
    procedure DrawPaint;
    procedure DrawDate(Const Value:TDateTime);
  end;

function GetIconRect(Const R:PIConArray):Integer;

var
  Form1: TForm1;
  fRun : Boolean = False;
  fDat : Array[0..41]of TUseDate;

implementation

{$R *.dfm}

function GetIconRect(Const R:PIConArray):Integer;
var
  dc,hid :THandle;
  pid,tmp:DWORD;
  fR     :PRect;
  dR     :TRect;
  i      :Integer;
begin
  Result:=0;
  if(R=nil)then Exit;
  dc:=GetWindow(GetWindow(FindWindow('Progman',nil),GW_CHILD),GW_CHILD);
  Result:=ListView_GetItemCount(dc);
  SetLength(R^,Result);
  GetWindowThreadProcessId(dc,pid);
  hid:=OpenProcess(PROCESS_ALL_ACCESS,False,pid);
  fR:=VirtualAllocEx(hid,nil,Sizeof(TRect),MEM_COMMIT	or MEM_RESERVE,PAGE_EXECUTE_READWRITE);
  for i:=0 to Result-1 do begin
    dR.Left:=LVIR_SELECTBOUNDS;
    WriteProcessMemory(hid,fR,@dR,Sizeof(TRect),tmp);
    if(SendMessage(dc,LVM_GETITEMRECT,i,Integer(fR))<>0)then begin
      ReadProcessMemory(hid,fR,@dR,Sizeof(TRect),Tmp);
      R^[i]:=dR;
    end;
  end;
  VirtualFreeEx(hid,fR,Sizeof(TRect),MEM_RELEASE);
  CloseHandle(hid);
end;

procedure TForm1.WMMove(var Msg:TMessage);
begin
  if Not fRun then Abort;
  DrawPaint;
  MBtn.Invalidate;
  CBtn.Invalidate;
  SetRgnRec;
end;

procedure TForm1.SetRgnRec;
var
  hg,tmp:HRGN;
  iCount:Integer;
  RAry  :PIConArray;
  i     :Integer;
  p1,p2 :TPoint;
begin
  New(RAry);
  hg:=CreateRectRgn(0,0,Width,Height);
  iCount:=GetIconRect(RAry);
  for i:=0 to iCount-1 do
    with RAry^[i] do begin
      p1:=ScreenToClient(TopLeft);
      p2:=ScreenToClient(BottomRight);
      tmp:=CreateRectRgn(p1.X,p1.Y,p2.X,p2.Y);
      CombineRgn(hg,hg,tmp,RGN_XOR);
      DeleteObject(tmp);
    end;
  SetWindowRgn(Handle,hg,True);
  DeleteObject(hg);
  Dispose(RAry);
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if(Not MBtn.Down)then abort;
  ReleaseCapture;
  perform(WM_SysCommand, SC_MOVE or 2, 0);
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  DrawPaint;
end;

procedure TForm1.CBtnClick(Sender: TObject);
begin
  Close;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  dc:THandle;
begin
  fRun:=True;
  dc:=GetWindow(GetWindow(FindWindow('Progman',nil),GW_CHILD),GW_CHILD);
  Windows.SetParent(Handle,dc);
end;

procedure TForm1.DrawDate(Const Value:TDateTime);
Const
  fAryStr:Array[0..6]of String = ('琍戳ら','琍戳