bottleclient/ColorSettingFrame.pas

   1 unit ColorSettingFrame;
   2
   3 interface
   4
   5 uses
   6   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
   7   Dialogs, StdCtrls, ExtCtrls, Contnrs, Menus;
   8
   9 type
  10   TfrmColorSetting = class(TFrame)
  11     lstElement: TListBox;
  12     cbxColor: TColorBox;
  13     lblTheme: TLabel;
  14     btnSave: TButton;
  15     mnThemes: TPopupMenu;
  16     btnTheme: TButton;
  17     procedure lstElementDrawItem(Control: TWinControl; Index: Integer;
  18       Rect: TRect; State: TOwnerDrawState);
  19     procedure lstElementClick(Sender: TObject);
  20     procedure btnSaveClick(Sender: TObject);
  21     procedure btnThemeMouseDown(Sender: TObject; Button: TMouseButton;
  22       Shift: TShiftState; X, Y: Integer);
  23     procedure cbxColorChange(Sender: TObject);
  24   private
  25     FCurrentTheme: TStringList;
  26     FThemeList: TStringList;
  27     function Token(const Str: String; const Delimiter: char;
  28       const Index: integer): String;
  29     function SelectedColor: TColor;
  30     function ColorIndex(Index: integer): TColor;
  31     function GetColor(Key: String): TColor;
  32     procedure SetColor(Key: String; const Value: TColor);
  33     procedure mnThemeItemClick(Sender: TObject);
  34   protected
  35     procedure Loaded; override;
  36     procedure UpdateThemeList;
  37   public
  38     constructor Create(Owner: TComponent); override;
  39     destructor Destroy; override;
  40     property Color[Key: String]: TColor read GetColor write SetColor;
  41   end;
  42
  43 implementation
  44
  45 {$R *.dfm}
  46
  47 { TfrmColorSetting }
  48
  49 procedure TfrmColorSetting.lstElementDrawItem(Control: TWinControl;
  50   Index: Integer; Rect: TRect; State: TOwnerDrawState);
  51 var ItemName: String;
  52 begin
  53   ItemName := Token(lstElement.Items[Index], '|', 0);
  54   with lstElement.Canvas do begin
  55     TextRect(Rect, Rect.Left+lstElement.ItemHeight, Rect.Top+2, ItemName);
  56     Pen.Color := clBlack;
  57     Brush.Color := ColorIndex(Index);
  58     Rectangle(Rect.Left+2, Rect.Top+2, Rect.Left+lstElement.ItemHeight-4, Rect.Bottom-2);
  59   end;
  60 end;
  61
  62 function TfrmColorSetting.Token(const Str: String; const Delimiter: char;
  63   const Index: integer): String;
  64 var i, c, len: integer;
  65 begin
  66   i := 1;
  67   c := 0;
  68   len := length(Str);
  69   Result := '';
  70   while i <= len do begin
  71     if Str[i] = Delimiter then begin
  72       Inc(c);
  73       if c > Index then Break;
  74     end else if c = Index then Result := Result + Str[i];
  75     Inc(i);
  76   end;
  77 end;
  78
  79 constructor TfrmColorSetting.Create(Owner: TComponent);
  80 begin
  81   inherited;
  82   FCurrentTheme := TStringList.Create;
  83   FThemeList := TStringList.Create;
  84   UpdateThemeList;
  85 end;
  86
  87 destructor TfrmColorSetting.Destroy;
  88 begin
  89   inherited;
  90   FCurrentTheme.Free;
  91   FThemeList.Free;
  92 end;
  93
  94 procedure TfrmColorSetting.Loaded;
  95 begin
  96   inherited;
  97 end;
  98
  99 procedure TfrmColorSetting.lstElementClick(Sender: TObject);
 100 begin
 101   if lstElement.ItemIndex = -1 then begin
 102     cbxColor.Enabled := false;
 103   end else begin
 104     cbxColor.Enabled := true;
 105     cbxColor.Selected := SelectedColor;
 106     cbxColor.Invalidate;
 107   end;
 108 end;
 109
 110 function TfrmColorSetting.SelectedColor: TColor;
 111 begin
 112   Result := ColorIndex(lstElement.ItemIndex);
 113 end;
 114
 115 function TfrmColorSetting.ColorIndex(Index: integer): TColor;
 116 var Key: String;
 117 begin
 118   Key := Token(lstElement.Items[Index], '|', 1);
 119   if FCurrentTheme.Values[Key] <> '' then
 120     Result := StringToColor(FCurrentTheme.Values[Key])
 121   else
 122     Result := StringToColor(Token(lstElement.Items[Index], '|', 2));
 123 end;
 124
 125 function TfrmColorSetting.GetColor(Key: String): TColor;
 126 var i: integer;
 127 begin
 128   Result := clBlack;
 129   if FCurrentTheme.Values[Key] <> '' then
 130     Result := StringToColor(FCurrentTheme.Values[Key])
 131   else begin
 132     for i := 0 to lstElement.Items.Count-1 do
 133       if Token(lstElement.Items[i], '|', 1) = Key then begin
 134         Result := StringToColor(Token(lstElement.Items[i], '|', 2));
 135         Exit;
 136       end;
 137   end;
 138 end;
 139
 140 procedure TfrmColorSetting.SetColor(Key: String; const Value: TColor);
 141 begin
 142   FCurrentTheme.Values[Key] := ColorToString(Value);
 143 end;
 144
 145 procedure TfrmColorSetting.btnSaveClick(Sender: TObject);
 146 var Title: String;
 147     Path: String;
 148 begin
 149   Title := 'Untitled';
 150   if not InputQuery('\83^\83C\83g\83\8b', '\83e\81[\83}\82Ì\96¼\91O', Title) then Exit;
 151   Path := ExtractFilePath(Application.ExeName) + '\themes\';
 152   if FileExists(Path + Title + '.txt') then begin
 153     if MessageDlg('"' + Title + '"\82ð\8fã\8f\91\82«\82µ\82Ü\82·\82©?', mtConfirmation, mbOkCancel, 0) = mrCancel then Exit;
 154   end;
 155   // \90V\82µ\82\95Û\91¶\82·\82é\8fê\8d\87\82Í\81A\90V\82µ\82¢\83e\81[\83}\82Ì\83C\83\93\83X\83^\83\93\83X\82ð\8dì\90¬\82·\82é
 156   FCurrentTheme.SaveToFile(Path + Title + '.txt');
 157   UpdateThemeList;
 158 end;
 159
 160 procedure TfrmColorSetting.UpdateThemeList;
 161 var i, tag: integer;
 162     F: TSearchRec;
 163     Item: TMenuItem;
 164     path: String;
 165 begin
 166   mnThemes.Items.Clear;
 167   FThemeList.Clear;
 168   tag := 0;
 169   path := ExtractFilePath(Application.ExeName);
 170   i := FindFirst(path + 'themes\*.txt', 0, F);
 171   if i = 0 then begin
 172     repeat
 173       Item := TMenuItem.Create(mnThemes);
 174       Item.Caption := ChangeFileExt(ExtractFileName(F.Name), '');
 175       Item.Tag := tag;
 176       FThemeList.Add(ChangeFileExt(ExtractFileName(F.Name), ''));
 177       Item.OnClick := mnThemeItemClick;
 178       mnThemes.Items.Add(Item);
 179       Inc(tag);
 180       i := FindNext(F);
 181     until i <> 0;
 182   end;
 183   FindClose(F);
 184 end;
 185
 186 procedure TfrmColorSetting.mnThemeItemClick(Sender: TObject);
 187 var Title, path: String;
 188 begin
 189   Title := FThemeList[(Sender as TMenuItem).Tag];
 190   path := ExtractFilePath(Application.ExeName);
 191   FCurrentTheme.LoadFromFile(path + 'themes\' + Title + '.txt');
 192   lstElement.Invalidate;
 193   lstElement.ItemIndex := -1;
 194   lstElementClick(self);
 195 end;
 196
 197 procedure TfrmColorSetting.btnThemeMouseDown(Sender: TObject;
 198   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
 199 var Pos: TPoint;
 200 begin
 201   if Button <> mbLeft then Exit;
 202   if mnThemes.Items.Count = 0 then Exit;
 203   Pos := btnTheme.ClientToScreen(Point(0, btnTheme.Height));
 204   mnThemes.Popup(Pos.X, Pos.Y);
 205 end;
 206
 207 procedure TfrmColorSetting.cbxColorChange(Sender: TObject);
 208 begin
 209   if lstElement.ItemIndex < 0 then Exit;
 210   lstElement.Invalidate;
 211   FCurrentTheme.Values[Token(lstElement.Items[lstElement.ItemIndex], '|', 1)] := ColorToString(cbxColor.Selected);
 212 end;
 213
 214 end.