main.~pas

一个delphi实现的时钟程序。在桌面上可任意移动。对钩子感兴趣的朋友可以看下。

{*******************************************************}
{*            Email: [e-mail]               *}
{*               QQ: 39262884                          *}
{*******************************************************}

unit Main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, GDIPlusCommon, GDIPOBJ, GDIPAPI, GDIPUTIL, GDITools, IniFiles,
  ExtCtrls, Menus;

type
  TSkinType = (stBlack, stBlue);
  TFmMain = class(TForm)
    pngBg: TPNGButton;
    pngHour: TPNGButton;
    pngMinute: TPNGButton;
    pngSecond: TPNGButton;
    pngDot: TPNGButton;
    pngHighLights: TPNGButton;
    dlgSave: TSaveDialog;
    tmrDrawClock: TTimer;
    pmMain: TPopupMenu;
    mniAllwithontop: TMenuItem;
    mniransparent: TMenuItem;
    mniTransparent10: TMenuItem;
    mniTransparent20: TMenuItem;
    mniTransparent40: TMenuItem;
    mniTransparent60: TMenuItem;
    mniTransparent80: TMenuItem;
    mniTransparent100: TMenuItem;
    mniSkin: TMenuItem;
    mniBlue: TMenuItem;
    mniBlack: TMenuItem;
    mniN1: TMenuItem;
    mniQuit: TMenuItem;
    TrayIcon: TTrayIcon;
    mniStartwithwindow: TMenuItem;
    mniN2: TMenuItem;
    mniFlashwindow: TMenuItem;
    mniSetremindtime: TMenuItem;
    mniAbout: TMenuItem;
    procedure FormShow(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure tmrDrawClockTimer(Sender: TObject);
    procedure mniAllwithontopClick(Sender: TObject);
    procedure pmMainPopup(Sender: TObject);
    procedure mniTransparent10Click(Sender: TObject);
    procedure mniTransparent20Click(Sender: TObject);
    procedure mniTransparent40Click(Sender: TObject);
    procedure mniTransparent60Click(Sender: TObject);
    procedure mniTransparent80Click(Sender: TObject);
    procedure mniTransparent100Click(Sender: TObject);
    procedure mniBlueClick(Sender: TObject);
    procedure mniBlackClick(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure mniQuitClick(Sender: TObject);
    procedure mniStartwithwindowClick(Sender: TObject);
    procedure mniFlashwindowClick(Sender: TObject);
    procedure mniSetremindtimeClick(Sender: TObject);
    procedure mniAboutClick(Sender: TObject);
  private
    FHour, FMinute, FSecond: Word;
    FSkinType: TSkinType;
    FShowSecond: Boolean;
    FSecondTan: Boolean;
    FUpdate: Boolean;
    FAlpha: Byte;
    procedure LoadSet;
    procedure SaveSet;
    procedure InitWindow;
    procedure DrawWindow;
    procedure FlashWindow(AFileName: string);
    procedure SetAppAtStart(AValue: Boolean);
    function GetAppAtStart: Boolean;
  public
    procedure BeginUpdate;
    procedure EndUpdate;
  end;

  TClockSkin = record
    BG: string;
    Hour: string;
    Minute: string;
    Second: string;
    Dot: string;
    HighLight: string;
    Seting: string;
  end;

const
  CClockSkin: array[TSkinType] of TClockSkin = (
    (BG: 'Black.png'; Hour: 'Black_h.png'; Minute: 'Black_m.png'; Second: 'Black_s.png';
     Dot: 'Black_dot.png'; HighLight: 'Black_highlights.png'; Seting: 'Black_settings.png'),
    (BG: 'Blue.png'; Hour: 'Blue_h.png'; Minute: 'Blue_m.png'; Second: 'Blue_s.png';
     Dot: 'Blue_dot.png'; HighLight: 'Blue_highlights.png'; Seting: 'Blue_settings.png'));
  APP_KEY_START: PChar = 'SOFTWARE\Microsoft\Windows\CurrentVersion\Run';
  M_SUBNAME: PChar = 'GDI Plus Clock';

var
  FmMain: TFmMain;

procedure AlphaUpdateLayeredWindowGDIP(Wnd: HWND; ASize: Size; ASrc: THandle; AAlpha: Byte);

implementation

{$R *.dfm}

uses
  DMHook, RemindTime;

procedure AlphaUpdateLayeredWindowGDIP(Wnd: HWND; ASize: Size; ASrc: THandle; AAlpha: Byte);
var
  P: TPoint;
  R: TRect;
  BF: _BLENDFUNCTION;
begin
  GetWindowRect(Wnd, R);
  P := Point(0, 0);
  bf.BlendOp := AC_SRC_OVER;
  bf.BlendFlags := 0;
  bf.SourceConstantAlpha := AAlpha;
  bf.AlphaFormat := AC_SRC_ALPHA;
  SetWindowLong(wnd, GWL_EXSTYLE, GetWindowLong(wnd, GWL_EXSTYLE) or WS_EX_LAYERED);
  UpdateLayeredWindow(wnd, 0, @R.TopLeft, @ASize, ASrc, @P, 0, @BF, ULW_ALPHA);
end;

{ TFmMain }

procedure TFmMain.BeginUpdate;
begin
  FUpdate := False;
end;

procedure TFmMain.DrawWindow;
var
  GPGraph: TGPGraphics;
  m_hdcMemory: HDC;
  hdcScreen: HDC;
  hBMP: HBITMAP;
  sizeWindow: SIZE;
begin
  inherited;
  hdcScreen := GetDC(0);
  m_hdcMemory := CreateCompatibleDC(hdcScreen);
  hBMP := CreateCompatibleBitmap(hdcScreen, Width, Height);
  SelectObject(m_hdcMemory, hBMP);
  GPGraph:= TGPGraphics.Create(m_hdcMemory);
  try
    DrawPNGImage(GPGraph, pngBg);
    DrawPNGImage(GPGraph, pngHour);
    DrawPNGImage(GPGraph, pngMinute);
    if FShowSecond then
      DrawPNGImage(GPGraph, pngSecond);
    DrawPNGImage(GPGraph, pngDot);
    DrawPNGImage(GPGraph, pngHighLights);
    sizeWindow.cx:= Width;
    sizeWindow.cy:= Height;
    AlphaUpdateLayeredWindowGDIP(Handle, sizeWindow, m_hdcMemory, Round(255*FAlpha/100));
  finally
    GPGraph.ReleaseHDC(m_hdcMemory);
    ReleaseDC(0, hdcScreen); 
    DeleteObject(hBMP);
    DeleteDC(m_hdcMemory);
    GPGraph.Free;
  end;
end;

procedure TFmMain.EndUpdate;
begin
  if FUpdate <> True then
  begin
    FUpdate := True;
    DrawWindow;
  end;
end;

procedure TFmMain.FlashWindow(AFileName: string);
var
  GPGraph: TGPGraphics;
  GPBitmap: TGPBitmap;
  Clsid: TGUID;
begin
  inherited;
  GPBitmap := TGPBitmap.Create(Width, Height, PixelFormat32bppARGB);
  GPGraph:= TGPGraphics.Create(GPBitmap);
  try
    DrawPNGImage(GPGraph, pngBg);
    DrawPNGImage(GPGraph, pngHour);
    DrawPNGImage(GPGraph, pngMinute);
    DrawPNGImage(GPGraph, pngSecond);
    DrawPNGImage(GPGraph, pngDot);
    DrawPNGImage(GPGraph, pngHighLights);

    if GetEncoderClsid('image/png', Clsid) <> -1 then
      GPBitmap.Save(AFileName, Clsid);
  finally
    GPBitmap.Free;
    GPGraph.Free;
  end;
end;

procedure TFmMain.InitWindow;
var
  sPath: string;
begin
  BeginUpdate;
  try
    sPath := ExtractFilePath(ParamStr(0)) + 'Images\';
    LoadSet;
    pngBg.ImageNormal := sPath + CClockSkin[FSkinType].BG;
    pngHour.ImageNormal := sPath + CClockSkin[FSkinType].Hour;
    pngMinute.ImageNormal := sPath + CClockSkin[FSkinType].Minute;
    pngSecond.ImageNormal := sPath + CClockSkin[FSkinType].Second;
    pngDot.ImageNormal := sPath + CClockSkin[FSkinType].Dot;
    pngHighLights.ImageNormal := sPath + CClockSkin[FSkinType].HighLight;
  finally
    EndUpdate;
  end;
end;

procedure TFmMain.LoadSet;
var
  iniSet: TIniFile;
begin
  iniSet := TIniFile.Create(ExtractFilePath(ParamStr(0)) + 'Set.ini');
  try
    FSkinType := TSkinType(iniSet.ReadInteger('AppleClock', 'SkinType', Integer(stBlue)));
    FShowSecond := iniSet.ReadBool('AppleClock', 'ShowSecond', True);
    FSecondTan := iniSet.ReadBool('AppleClock', 'SecondTan', True);
    FAlpha := iniSet.ReadInteger('AppleClock', 'Alpha', 100);
    Left := iniSet.ReadInteger('AppleClock', 'Left', Screen.Width-Width-20);
    Top := iniSet.ReadInteger('AppleClock', 'Top', 20);
    if iniSet.ReadBool('AppleClock', 'StayOnTop', True) then
      FormStyle := fsStayOnTop;
  finally
    iniSet.Free;
  end;
end;

procedure TFmMain.SaveSet;
var
  iniSet: TIniFile;
begin
  iniSet := TIniFile.Create(ExtractFilePath(ParamStr(0)) + 'Set.ini');
  try
    iniSet.WriteInteger('AppleClock', 'SkinType', Integer(FSkinType));
    iniSet.WriteBool('AppleClock', 'ShowSecond', FShowSecond);
    iniSet.WriteBool('AppleClock', 'SecondTan', FSecondTan);
    iniSet.WriteInteger('AppleClock', 'Alpha', FAlpha);
    iniSet.WriteInteger('AppleClock', 'Left', Left);
    iniSet.WriteInteger('AppleClock', 'Top', Top);
    if FormStyle = fsStayOnTop then
      iniSet.WriteBool('AppleClock', 'StayOnTop', True)
    else
      iniSet.WriteBool('AppleClock', 'StayOnTop', False)
  finally
    iniSet.Free;
  end;
end;

procedure TFmMain.SetAppAtStart(AValue: Boolean);
var
  key : HKEY;
  ret : integer;
  chg : DWORD;
  AppStr : String;
begin
  key := 0;
  ret := RegCreateKeyEx(HKEY_LOCAL_MACHINE, APP_KEY_START, 0, nil, REG_OPTION_NON_VOLATILE,
    KEY_ALL_ACCESS, nil, key, @chg);
  if (ret<>ERROR_SUCCESS) or (key=0) then exit;
  try
    if not AValue then begin
      RegDeleteValue(key, M_SUBNAME);
    end
    else begin
      AppStr := ParamStr(0);
      RegSetValueEx(key, M_SUBNAME, 0, REG_SZ, PChar(AppStr), Length(AppStr));
    end;
  finally
    RegCloseKey(key);
  end;
end;

function TFmMain.GetAppAtStart: Boolean;
var
  key : HKEY;
  ret : integer;
  chg : DWORD;
  Buffer : string[255];
  len : DWORD;
begin
  Result := False;
  key := 0;
  ret := RegCreateKeyEx(HKEY_LOCAL_MACHINE, APP_KEY_START, 0, nil, REG_OPTION_NON_VOLATILE,
    KEY_ALL_ACCESS, nil, key, @chg);
  if (ret<>ERROR_SUCCESS) or (key=0) then exit;
  len := 255;
  try
    if RegQueryValueEx(key, M_SUBNAME, nil, nil, PByte(@Buffer), @len)
      = ERROR_SUCCESS then Result := True;
  finally
    RegCloseKey(key);
  end;
end;

procedure TFmMain.FormShow(Sender: TObject);
begin
  InitWindow;
end;

procedure TFmMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  SaveSet;
end;

procedure TFmMain.FormCreate(Sender: TObject);
begin
  FUpdate := False;
end;

procedure TFmMain.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  ReleaseCapture;
  SendMessage(Handle, WM_SYSCOMMAND, SC_MOVE + HTCAPTION, 0);
end;

procedure TFmMain.tmrDrawClockTimer(Sender: TObject);
var
  wHur, wMiu, wSec, wMsec: Word;
begin
  inherited;
  DecodeTime(Now, wHur, wMiu, wSec, wMsec);
  if (FHour=wHur) and (FMinute=wMiu) and (FSecond=wSec) then Exit;
  if (not FShowSecond) and (FHour=wHur) and (FMinute=wMiu) then Exit;
  BeginUpdate;
  pngHour.Rotate := Trunc(wMiu/2)+(wHur mod 12)*30;
  pngMinute.Rotate := Trunc(wSec/10)+wMiu*6;
  if FSecondTan then
  begin
    pngSecond.Rotate := wSec*6+4;
    EndUpdate;
    Sleep(50);
  end;
  pngSecond.Rotate := wSec*6;
  EndUpdate;
  FHour := wHur;
  FMinute := wMiu;
  FSecond := wSec;
end;

procedure TFmMain.mniAboutClick(Sender: TObject);
begin
  MessageBox(Handle, 'Email:[e-mail];  QQ:39262884', 'About', MB_ICONINFORMATION);
end;

procedure TFmMain.mniAllwithontopClick(Sender: TObject);
begin
  if mniAllwithontop.Checked then
    Self.FormStyle := fsStayOnTop
  else
    Self.FormStyle := fsNormal;
end;

procedure TFmMain.pmMainPopup(Sender: TObject);
begin
  mniStartwithwindow.Checked := GetAppAtStart;
  if FormStyle = fsStayOnTop then
    mniAllwithontop.Checked := True
  else
    mniAllwithontop.Checked := False;
  case FAlpha of
    10: mniTransparent10.Checked := True;
    20: mniTransparent20.Checked := True;
    40: mniTransparent40.Checked := True;
    60: mniTransparent60.Checked := True;
    80: mniTransparent80.Checked := True;
    100: mniTransparent100.Checked := True;
  end;
  case FSkinType of
    stBlue: mniBlue.Checked := True;
    stBlack: mniBlack.Checked := True;
  end;
end;

procedure TFmMain.mniTransparent10Click(Sender: TObject);
begin
  FAlpha := 10;
  DrawWindow;
end;

procedure TFmMain.mniTransparent20Click(Sender: TObject);
begin
  FAlpha := 20;
  DrawWindow;
end;

procedure TFmMain.mniTransparent40Click(Sender: TObject);
begin
  FAlpha := 40;
  DrawWindow;
end;

procedure TFmMain.mniTransparent60Click(Sender: TObject);
begin
  FAlpha := 60;
  DrawWindow;
end;

procedure TFmMain.mniTransparent80Click(Sender: TObject);
begin
  FAlpha := 80;
  DrawWindow;
end;

procedure TFmMain.mniTransparent100Click(Sender: TObject);
begin
  FAlpha := 100;
  DrawWindow;
end;

procedure TFmMain.mniBlueClick(Sender: TObject);
var
  sPath: string;
begin
  FSkinType := stBlue;
  sPath := ExtractFilePath(ParamStr(0)) + 'Images\';
  BeginUpdate;
  try
    pngBg.ImageNormal := sPath + CClockSkin[FSkinType].BG;
    pngHour.ImageNormal := sPath + CClockSkin[FSkinType].Hour;
    pngMinute.ImageNormal := sPath + CClockSkin[FSkinType].Minute;
    pngSecond.ImageNormal := sPath + CClockSkin[FSkinType].Second;
    pngDot.ImageNormal := sPath + CClockSkin[FSkinType].Dot;
    pngHighLights.ImageNormal := sPath + CClockSkin[FSkinType].HighLight;
  finally
    EndUpdate;
  end;
end;

procedure TFmMain.mniFlashwindowClick(Sender: TObject);
var
  sFileName: string;
begin
  if dlgSave.Execute(Handle) then
  begin
    sFileName := dlgSave.FileName;
    if not SameText(ExtractFileExt(sFileName), '.png') then
      sFileName := sFileName + '.png';
    FlashWindow(sFileName);
  end;
end;

procedure TFmMain.mniQuitClick(Sender: TObject);
begin
  Close;
end;

procedure TFmMain.mniSetremindtimeClick(Sender: TObject);
var
  iValue: Integer;
begin
  iValue := DM.WorkTime;
  if TFmRemindTime.ShowForm(iValue, Handle) then
  begin
    DM.WorkTime := iValue;
  end;
end;

procedure TFmMain.mniStartwithwindowClick(Sender: TObject);
begin
  SetAppAtStart(mniStartwithwindow.Checked);
end;

procedure TFmMain.mniBlackClick(Sender: TObject);
var
  sPath: string;
begin
  FSkinType := stBlack;
  sPath := ExtractFilePath(ParamStr(0)) + 'Images\';
  BeginUpdate;
  try
    pngBg.ImageNormal := sPath + CClockSkin[FSkinType].BG;
    pngHour.ImageNormal := sPath + CClockSkin[FSkinType].Hour;
    pngMinute.ImageNormal := sPath + CClockSkin[FSkinType].Minute;
    pngSecond.ImageNormal := sPath + CClockSkin[FSkinType].Second;
    pngDot.ImageNormal := sPath + CClockSkin[FSkinType].Dot;
    pngHighLights.ImageNormal := sPath + CClockSkin[FSkinType].HighLight;
  finally
    EndUpdate;
  end;
end;

end.