main.pas

在深度历险网站上发布的所有delphi程序原码。对初学delphi者很有用。

unit main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, Buttons, ComCtrls, Menus, IniFiles, Registry, MMSystem, Util;

type
  TMainForm = class(TForm)
    PageControl: TPageControl;
    tabPreview: TTabSheet;
    imgPreview: TImage;
    tabColors: TTabSheet;
    lbxColors: TListBox;
    gbxColors: TGroupBox;
    lblRValue: TLabel;
    lblGValue: TLabel;
    lblBValue: TLabel;
    pnlColor: TPanel;
    tabCursor: TTabSheet;
    lbxCursors: TListBox;
    gbxCursors: TGroupBox;
    Label4: TLabel;
    Label1: TLabel;
    txtCursorFile: TEdit;
    pnlCursor: TPanel;
    imgCursor: TImage;
    tabSound: TTabSheet;
    lbxSounds: TListBox;
    gbxSounds: TGroupBox;
    Label2: TLabel;
    txtSoundFile: TEdit;
    pnlPlaySound: TPanel;
    btnPlaySound: TSpeedButton;
    btnStopPlay: TSpeedButton;
    tabFonts: TTabSheet;
    lbxFonts: TListBox;
    gbxFonts: TGroupBox;
    tabDesktop: TTabSheet;
    lbxDesktop: TListBox;
    gbxDesktop: TGroupBox;
    nbkDesktop: TNotebook;
    Label7: TLabel;
    txtDesktopFile: TEdit;
    pnlIcon: TPanel;
    imgIcon: TImage;
    btnPreview: TButton;
    lblHorizontal: TLabel;
    lblVertical: TLabel;
    lblBorderWidth: TLabel;
    lblTitleWrap: TLabel;
    cbxMetricsKind: TComboBox;
    mnuMain: TMainMenu;
    mnuFile: TMenuItem;
    mnuHelp: TMenuItem;
    mnuExit: TMenuItem;
    mnuAbout: TMenuItem;
    N1: TMenuItem;
    mnuOpen: TMenuItem;
    lblFontName: TLabel;
    lblFontSize: TLabel;
    lblFontStyle: TLabel;
    N2: TMenuItem;
    mnuApply: TMenuItem;
    dlgOpen: TOpenDialog;
    mnuCurrent: TMenuItem;
    N3: TMenuItem;
    procedure mnuOpenClick(Sender: TObject);
    procedure lbxColorsDrawItem(Control: TWinControl; index: Integer;
      Rect: TRect; State: TOwnerDrawState);
    procedure lbxCursorsDrawItem(Control: TWinControl; index: Integer;
      Rect: TRect; State: TOwnerDrawState);
    procedure lbxFontsDrawItem(Control: TWinControl; index: Integer;
      Rect: TRect; State: TOwnerDrawState);
    procedure lbxDesktopDrawItem(Control: TWinControl; index: Integer;
      Rect: TRect; State: TOwnerDrawState);
    procedure lbxColorsClick(Sender: TObject);
    procedure lbxCursorsClick(Sender: TObject);
    procedure lbxSoundsClick(Sender: TObject);
    procedure lbxFontsClick(Sender: TObject);
    procedure btnPlaySoundClick(Sender: TObject);
    procedure lbxDesktopClick(Sender: TObject);
    procedure cbxMetricsKindChange(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure mnuApplyClick(Sender: TObject);
    procedure btnPreviewClick(Sender: TObject);
    procedure mnuCurrentClick(Sender: TObject);
  private
    FThemePath, FThemeName: string;
    
    // ========= Theme Data Start ========== //
    FMyIcons: array[TMyIcon] of string;
    FMyColors: array[TMyColor] of TColor;
    FMyCursors: array[TMyCursor] of string;
    FMySounds: array[TMySound] of string;
    FMyFonts: array[TMyFont] of TLogFont;
    FWallPaper, FScreenSaver: string;
    FWallPaperStyle, FTileWallPaper: Integer;
    FPattern: string;
    
    FIM: TIconMetrics; // ICONMETRICS
    FNM: TNonClientMetrics;
    // ========= Theme Data End ========== //
    
    FMyCursorIcons: array[TMyCursor] of HICON;
    FMyIconIcons: array[TMyIcon] of HICON;
    FWallPaperBits: TBitmap;
    
    procedure ReadThemeFile(const Filename: string);
    procedure LoadDesc;
    procedure LoadThemeComponents;
    
    procedure DrawTheme(DrawCanvas: TCanvas);
    procedure UpdateCaption;
    procedure ApplyTheme;
    procedure LoadCurrentSettings;
  public
    { Public declarations }
  end;
  
var
  MainForm: TMainForm;
  
implementation

uses xUtils, xGraphics, xKernel, xFiles, xFonts, xRegistry, xDesktop, xControls;

{$R *.DFM}

procedure TMainForm.mnuOpenClick(Sender: TObject);
begin
  if dlgOpen.Execute then
  begin
    ReadThemeFile(dlgOpen.Filename);
    UpdateCaption;
  end;
end;

procedure TMainForm.LoadDesc;
var
  J: TMyCursor; 
  K: TMyIcon;   
  L: TMyColor;  
  F: TMyFont;   
  D: TMyDesktop;
  I: TMySound;  
begin
  lbxColors.Items.Clear;
  for L := Low(FMyColors) to High(FMyColors) do
    lbxColors.Items.Add(MyColorDesc[L]);
  
  lbxCursors.Items.Clear;
  for J := Low(FMyCursors) to High(FMyCursors) do
    lbxCursors.Items.Add(MyCursorDesc[J]);
  
  lbxSounds.Items.Clear;
  with TRegIniFile.Create('AppEvents\EventLabels') do
    try
      for I := Low(FMySounds) to High(FMySounds) do
        lbxSounds.Items.Add(ReadString(MySoundDescKey[I], '', MySoundDescKey[I]));
    finally
      Free;
    end;
  
  lbxFonts.Items.Clear;
  for F := Low(FMyFonts) to High(FMyFonts) do
    lbxFonts.Items.Add(MyFontDesc[F]);
  
  lbxDesktop.Items.Clear;
  for K := Low(FMyIcons) to High(FMyIcons) do
    lbxDesktop.Items.Add(MyIconDesc[K]);
  
  for D := Low(TMyDesktop) to High(TMyDesktop) do
    lbxDesktop.Items.Add(MyDesktopDesc[D]);
end;



procedure TMainForm.ReadThemeFile(const Filename: string);
var
  IniFile: TIniFile;
  
  function ReadSetting(const Section: string; Ident: string): string;
  var
    S: string;
  begin
    if Ident = '' then Ident := 'DefaultValue';
    Result := IniFile.ReadString(Section, Ident, '');
    
    S := FThemePath + ExtractFileName(Result);
    
    if FileExistsAfterTruncate(S) then
    begin
      Result := S;
      Exit;
    end;
  end;
  
  procedure ReadOthers;
  var
    S: string;
  begin
    FWallPaper := ReadSetting(secDesktop, 'WallPaper');
    
    FWallPaperStyle := StrToIntDef(ReadSetting(secDesktop, 'WallPaperStyle'), 0);
    FTileWallPaper := StrToIntDef(ReadSetting(secDesktop, 'TileWallPaper'), 0);
    FPattern := ReadSetting(secDesktop, 'Pattern');
    
    S := ReadSetting(secBoot, 'SCRNSAVE.EXE');
    FScreenSaver := S;
  end;
  
  procedure ReadMySounds;
  var
    I: TMySound;
  begin
    for I := Low(FMySounds) to High(FMySounds) do
      FMySounds[I] := ReadSetting('AppEvents\Schemes\Apps\' + MySoundSect[I], '');
  end;
  
  procedure ReadMetrics;
  var
    S: string;
  begin
    S := ReadSetting(secMetrics, 'IconMetrics');
    StringToBuffer(S, @FIM, SizeOf(FIM));
    S := ReadSetting(secMetrics, 'NonClientMetrics');
    StringToBuffer(S, @FNM, SizeOf(FNM));
    
    FMyFonts[mfIcon] := FIM.lfFont;
    FMyFonts[mfCaptionFont] := FNM.lfCaptionFont;
    FMyFonts[mfsmCaptionFont] := FNM.lfSmCaptionFont;
    FMyFonts[mfMenuFont] := FNM.lfMenuFont;
    FMyFonts[mfStatusFont] := FNM.lfStatusFont;
    FMyFonts[mfMessageFont] := FNM.lfMessageFont;
  end;
  
  procedure ReadMyIcons;
  begin
    if IniFile.SectionExists(secMyComputerKey) then
      FMyIcons[mcMyComputer] := ReadSetting(secMyComputerKey, '') // for shit win98's theme
    else
      FMyIcons[mcMyComputer] := ReadSetting(secMyComputer, '');
    
    if IniFile.SectionExists(secNeighborKey) then
      FMyIcons[mcNeighbor] := ReadSetting(secNeighborKey, '')
    else
      FMyIcons[mcNeighbor] := ReadSetting(secNeighbor, '');
    
    if IniFile.SectionExists(secRecycleBinKey) then
    begin
      FMyIcons[mcRecycleBinFull] := ReadSetting(secRecycleBinKey, 'full');
      FMyIcons[mcRecycleBinEmpty] := ReadSetting(secRecycleBinKey, 'empty');
    end else
    begin
      FMyIcons[mcRecycleBinFull] := ReadSetting(secRecycleBin, 'full');
      FMyIcons[mcRecycleBinEmpty] := ReadSetting(secRecycleBin, 'empty');
    end;
  end;
  
  procedure ReadMyColors;
  var
    I: TMyColor;
    S: string;  
  begin
    for I := Low(FMyColors) to High(FMyColors) do
    begin
      S := ReadSetting(secColors, MyColorID[I]);
      if S <> '' then FMyColors[I] := RGBStringToColor(S)
      else
      begin
        if I = GradientActiveTitle then
          FMyColors[I] := FMyColors[ActiveTitle]
        else if I = GradientInActiveTitle then
          FMyColors[I] := FMyColors[InActiveTitle]
        else FMyColors[I] := -1; // 箇砞