macform.pas

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

Unit MacForm;

Interface

Uses
  Windows,
  Messages,
  SysUtils,
  Classes,
  Graphics,
  Controls,
  Forms,
  IniFiles,
  ExtCtrls,
  Menus,
  Math,
  FileCtrl,
  jpeg,
  DateUtils,
  Registry,
  StdCtrls,
  Spin;
Const
  WM_HIDELUNAR = WM_USER + 1;
  WM_OPENFILEOVER = WM_USER + 2;
  WM_OPENFILEBEGIN = WM_USER + 3;
  WM_TIMERALPHA = WM_USER + 5;
  WM_CHGFACE = WM_USER + 6;
  WM_CHGDIGIT = WM_USER + 7;
  WM_OPENFILENEXT = WM_USER + 8;

Type
  TMenuOption = (moAutoCheck, moChecked, moDefault, moEnabled, moRadioItem);
  TMenuOptions = Set Of TMenuOption;

  TWallStyle = (wsCenter, wsTile, wsStretch);
  TMacHeader = Class;

  TMacBaseButton = Class(TCustomControl)
  Private
    FResID, aWidth: Integer;
    bmpIn: TBitmap;
    bMouseIn: Boolean;
    Procedure MouseEnter(Var Msg: TMessage); Message CM_MOUSEENTER;
    Procedure MouseLeave(Var Msg: TMessage); Message CM_MOUSELEAVE;
  Protected
    Procedure SetResID(Value: Integer); Virtual;
  Public
    Constructor Create(AOwner: TComponent); Override;
    Destructor Destroy; Override;
    Property ResID: Integer Read FResID Write SetResID;
  Published
    Property OnClick;
  End;

  TSmoothFont = Class(TFont)
  Private
    BigBmp, tmpBmp: TBitmap;
  Public
    Procedure Draw(AX, AY: Integer; Canvas: TCanvas; Const Text: String);
    Constructor CreateNew; Virtual;
    Destructor Destroy; Override;
    Function TextSize(Const Text: String): TSize;
  End;

  TMacTwoButton = Class(TMacBaseButton)
  Private
    bmpOut: TBitmap;

  Protected
    Procedure Paint; Override;
    Procedure SetResID(Value: Integer); Override;
  Public
    Constructor Create(AOwner: TComponent); Override;
    Destructor Destroy; Override;
  Published
  End;

  TMacPanel = Class(TCustomPanel)
  Private
    Bitmap: TBitmap;
    FNoBorder: Boolean;
    Procedure SetNoBorder(Value: Boolean);
  Protected
    Procedure Paint; Override;
    Procedure Resize; Override;
  Public
    Constructor Create(AOwner: TComponent); Override;
    Destructor Destroy; Override;
  Published
    Property Align;
    Property Caption;
    Property Color;
    Property Visible;
    Property OnMouseDown;
    Property OnMouseMove;
    Property OnMouseUp;
    Property NoBorder: Boolean Read FNoBorder Write SetNoBorder;
  End;

  TMacButton = Class(TMacTwoButton)
  Public
    Constructor Create(AOwner: TComponent); Override;
  End;

  TMacCheckButton = Class(TMacTwoButton)
  Private
    FChecked: Boolean;
    Procedure MouseEnter(Var Msg: TMessage); Message CM_MOUSEENTER;
    Procedure MouseLeave(Var Msg: TMessage); Message CM_MOUSELEAVE;
    Procedure SetChecked(Value: Boolean);
  Protected
  Public
    Procedure Click; Override;
    Constructor Create(AOwner: TComponent); Override;
    Property Checked: Boolean Read FChecked Write SetChecked;
  End;

  TMacCloseButton = Class(TMacTwoButton)
  Protected
    Procedure Click; Override;
  Public
    Constructor Create(AOwner: TComponent); Override;
  End;

  TMacMinButton = Class(TMacTwoButton)
  Protected
    Procedure Click; Override;
  Public
    Constructor Create(AOwner: TComponent); Override;
  End;

  TMacSmallButton = Class(TMacTwoButton)
  Public
    Constructor Create(AOwner: TComponent); Override;
  End;

  TMacBody = Class(TMacPanel)
  Protected
  Public
    Constructor Create(AOwner: TComponent); Override;
  End;

  TMacLeftButton = Class(TMacTwoButton)
  Public
    Constructor Create(AOwner: TComponent); Override;
  End;

  TMacRightButton = Class(TMacTwoButton)
  Protected
  Public
    Constructor Create(AOwner: TComponent); Override;
  End;

  TMacHeader = Class(TCustomPanel)
  Private
    Bitmap: TBitmap;
    MacMin: TMacMinButton;
    MacClose: TMacCloseButton;
    FOnCloseClick: TNotifyEvent;

  Protected
    Procedure NCHITTEST(Var Message: TMessage); Message WM_NCHITTEST;
    Procedure Resize; Override;
    Procedure Paint; Override;
    Procedure CloseClick(Sender: TObject);
  Public
    Constructor Create(AOwner: TComponent); Override;
    Destructor Destroy; Override;
  Published
    Property Caption;
    Property Font;
    Property OnCloseClick: TNotifyEvent Read FOnCloseClick Write FOnCloseClick;
  End;

  TCanvasPanel = Class(TPanel)
  Public
    Property Canvas;
  End;

  TMacOneButton = Class(TMacBaseButton)
  Protected
    Procedure SetResID(Value: Integer); Override;
    Procedure Paint; Override;
  End;

  TMacNextYear = Class(TMacOneButton)
  Public
    Constructor Create(AOwner: TComponent); Override;
  End;

  TMacNextMonth = Class(TMacOneButton)
  Public
    Constructor Create(AOwner: TComponent); Override;
  End;

  TMacCurrent = Class(TMacOneButton)
  Public
    Constructor Create(AOwner: TComponent); Override;
  End;

  TMacPrevYear = Class(TMacOneButton)
  Public
    Constructor Create(AOwner: TComponent); Override;
  End;

  TMacPrevMonth = Class(TMacOneButton)
  Public
    Constructor Create(AOwner: TComponent); Override;
  End;

  TMacSpinEdit = Class(TSpinEdit)
  Published
    Property BevelEdges;
    Property BevelInner;
    Property BevelKind Default bkNone;
    Property BevelOuter;
    Property BorderStyle;
  End;

Procedure Register;

Function NewMenuItem(Const ACaption: String; AOnClick: TNotifyEvent = Nil; MO:
  TMenuOptions = [moEnabled]; ATag: integer = 0): TMenuItem; overload;

Procedure SaveState(aCtrl: TControl);

Procedure RestoreState(aCtrl: TControl);

Procedure RegWrite(Path, Name, Value: String); overload;

Procedure RegWrite(Path, Name: String; Value: integer); overload;

Function RegRead(Path, Name: String): String;

Procedure ColorToRGB(color: TColor; Var r, g, b: Integer);

Function getAlpha(per: byte): Byte;

Procedure SetAutoRun(f: boolean = true);

Procedure RegRemoveValue(Path, Name: String);

Procedure ChgWallPaper(Name: String; ws: TWallStyle = wsStretch);

Function ReadBackground: TColor;

Procedure CheckfrmMain;

Var
  AppReg: TRegistry;
  AppInf: TIniFile;
  AppName, AppPath, WinPath: String;

Const
  sClockStyles = 'ClockStyles';
  sClockFace = 'ClockFace';
  sClockDigit = 'ClockDigit';
  sOption = 'Option';
  sDesktop = 'Desktop';
Implementation
{$R form.RES}
Uses Main;

Const
  RegPath = '\SOFTWARE\Lunar\';

Procedure ColorToRGB(color: TColor; Var r, g, b: Integer);
Begin
  r := Byte(color);
  g := Byte(color Shr 8);
  b := Byte(color Shr 16);
End;

Function NewMenuItem(Const ACaption: String; AOnClick: TNotifyEvent = Nil; MO:
  TMenuOptions = [moEnabled]; ATag: integer = 0): TMenuItem;
Begin
  Result := TMenuItem.Create(Nil);
  With Result Do
  Begin
    Caption := ACaption;
    OnClick := AOnClick;

    RadioItem := moRadioItem In Mo;
    Checked := moChecked In Mo;
    AutoCheck := moAutoCheck In Mo;
    Enabled := moEnabled In mo;
    default := modefault In mo;

    Tag := atag;
  End;
End;

Procedure Register;
Begin
  RegisterComponents('Custom', [TMacHeader, TMacCloseButton, TMacMinButton,
    TMacPanel, TMacSmallButton, TMacCheckButton, TMacBody,
      TMacRightButton, TMacLeftButton, TMacSpinEdit,
      TMacNextYear, TMacNextMonth, TMacCurrent, TMacPrevYear,
      TMacPrevMonth]);
End;

Procedure SaveState(aCtrl: TControl);
Var
  s: String;
Begin
  With AppInf, aCtrl Do
  Begin
    s := Name + '.';
    WriteInteger(ClassName, s + 'Left', Left);
    WriteInteger(ClassName, s + 'Top', Top);
  End;
End;

Procedure RestoreState(aCtrl: TControl);
Var
  s: String;
  v: Integer;
Begin
  With AppInf, aCtrl Do
  Begin
    s := Name + '.';

    v := ReadInteger(ClassName, s + 'Left', 0);
    If v <> 0 Then
      Left := v;

    v := ReadInteger(ClassName, s + 'Top', 0);
    If v <> 0 Then
      Top := v;
  End;
End;

Procedure RegWrite(Path, Name, Value: String);
Begin
  If AppReg.OpenKey(Path, True) Then
  Begin
    AppReg.WriteString(Name, Value);
    AppReg.CloseKey;
  End;
End;

Procedure RegWrite(Path, Name: String; Value: integer);
Begin
  RegWrite(Path, Name, IntToStr(Value));
End;

Function RegRead(Path, Name: String): String;
Begin
  If AppReg.OpenKey(Path, True) Then
  Begin
    Result := AppReg.ReadString(Name);
    AppReg.CloseKey;
  End;
End;

Function getAlpha(per: byte): Byte;
Begin
  Result := lo(trunc((per / 100) * 255));
End;

Procedure SetAutoRun(f: boolean = true);
Const
  s = '\Software\Microsoft\Windows\CurrentVersion\Run';
Begin
  If f Then
    RegWrite(s, ExtractFileName(AppName), '"' + ParamStr(0) + '"')
  Else
    RegRemoveValue(s, ExtractFileName(AppName));
End;

Procedure RegRemoveValue(Path, Name: String);
Begin
  If AppReg.OpenKey(Path, False) Then
  Begin
    AppReg.DeleteValue(Name);
    AppReg.CloseKey;
  End;
End;

Procedure ChgWallPaper(Name: String; ws: TWallStyle = wsStretch);
Const
  s1 = '\Control Panel\Desktop\';
  s2 = 'WallpaperStyle';
  s3 = 'TileWallpaper';
Begin
  AppReg.RootKey := HKEY_CURRENT_USER;

  Case ws Of
    wsStretch:
      Begin
        RegWrite(s1, s2, 2);
        RegWrite(s1, s3, 0);
      End;

    wsTile:
      Begin
        RegWrite(s1, s2, 0);
        RegWrite(s1, s3, 1);

      End;

    wsCenter:
      Begin
        RegWrite(s1, s2, 0);
        RegWrite(s1, s3, 0);

      End;
  End;

  SystemParametersInfo(SPI_SETDESKWALLPAPER, 1, PChar(Name),
    SPIF_UPDATEINIFILE);
  UpdateWindow(GetDesktopWindow);

  AppReg.RootKey := HKEY_LOCAL_MACHINE;
End;

Function ReadBackground: TColor;
Var
  s, s1: String;
  p: Integer;
  r, g, b: Byte;
Begin
  AppReg.RootKey := HKEY_CURRENT_USER;
  s := RegRead('\Control Panel\Colors\', 'Background');

  p := Pos(' ', s);
  If p > 0 Then
  Begin
    s1 := Copy(s, 1, p - 1);
    Delete(s, 1, p);
  End;
  r := Lo(strtointdef(s1, 255));

  p := Pos(' ', s);
  If p > 0 Then
  Begin
    s1 := Copy(s, 1, p - 1);
    Delete(s, 1, p);
  End;
  g := Lo(strtointdef(s1, 255));
  b := Lo(strtointdef(s, 255));

  Result := RGB(r, g, b);

  AppReg.RootKey := HKEY_LOCAL_MACHINE;
End;

Procedure CheckfrmMain;
Begin
  If frmMain = Nil Then
    Application.CreateForm(TfrmMain, frmMain);
End;

Procedure TMacPanel.Paint;
Var
  p: Integer;
Var
  w, h: Integer;
Begin
  p := 0;
  While p < Height Do
  Begin
    Canvas.StretchDraw(Rect(0, p, Width, Bitmap.Height + p), Bitmap);
    Inc(p, Bitmap.Height);
  End;

  If FNoBorder Then
    exit;

  With Canvas Do
  Begin
    Pen.Color := $808080;
    MoveTo(0, 0);
    LineTo(0, Height - 1);
    LineTo(Width - 1, Height - 1);

    LineTo(Width - 1, 0);
  End;
  With Canvas Do
  Begin
    w := (Width - TextWidth(Caption)) Div 2;
    h := (Height - TextHeight(Caption)) Div 2;

    Brush.Style := bsClear;
    TextOut(w, h, Caption);
  End;
End;

Constructor TMacPanel.Create(AOwner: TComponent);
Begin
  Inherited;
  FNoBorder := false;
  Bitmap := TBitmap.Create;
  Bitmap.LoadFromResourceID(hInstance, 2001);
  BorderStyle := bsNone;
End;

Destructor TMacPanel.Destroy;
Begin
  Bitmap.Free;
  Inherited;
End;

Procedure TMacPanel.Resize;
Var
  i: Integer;
  ct: TControl;
Begin
  Inherited;
  For i := 0 To ControlCount - 1 Do
  Begin
    ct := Controls[i];
    If ct.ClassNameIs('TMacLeftButton') Then
      ct.Left := 1;
    If ct.ClassNameIs('TMacRightButton') Then
      ct.Left := Width - ct.Width - 1;
  End;
End;