timer.pas

Clock 桌面时钟 日历 阴历 看到的delphi程序 转发

Unit Timer;

Interface

Uses
  Windows,
  Messages,
  SysUtils,
  Classes,
  Graphics,
  Controls,
  Forms,
  ExtCtrls,
  Menus,
  MacForm,
  UnitBitmapRgn,
  IniFiles,
  Math,
  CoolTray;

Type
  TfrmTime = Class(TForm)
    Procedure FormCreate(Sender: TObject);
  Private
    FCaptured: Boolean;
    FOldx, FOldy: Integer;
    Images: TImageList;

    cmRt, digRt: TRect;
    time: TTimer;
    Tray: TCoolTrayIcon;

    bmp, bmpDigit: TBitmap;
    tm: Array[0..11] Of TBitmap;

    ScreenRect: TRect;
    PosX, PosY: Integer;

    Rgn: TBitmapRgn;

    FOldFace, FOldDigit, FFace, FDigit: String;
  Protected
    Procedure ChgTime(Sender: TObject);

    Procedure popExitClick(Sender: TObject);
    Procedure popCalClick(Sender: TObject);
    Procedure popOptionClick(Sender: TObject);

    Procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y:
      Integer); Override;
    Procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      Override;
    Procedure MouseMove(Shift: TShiftState; X, Y: Integer); Override;
    Procedure Paint; Override;
    Procedure Init(AFace, ADigit: String);
    Procedure PaintDigit;
    Procedure FaceClick(Sender: TObject);
    Procedure DigitClick(Sender: TObject);
    Procedure popAutoRunClick(Sender: TObject);
    Procedure WMTIMERALPHA(Var Message: TMessage); Message WM_TIMERALPHA;
    Procedure popRandImg(Sender: TObject);
    Procedure WMCHGFACE(Var Message: TMessage); Message WM_CHGFACE;
    Procedure WMCHGDIGIT(Var Message: TMessage); Message WM_CHGDIGIT;
    Procedure CreateParams(Var Params: TCreateParams); Override;
  Public
    FaceList, DigitList: TStringList;
    popFace, popDigit, popRandFace, popAutoRun: TMenuItem;
    Destructor Destroy; Override;
    Function GetFaceIndex: Integer;
    Function GetDigitIndex: Integer;
  End;
Var
  frmTime: TfrmTime;

Implementation
{$R *.dfm}

Uses Main,
  Option;

Procedure TfrmTime.ChgTime(Sender: TObject);
Var
  s: String;
  i, p, w, t: Integer;
  st: integer;
Begin
  st := getWindowLong(Handle, GWL_EXSTYLE);

  If (st And WS_EX_TOPMOST) <> WS_EX_TOPMOST Then
  Begin
    If (frmOption <> Nil) And (frmOption.chkTop.Checked) Then
      SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or
        SWP_NOSIZE Or SWP_NOACTIVATE);
  End
  Else
  Begin
    If (frmOption <> Nil) And Not (frmOption.chkTop.Checked) Then
      SetWindowPos(Handle, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or
        SWP_NOMOVE);
  End;

  w := 3;
  bmpDigit.Canvas.StretchDraw(digRt, TM[11]);

  s := FormatDateTime('HH:MM:SS', Now);
  For i := 1 To Length(s) Do
  Begin
    If s[i] In ['0'..'9'] Then
      p := strtoint(s[i])
    Else
      p := 10;

    With tm[p] Do
    Begin
      If p = 10 Then
        t := 7
      Else
        t := 15;

      BitBlt(bmpDigit.Canvas.Handle, w, 0, Width, 25,
        Canvas.Handle, 0, 0, SRCCOPY);

      Inc(w, t);
    End;
  End;

  PaintDigit;
End;

Procedure TfrmTime.Paint;
Begin
  BitBlt(Canvas.Handle, 0, 0, Width, Height, bmp.Canvas.Handle, 0, 0, SRCCOPY);

  PaintDigit;
End;

Procedure TfrmTime.FormCreate(Sender: TObject);
Var
  tmpStr, s: String;
  tmpB: TBitmap;
  j: Integer;

  Procedure LoadImg;
  Var
    i, p: Integer;
    tmpInf: TIniFile;
    tmp: TStringList;

  Begin
    tmpInf := Nil;
    s := AppPath + AppInf.ReadString(sClockStyles, 'Path',
      'Res\ClockStyle.ini');
    If FileExists(s) Then
      tmpInf := TIniFile.Create(s);

    If tmpInf <> Nil Then
    Begin
      s := ExtractFilePath(s);
      tmp := TStringList.Create;
      tmpInf.ReadSectionValues(sClockFace, tmp); //FaceList

      For i := 0 To tmp.Count - 1 Do
      Begin
        tmpStr := tmp[i];
        p := pos('=', tmpStr);
        If p > 0 Then
        Begin
          Delete(tmpStr, 1, p);
          tmpStr := s + tmpStr;

          If FileExists(tmpStr) Then
          Begin
            FaceList.Add(tmpStr);

            popFace.Add(NewMenuItem(ChangeFileExt(ExtractFileName(tmpStr), ''),
              FaceClick, [moEnabled, moAutoCheck, moRadioItem], FaceList.Count -
              1));
          End;
        End;
      End;

      popFace.Enabled := FaceList.Count > 0;
      tmp.Clear;

      tmpInf.ReadSectionValues(sClockDigit, tmp);

      For i := 0 To tmp.Count - 1 Do
      Begin
        tmpStr := tmp[i];
        p := pos('=', tmpStr);
        If p > 0 Then
        Begin
          Delete(tmpStr, 1, p);
          tmpStr := s + tmpStr;

          If FileExists(tmpStr) Then
          Begin
            DigitList.Add(tmpStr);

            popDigit.Add(NewMenuItem(ChangeFileExt(ExtractFileName(tmpStr), ''),
              DigitClick, [moEnabled, moAutoCheck, moRadioItem], DigitList.Count
              - 1));

          End;
        End;
      End;
      popDigit.Enabled := DigitList.Count > 0;

      tmp.Free;
      FreeAndNil(tmpInf);
    End;
  End;

  Procedure LoadDef;
  Begin
    popRandFace.Checked := AppInf.ReadBool(sOption, 'RandImg', True);
    popAutoRun.Checked := AppInf.ReadBool(soption, 'AutoRun', True);

    FFace := AppInf.ReadString(sClockStyles, 'Face', '');
    FDigit := AppInf.ReadString(sClockStyles, 'Digit', '');

    popAutoRunClick(Nil);
  End;

  Procedure InitItem;
  Begin
    popupmenu := Tpopupmenu.Create(self);
    With popupmenu Do
    Begin
      AutoHotkeys := maManual;
      AutoPopup := true;
      items.Add(newmenuitem('日历(&C)', popCalClick));
      items.Add(Newline);

      items.Add(newmenuitem('自动运行(&R)', popAutoRunClick, [moAutoCheck,
        moEnabled]));
      popAutoRun := items[Items.Count - 1];

      items.Add(newmenuitem('选项(&O)', popOptionClick));
      items.Add(Newline);
      items.Add(newmenuitem('随机更换皮肤(&R)', popRandImg, [moAutoCheck,
        moEnabled]));
      popRandFace := items[Items.Count - 1];

      items.Add(newmenuitem('背景皮肤(&B)'));
      popFace := items[Items.Count - 1];

      items.Add(newmenuitem('字型(&F)'));
      popDigit := items[Items.Count - 1];

      items.Add(Newline);
      items.Add(newmenuitem('退出(&X)', popExitClick));
    End
  End;

Begin
  BorderStyle := bsNone;
  AlphaBlend := True;

  FCaptured := False;
  ScreenRect := Screen.WorkAreaRect;
  FOldFace := '';
  FOldDigit := '';

  Rgn := TBitmapRgn.Create(self);
  bmp := TBitmap.Create;
  FaceList := TStringList.Create;
  DigitList := TStringList.Create;

  For j := 0 To 11 Do
    tm[j] := TBitmap.Create;

  InitItem;
  LoadDef;
  LoadImg;

  If popRandFace.Checked Then
  Begin
    If (FaceList.Count > 0) Then
    Begin
      j := RandomRange(0, FaceList.Count);
      If j >= popFace.Count Then
        j := 0;
      FFace := FaceList[j];
    End;

    If DigitList.Count > 0 Then
    Begin
      j := RandomRange(0, DigitList.Count);
      If j >= popDigit.Count Then
        j := 0;
      FDigit := DigitList[j];
    End;
  End;

  digRt := Bounds(0, 0, 110, 25);
  bmpDigit := TBitmap.Create;
  With bmpDigit Do
  Begin
    width := digRt.Right;
    Height := digRt.Bottom;
  End;

  time := TTimer.Create(Self);
  With time Do
  Begin
    OnTimer := ChgTime;
    Interval := 1000;
  End;

  TmpB := TBitmap.Create;
  TmpB.LoadFromResourceID(HInstance, 3000);

  Images := TImageList.Create(Self);
  Images.AddMasked(TmpB, TmpB.Canvas.Pixels[1, 1]);
  TmpB.Free;

  Tray := TCoolTrayIcon.Create(self);
  With Tray Do
  Begin
    CycleIcons := True;
    IconList := Images;
    CycleInterval := 500;
    Hint := 'Lunar Desktop Calendar';
    LeftPopup := True;
    Popupmenu := self.PopupMenu;
    Init;
  End;

  j := GetFaceIndex;
  If J > -1 Then
    popFace.Items[j].Checked := True;
  j := GetDigitIndex;
  If j > -1 Then
    popDigit.Items[j].Checked := True;

  Init(FFace, FDigit);

  RestoreState(Self);
  ChgTime(Nil);
End;

Destructor TfrmTime.Destroy;
Var
  i: Integer;
Begin
  AppInf.WriteBool(sOption, 'RandImg', popRandFace.Checked);
  AppInf.WriteBool(soption, 'AutoRun', popAutoRun.Checked);
  AppInf.WriteString(sClockStyles, 'Face', FFace);
  AppInf.WriteString(sClockStyles, 'Digit', FDigit);

  SaveState(Self);

  For i := 0 To 11 Do
    tm[i].Free;

  popupmenu.Free;
  Tray.Free;
  time.Free;
  bmpDigit.Free;
  FaceList.Free;
  DigitList.Free;
  Rgn.Free;
  bmp.Free;

  Images.Free;

  Inherited;
End;

Procedure TfrmTime.popExitClick(Sender: TObject);
Begin
  If frmMain.Busy Then
    Exit;
  Close;
End;

Procedure TfrmTime.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y:
  Integer);
Begin
  SetCapture(Handle);
  FCaptured := True;
  FOldx := x;
  FOldy := y;

  Inherited MouseDown(Button, Shift, X, Y);
End;

Procedure TfrmTime.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y:
  Integer);
Begin
  ReleaseCapture;
  FCaptured := false;
  Inherited MouseUp(Button, Shift, X, Y);
End;

Procedure TfrmTime.MouseMove(Shift: TShiftState; X, Y: Integer);
Var
  pt, pt1: TPoint;
Begin
  If FCaptured Then
  Begin
    pt := ClientToScreen(Point(X - FOldx, Y - FOldy));
    pt1.X := pt.X + Width;
    pt1.y := pt.y + Height;

    If PtInRect(ScreenRect, pt) And PtInRect(ScreenRect, pt1) Then
      MoveWindow(Handle, pt.X, pt.Y, Width, Height, False);

  End;

  Inherited MouseMove(Shift, X, Y);
End;

Procedure TfrmTime.popCalClick(Sender: TObject);
Begin
  CheckfrmMain;

  frmMain.Show;
End;

Procedure TfrmTime.Init(AFace, ADigit: String);
Var
  tmp: TBitmap;
  rt: TRect;
  i: Integer;

  Function LoadFace: Boolean;
  Begin
    Result := False;
    If AnsiSameText(FFace, FOldFace) Then
    Begin
      Result := FileExists(AFace);
      Exit;
    End;

    If FileExists(AFace) Then
    Begin
      Try
        bmp.LoadFromFile(AFace);
        Result := True;
      Except
      End;
    End;

    If Not Result Then
      bmp.LoadFromResourceID(HInstance, 5010); // face

    FOldFace := FFace;
    Result := True;
  End;

  Function LoadDigit: Boolean;
  Begin
    Result := False;

    If AnsiSameText(FDigit, FOldDigit) Then
    Begin
      Result := FileExists(FDigit);
      Exit;
    End;

    If FileExists(FDigit) Then
    Begin
      Try
        tmp.LoadFromFile(ADigit);
        Result := True;
      Except
      End;
    End;

    If Not Result Then
      tmp.LoadFromResourceID(HInstance, 5011); // digit

    FOldDigit := FDigit;
    Result := true;
  End;

  Function FindBlackRect: Boolean;
  Var
    j, k, px, py: Integer;
  Label
    NotFind;
  Begin
    Result := False;
    With bmp Do
    Begin
      For j := 0 To Width - 110 Do
      Begin
        For k := 0 To Height - 25 Do
        Begin
          PosX := j;
          PosY := k;

          For px := j To j + 109 Do
          Begin
            For py := k To k + 24 Do
            Begin
              If Canvas.Pixels[px, py] <> clBlack Then
              Begin
                PosX := -1;
                PosY := -1;
                Goto NotFind;
              End;
            End;
          End;
          Result := (PosX <> -1) And (PosY <> -1);
          If Result Then
            Exit;

          NotFind:

        End;
      End;
    End;
  End;

Begin
  tmp := TBitmap.Create;

  If Not LoadFace Then
    bmp.LoadFromResourceID(HInstance, 5010); // face

  If Not FindBlackRect Then
  Begin
    bmp.LoadFromResourceID(HInstance, 5010); // face
    PosX := 5;
    PosY := 7;
  End;

  If Not LoadDigit Then
    tmp.LoadFromResourceID(HInstance, 5011); // digit

  With Rgn Do
  Begin
    Mask := bmp;
    TransparentColor := bmp.Canvas.Pixels[0, 0];
    Regionize;
  End;

  cmRt := Bounds(PosX, PosY, 110, 25);

  For i := 0 To 11 Do
  Begin
    SetRect(rt, i * 15, 0, (i + 1) * 15, 25);

    With tm[i] Do
    Begin
      Width := 15;
      Height := 25;
      Canvas.CopyRect(Rect(0, 0, Width, Height), tmp.Canvas, rt);
    End;
  End;

  tmp.Free;
End;

Procedure TfrmTime.PaintDigit;
Begin
  With cmRt Do
    BitBlt(Canvas.Handle, Left, Top, Right, Bottom, bmpDigit.Canvas.Handle, 0,
      0, SRCCOPY);

End;

Procedure TfrmTime.FaceClick(Sender: TObject);
Var
  p: Integer;
Begin
  If Sender Is TMenuItem Then
  Begin
    p := (Sender As TMenuItem).Tag;
    If (p < FaceList.Count) And (p > -1) Then
      SendMessage(Handle, WM_CHGFACE, p, 0);
  End;
End;

Procedure TfrmTime.DigitClick(Sender: TObject);
Var
  p: Integer;
Begin
  If Sender Is TMenuItem Then
  Begin
    p := (Sender As TMenuItem).Tag;
    If (p < DigitList.Count) And (p > -1) Then
      SendMessage(Handle, WM_CHGDIGIT, p, 0);
  End;
End;

Procedure TfrmTime.popOptionClick(Sender: TObject);
Begin
  frmOption.ActivatePage(0);
  frmOption.Show;
End;

Procedure TfrmTime.popAutoRunClick(Sender: TObject);
Begin
  SetAutoRun(popAutoRun.Checked);
  If frmOption <> Nil Then
    frmOption.chkAutoRun.Checked := popAutoRun.Checked;
End;

Procedure TfrmTime.WMTIMERALPHA(Var Message: TMessage);
Begin
  AlphaBlendValue := lo(Message.WParam);
End;

Procedure TfrmTime.popRandImg(Sender: TObject);
Begin
  If frmOption <> Nil Then
    frmOption.chkRandImg.Checked := popRandFace.Checked;
End;

Function TfrmTime.GetFaceIndex: Integer;
Var
  i: Integer;
Begin
  Result := -1;
  For i := 0 To FaceList.Count - 1 Do
  Begin
    If AnsiSameText(FFace, FaceList[i]) Then
    Begin

      Result := i;
      break;
    End;
  End;
End;

Function TfrmTime.GetDigitIndex: Integer;
Var
  i: Integer;
Begin
  Result := -1;
  For i := 0 To DigitList.Count - 1 Do
  Begin
    If AnsiSameText(FDigit, DigitList[i]) Then
    Begin
      Result := i;
      break;
    End;
  End;
End;

Procedure TfrmTime.WMCHGFACE(Var Message: TMessage);
Begin
  popFace.Items[Message.WPARAM].Checked := True;

  FFace := FaceList[Message.WPARAM];
  If frmOption <> Nil Then
    frmOption.cbbFace.ItemIndex := GetFaceIndex;

  Init(FFace, FDigit);

  Invalidate;
End;

Procedure TfrmTime.WMCHGDIGIT(Var Message: TMessage);
Begin
  popDigit.Items[Message.WPARAM].Checked := True;

  FDigit := DigitList[Message.WPARAM];
  If frmOption <> Nil Then
    frmOption.cbbDigit.ItemIndex := GetDigitIndex;

  Init(FFace, FDigit);

  PaintDigit;
End;

Procedure TfrmTime.CreateParams(Var Params: TCreateParams);
Begin
  Inherited CreateParams(Params);
  With Params Do
  Begin
    If CheckWin32Version(5, 1) Then
      WindowClass.Style := WindowClass.style Or CS_DROPSHADOW;

    If NewStyleControls Then
      ExStyle := WS_EX_TOOLWINDOW Or WS_EX_TOPMOST Or ExStyle;
  End;
End;

End.