main.pas

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

Unit Main;

Interface

Uses Forms,
  Classes,
  Controls,
  StdCtrls,
  ExtCtrls,
  MacForm,
  CustomCtrls,
  FileCtrl,
  LunarCalendar,
  Windows,
  Messages,
  Graphics,
  Math,
  SysUtils,
  Menus,
  Dialogs,
  Spin;

Type
  TfrmMain = Class(TForm)
    MacPic: TMacBody;
    MacButtom: TMacPanel;
    MacLunar: TMacBody;
    picList: TPictureListBox;
    MacLeft: TMacLeftButton;
    MacRight: TMacRightButton;
    CalLunar: TLunarPanel;
    PrevYear: TMacPrevMonth;
    NextYear: TMacNextMonth;
    NextMonth: TMacNextYear;
    PrevMonth: TMacPrevYear;
    Current: TMacCurrent;
    pmCal: TPopupMenu;
    popGrid: TMenuItem;
    popBorder: TMenuItem;
    popGridColor: TMenuItem;
    popBorderColor: TMenuItem;
    popWeekEndColor: TMenuItem;
    popTermColor: TMenuItem;
    popTodayColor: TMenuItem;
    N2: TMenuItem;
    popCalType: TMenuItem;
    popSolar: TMenuItem;
    popLunar: TMenuItem;
    popSLunar: TMenuItem;
    popLSunar: TMenuItem;
    popCnWeek: TMenuItem;
    popColor: TMenuItem;
    popFont: TMenuItem;
    popLFont: TMenuItem;
    popSFont: TMenuItem;
    popYFont: TMenuItem;
    popWFont: TMenuItem;
    MacOpen: TMacSmallButton;
    chkChgWall: TCheckBox;
    MacSpin: TMacSpinEdit;
    cbbTime: TComboBox;
    lblTime: TLabel;
    cbbStyle: TComboBox;
    pmList: TPopupMenu;
    popDefIcon: TMenuItem;
    popPrevIcon: TMenuItem;
    N1: TMenuItem;
    popShadow: TMenuItem;
    N3: TMenuItem;
    popChgNow: TMenuItem;
    N4: TMenuItem;
    popExit: TMenuItem;
    MacHeader: TMacHeader;
    N5: TMenuItem;
    pmClear: TMenuItem;

    Procedure MacOpenClick(Sender: TObject);
    Procedure MacLeftClick(Sender: TObject);
    Procedure MacRightClick(Sender: TObject);
    Procedure FormCreate(Sender: TObject);
    Procedure PrevYearClick(Sender: TObject);
    Procedure NextMonthClick(Sender: TObject);
    Procedure PrevMonthClick(Sender: TObject);
    Procedure CurrentClick(Sender: TObject);
    Procedure NextYearClick(Sender: TObject);
    Procedure popGridClick(Sender: TObject);
    Procedure pmCalPopup(Sender: TObject);
    Procedure popBorderClick(Sender: TObject);
    Procedure popGridColorClick(Sender: TObject);
    Procedure popBorderColorClick(Sender: TObject);
    Procedure popWeekEndColorClick(Sender: TObject);
    Procedure popTermColorClick(Sender: TObject);
    Procedure popTodayColorClick(Sender: TObject);
    Procedure popCalTypeClick(Sender: TObject);
    Procedure popCnWeekClick(Sender: TObject);
    Procedure popLFontClick(Sender: TObject);
    Procedure popSFontClick(Sender: TObject);
    Procedure popYFontClick(Sender: TObject);
    Procedure popWFontClick(Sender: TObject);
    Procedure MacPicMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    Procedure chkChgWallClick(Sender: TObject);
    Procedure cbbTimeChange(Sender: TObject);
    Procedure MacSpinChange(Sender: TObject);
    Procedure pmListPopup(Sender: TObject);
    Procedure popPrevIconClick(Sender: TObject);
    Procedure popShadowClick(Sender: TObject);
    Procedure popChgNowClick(Sender: TObject);
    Procedure popExitClick(Sender: TObject);
    Procedure pmClearClick(Sender: TObject);

  Private
    tmpFont: TFont;
    ExpCount, FCount, iCount: Integer;
    FBusy: Boolean;

    Timer: TTimer;
    FPath, FText1, FText2: String;
    OutPath: String;
    Pos: TPoint;
  Protected
    Procedure SessionEnd(Var Message: TMessage); Message WM_ENDSESSION;
    Procedure VisibleItem(f: Boolean);
    Procedure GetFont(AMax: Integer = 15);
    Procedure TimerTimer(Sender: TObject);
    Function GetColor: TColor;
    Procedure ChgWallPaper;
    Procedure ChgTo(AName: String);
    Procedure WMTIMERALPHA(Var Message: TMessage); Message WM_TIMERALPHA;
    Procedure WMOPENFILEOVER(Var Message: TMessage); Message WM_OPENFILEOVER;
    Procedure WMOPENFILEBEGIN(Var Message: TMessage); Message WM_OPENFILEBEGIN;
    Procedure WMOPENFILENEXT(Var Message: TMessage); Message WM_OPENFILENEXT;
  Public
    OpenLast: Boolean;
    Destructor Destroy; Override;
    property Busy: Boolean read FBusy write FBusy;
  End;

Var
  frmMain: TfrmMain;

Implementation

{$R *.dfm}
Const
  fC: Array[0..9] Of integer = (3600 * 6, 3600 * 5, 3600 * 4, 3600 * 3, 3600
    * 2, 3600, 1800, 900, 300, 60);

Procedure TfrmMain.MacOpenClick(Sender: TObject);
Begin
  If SelectDirectory('选择图片所在目录!', '', FPath) Then
    picList.OpenPath(FPath);
End;

Procedure TfrmMain.MacLeftClick(Sender: TObject);
Begin
  VisibleItem(True);
  MacHeader.Caption := FText1;
End;

Procedure TfrmMain.MacRightClick(Sender: TObject);
Begin
  VisibleItem(False);
  MacHeader.Caption := FText2;
End;

Procedure TfrmMain.FormCreate(Sender: TObject);
Var
  tmp: integer;
Begin

  AlphaBlend := True;

  tmpFont := TFont.Create;
  iCount := 1;

  With CalLunar.TodayRec Do
    FText1 :=
      Format('今天是%d年%d月%d日 星期%s  农历 %d年%d月%d日 %s',
      [iSolarYear, iSolarMonth, iSolarDay, sCnWeekName, iLunarYear, iLunarMonth,
      iLunarDay, sLunarYear, solarTerm]);

  MacRight.OnClick := MacRightClick;
  MacLeft.OnClick := MacLeftClick;

  Timer := TTimer.Create(self);
  With Timer Do
  Begin
    Enabled := false;
    OnTimer := TimerTimer;
  End;

  tmp := appinf.ReadInteger(sDesktop, 'Times', cbbTime.Items.Count - 1);
  If (tmp < 0) Or (tmp > cbbTime.Items.Count - 1) Then
    tmp := cbbTime.Items.Count - 1;
  cbbTime.ItemIndex := tmp; // set time index

  cbbTimeChange(Nil); //

  chkChgWall.Checked := appInf.ReadBool(sDesktop, 'ChgWall', true);
  FPath := appinf.ReadString(sDesktop, 'LastPath', '');
  OpenLast := AppInf.ReadBool(sOption, 'OpenLast', False);

  outpath := WinPath + 'WallPaper.bmp';

  SendMessage(handle, WM_OPENFILEOVER, 0, 0);

  RestoreState(Self);

  MacLeftClick(Self);

  If OpenLast And directoryExists(fpath) Then
    picList.OpenPath(FPath);
End;

Procedure TfrmMain.VisibleItem(f: Boolean);
Begin
  MacPic.Visible := f;
  MacLunar.Visible := Not f;
  MacLeft.Visible := Not f;
  MacRight.Visible := f;
End;

Procedure TfrmMain.SessionEnd(Var Message: TMessage);
Begin
  Message.WParam := Integer(True);

  Close;
End;

Destructor TfrmMain.Destroy;
Begin
  appInf.WriteBool(sDesktop, 'ChgWall', chkChgWall.Checked);
  appinf.Writeinteger(sDesktop, 'Times', cbbTime.ItemIndex);
  appinf.WriteString(sDesktop, 'LastPath', FPath);
  appInf.WriteBool(sDesktop, 'OpenLast', OpenLast);

  SaveState(Self);
  tmpFont.Free;

  Inherited;
End;

Procedure TfrmMain.PrevYearClick(Sender: TObject);
Begin
  CalLunar.PrevYear;
End;

Procedure TfrmMain.NextMonthClick(Sender: TObject);
Begin
  CalLunar.NextMonth;
End;

Procedure TfrmMain.PrevMonthClick(Sender: TObject);
Begin
  CalLunar.PrevMonth;
End;

Procedure TfrmMain.CurrentClick(Sender: TObject);
Begin
  CalLunar.UpdateDateNow;
End;

Procedure TfrmMain.NextYearClick(Sender: TObject);
Begin
  CalLunar.NextYear;
End;

Procedure TfrmMain.popGridClick(Sender: TObject);
Begin
  CalLunar.ShowGrid := popGrid.Checked;
End;

Procedure TfrmMain.popBorderClick(Sender: TObject);
Begin
  CalLunar.ShowBorder := popBorder.Checked;
End;

Function TfrmMain.GetColor: TColor;
Begin
  Result := clNone;
  With TColorDialog.Create(Self) Do
  Begin
    Options := [cdAnyColor];
    If Execute Then
      Result := Color;
    Free;
  End;
End;

Procedure TfrmMain.popGridColorClick(Sender: TObject);
Var
  c: TColor;
Begin
  c := GetColor;
  If c <> clNone Then
    CalLunar.GridColor := c;
End;

Procedure TfrmMain.popBorderColorClick(Sender: TObject);
Var
  c: TColor;
Begin
  c := GetColor;
  If c <> clNone Then
    CalLunar.BorderColor := c;
End;

Procedure TfrmMain.popWeekEndColorClick(Sender: TObject);
Var
  c: TColor;
Begin
  c := GetColor;
  If c <> clNone Then
    CalLunar.WeekEndColor := c;
End;

Procedure TfrmMain.popTermColorClick(Sender: TObject);
Var
  c: TColor;
Begin
  c := GetColor;
  If c <> clNone Then
    CalLunar.TermColor := c;
End;

Procedure TfrmMain.popTodayColorClick(Sender: TObject);
Var
  c: TColor;
Begin
  c := GetColor;
  If c <> clNone Then
    CalLunar.TodayColor := c;
End;

Procedure TfrmMain.popCalTypeClick(Sender: TObject);
Var
  p: Integer;
Begin
  If Sender Is TMenuItem Then
  Begin
    p := (Sender As TMenuItem).Tag;
    CalLunar.CalendarType := tcalendartype(p);
  End;
End;

Procedure TfrmMain.popCnWeekClick(Sender: TObject);
Begin
  CalLunar.EnWeekName := Not popCnWeek.Checked;
End;

Procedure TfrmMain.popLFontClick(Sender: TObject);
Begin
  tmpFont.Assign(CalLunar.SolarFont);
  GetFont;
  If tmpFont.Size > 1 Then
    CalLunar.SolarFont := tmpFont;
End;

Procedure TfrmMain.GetFont(AMax: Integer = 15);
Begin
  With TFontDialog.Create(Self) Do
  Begin
    Font.Assign(tmpFont);
    MaxFontSize := AMax;
    MinFontSize := 8;
    If Execute Then
      tmpFont.Assign(Font)
    Else
      tmpFont.Size := 1;
    Free;
  End;
End;

Procedure TfrmMain.popSFontClick(Sender: TObject);
Begin
  tmpFont.Assign(CalLunar.LunarFont);
  GetFont;
  If tmpFont.Size > 1 Then
    CalLunar.LunarFont := tmpFont;
End;

Procedure TfrmMain.popYFontClick(Sender: TObject);
Begin
  tmpFont.Assign(CalLunar.BackFont);
  GetFont(100);
  If tmpFont.Size > 1 Then
    CalLunar.BackFont := tmpFont;
End;

Procedure TfrmMain.popWFontClick(Sender: TObject);
Begin
  tmpFont.Assign(CalLunar.WeekFont);
  GetFont;
  If tmpFont.Size > 1 Then
    CalLunar.WeekFont := tmpFont;
End;

Procedure TfrmMain.MacPicMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
Begin
  SendMessage(Callunar.Handle, WM_HIDELUNAR, 0, 0);
End;

Procedure TfrmMain.chkChgWallClick(Sender: TObject);
Var
  f: Boolean;
Begin
  f := chkChgWall.Checked;

  macSpin.Enabled := f And (cbbTime.ItemIndex = cbbTime.Items.Count - 1);
  cbbtime.Enabled := f;

  Timer.Enabled := f And (picList.Count > 0) And (Not FBusy);
End;

Procedure TfrmMain.cbbTimeChange(Sender: TObject);
Var
  i: integer;
Begin
  i := cbbTime.ItemIndex;
  macSpin.Enabled := (i = cbbTime.Items.Count - 1);

  ExpCount := fC[i];

  If i = 9 Then
    ExpCount := ExpCount * iCount;

  FCount := 0;
End;

Procedure TfrmMain.TimerTimer(Sender: TObject);
Begin
  inc(FCount);

  MacButtom.Caption := format('剩下[ %d ]秒改变壁纸', [ExpCount - FCount]);
  If FCount >= ExpCount Then
  Begin
    ChgWallPaper;
    FCount := 0;
  End;
End;

Procedure TfrmMain.ChgWallPaper;
Var
  p: integer;
Begin
  If picList.Count = 0 Then
    exit;

  p := RandomRange(0, picList.Count);
  If p >= picList.Count Then
    p := 0;
  cHGtO(picList.Items[p]);
End;

Procedure TfrmMain.WMOPENFILEOVER(Var Message: TMessage);
Begin
  FBusy := False;

  FText2 := format('总共 %d 张图片可供使用', [picList.Count]);
  MacHeader.Caption := FText2;

  chkChgWallClick(Nil); // Check Time
End;

Procedure TfrmMain.MacSpinChange(Sender: TObject);
Begin
  iCount := MacSpin.Value;

  If cbbTime.ItemIndex = 9 Then
    ExpCount := fC[cbbTime.ItemIndex] * iCount;
End;

Procedure TfrmMain.popPrevIconClick(Sender: TObject);
Var
  p: integer;
Begin
  If sender Is tmenuItem Then
  Begin
    p := (sender As tmenuItem).Tag;
    Case p Of
      0: picList.PreviewIcon := false;
      1: picList.PreviewIcon := true;
    End;
  End;
End;

Procedure TfrmMain.WMOPENFILEBEGIN(Var Message: TMessage);
Begin
  FBusy := true;
  Timer.Enabled := False;
End;

Procedure TfrmMain.popShadowClick(Sender: TObject);
Begin
  CalLunar.EffectFont.Effect.Shadow.Enabled := popShadow.Checked;
  CalLunar.UpdateDateNow;
End;

Procedure TfrmMain.pmCalPopup(Sender: TObject);
Begin
  popGrid.Checked := CalLunar.ShowGrid;
  popBorder.Checked := CalLunar.ShowBorder;
  popGridColor.Enabled := popGrid.Checked;
  popBorderColor.Enabled := popBorder.Checked;
  popCnWeek.Checked := Not CalLunar.EnWeekName;
  popShadow.Checked := CalLunar.EffectFont.Effect.Shadow.Enabled;

  popCalType.Items[Integer(CalLunar.CalendarType)].Checked := True;
End;

Procedure TfrmMain.pmListPopup(Sender: TObject);
Begin
  GetCursorPos(Pos);
  pmList.Items[Integer(picList.PreviewIcon)].Checked := True;
  pmClear.Enabled := Not FBusy;
  popChgNow.Enabled := (Not FBusy) And (picList.Count > 0);
End;

Procedure TfrmMain.ChgTo(AName: String);
Var
  tmp: TBitmap;
Begin
  tmp := getBitmap(AName);
  If tmp <> Nil Then
  Begin
    tmp.SaveToFile(outpath);
    MacForm.ChgWallPaper(outpath, TWallStyle(cbbStyle.ItemIndex));

    tmp.Free;
  End;
End;

Procedure TfrmMain.popChgNowClick(Sender: TObject);
Var
  id: Integer;
Begin
  pos := picList.ScreenToClient(pos);
  id := picList.ItemAtPos(pos, True);

  If id <> -1 Then
    ChgTo(Piclist.Items[id]);
End;

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

Procedure TfrmMain.popExitClick(Sender: TObject);
Begin
  SendMessage(Callunar.Handle, WM_HIDELUNAR, 0, 0);
  Hide;
End;

Procedure TfrmMain.pmClearClick(Sender: TObject);
Begin
  picList.Clear;
  Timer.Enabled := false;
End;

Procedure TfrmMain.WMOPENFILENEXT(Var Message: TMessage);
Begin
  If MacLeft.Visible Then
    MacHeader.Caption := format('总共 %d 张图片可供使用', [picList.Count]);
End;

End.