source: trunk/Packages/bgracontrols/bcstylesform.pas

Last change on this file was 2, checked in by chronos, 6 years ago
File size: 13.8 KB
Line 
1{ Styles form manager
2
3 ------------------------------------------------------------------------------
4 Copyright (C) 2012 Krzysztof Dibowski dibowski at interia.pl
5
6 This library is free software; you can redistribute it and/or modify it
7 under the terms of the GNU Library General Public License as published by
8 the Free Software Foundation; either version 2 of the License, or (at your
9 option) any later version with the following modification:
10
11 As a special exception, the copyright holders of this library give you
12 permission to link this library with independent modules to produce an
13 executable, regardless of the license terms of these independent modules,and
14 to copy and distribute the resulting executable under terms of your choice,
15 provided that you also meet, for each linked independent module, the terms
16 and conditions of the license of that module. An independent module is a
17 module which is not derived from or based on this library. If you modify
18 this library, you may extend this exception to your version of the library,
19 but you are not obligated to do so. If you do not wish to do so, delete this
20 exception statement from your version.
21
22 This program is distributed in the hope that it will be useful, but WITHOUT
23 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
24 FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
25 for more details.
26
27 You should have received a copy of the GNU Library General Public License
28 along with this library; if not, write to the Free Software Foundation,
29 Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
30}
31unit BCStylesForm;
32
33{$mode objfpc}{$H+}
34
35interface
36
37uses
38 Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
39 StdCtrls, ActnList, ComCtrls, Buttons, ComponentEditors, PropEdits,
40 bcbasectrls;
41
42type
43
44 { TBCfrmStyle }
45
46 TBCfrmStyle = class(TForm)
47 ActionRefresh: TAction;
48 ActionNewFromFile: TAction;
49 ActionDelete: TAction;
50 ActionNewFromCtrl: TAction;
51 ActionList1: TActionList;
52 BitBtn1: TBitBtn;
53 BitBtn2: TBitBtn;
54 gboxPreview: TGroupBox;
55 gboxStyles: TGroupBox;
56 lvFiles: TListView;
57 memoLogs: TMemo;
58 OpenDialog1: TOpenDialog;
59 pnlBottom: TPanel;
60 Splitter1: TSplitter;
61 sptrLog: TSplitter;
62 ToolBar1: TToolBar;
63 btnDelete: TToolButton;
64 btnNewFromCtrl: TToolButton;
65 ToolButton1: TToolButton;
66 btnNewFromFile: TToolButton;
67 btnRefresh: TToolButton;
68 procedure ActionDeleteExecute(Sender: TObject);
69 procedure ActionNewFromCtrlExecute(Sender: TObject);
70 procedure ActionNewFromFileExecute(Sender: TObject);
71 procedure ActionRefreshExecute(Sender: TObject);
72 procedure FormCloseQuery(Sender: TObject; var CanClose: boolean);
73 procedure lvFilesSelectItem(Sender: TObject; Item: TListItem;
74 Selected: Boolean);
75 private
76 { private declarations }
77 FControl: TControl;
78 FPreviewControl: TControl;
79 FStyleExt: String;
80 procedure AddLog(const AText: String; AClear: Boolean = True);
81 procedure CreatePreviewControl;
82 function GetFileName: String;
83 function GetStylesDir: String;
84 public
85 { public declarations }
86 constructor Create(AControl: TControl; const AFileExt: String);
87
88 property FileName: String read GetFileName;
89 end;
90
91 { TBCStyleComponentEditor }
92
93 TBCStyleComponentEditor = class(TComponentEditor)
94 protected
95 procedure BeginUpdate;
96 procedure EndUpdate;
97 function GetStyleExtension: String;
98 procedure DoShowEditor;
99 public
100 procedure ExecuteVerb(Index: Integer); override;
101 function GetVerb(Index: Integer): String; override;
102 function GetVerbCount: Integer; override;
103 end;
104
105 { TBCSylePropertyEditor }
106
107 TBCSylePropertyEditor = class(TClassPropertyEditor)
108 private
109 procedure BeginUpdate;
110 procedure EndUpdate;
111 function GetStyleExtension: String;
112 procedure DoShowEditor;
113 public
114 procedure Edit; Override;
115 function GetAttributes: TPropertyAttributes; Override;
116 end;
117
118implementation
119
120uses MacroIntf, BCRTTI, IDEImagesIntf;
121
122{ TBCSylePropertyEditor }
123
124procedure TBCSylePropertyEditor.BeginUpdate;
125begin
126 if GetComponent(0).InheritsFrom(TBCStyleGraphicControl) then
127 TBCStyleGraphicControl(GetComponent(0)).BeginUpdate
128 else
129 if GetComponent(0).InheritsFrom(TBCStyleCustomControl) then
130 TBCStyleCustomControl(GetComponent(0)).BeginUpdate;
131end;
132
133procedure TBCSylePropertyEditor.EndUpdate;
134begin
135 if GetComponent(0).InheritsFrom(TBCStyleGraphicControl) then
136 TBCStyleGraphicControl(GetComponent(0)).EndUpdate
137 else
138 if GetComponent(0).InheritsFrom(TBCStyleCustomControl) then
139 TBCStyleCustomControl(GetComponent(0)).EndUpdate;
140end;
141
142function TBCSylePropertyEditor.GetStyleExtension: String;
143begin
144 if GetComponent(0).InheritsFrom(TBCStyleGraphicControl) then
145 Result := TBCStyleGraphicControl(GetComponent(0)).StyleExtension
146 else
147 if GetComponent(0).InheritsFrom(TBCStyleCustomControl) then
148 Result := TBCStyleCustomControl(GetComponent(0)).StyleExtension
149 else
150 Result := '';
151end;
152
153procedure TBCSylePropertyEditor.DoShowEditor;
154var f: TBCfrmStyle;
155begin
156 if GetStyleExtension='' then
157 begin
158 MessageDlg('Empty ext', Format('Class %s has empty style extension',
159 [GetComponent(0).ClassName]),mtError,[mbOK],0);
160 Exit;
161 end;
162
163 f := TBCfrmStyle.Create(TControl(GetComponent(0)),GetStyleExtension);
164 try
165 if (f.ShowModal=mrOK) and FileExists(f.FileName) then
166 begin
167 try
168 BeginUpdate;
169 LoadStyle(GetComponent(0),f.FileName);
170 finally
171 EndUpdate;
172 end;
173 end;
174 finally
175 f.Free;
176 end;
177end;
178
179procedure TBCSylePropertyEditor.Edit;
180begin
181 DoShowEditor;
182end;
183
184function TBCSylePropertyEditor.GetAttributes: TPropertyAttributes;
185begin
186 Result := [paDialog, paReadOnly];
187end;
188
189{ TBCfrmStyle }
190
191procedure TBCfrmStyle.ActionNewFromCtrlExecute(Sender: TObject);
192var
193 sName: String;
194 sl: TStrings;
195begin
196 sName := 'My new style';
197 if InputQuery('Create new style', 'Style name', sName) then
198 begin
199 if Trim(sName)='' then
200 raise Exception.Create('Name can not be empty');
201 sName := IncludeTrailingBackslash(GetStylesDir) + sName+'.'+FStyleExt;
202 if FileExists(sName) then
203 raise Exception.Create('Style with this name already exists!');
204 sl := TStringList.Create;
205 try
206 SaveStyle(FControl,'Me','',sl);
207 sl.SaveToFile(sName);
208 ActionRefresh.Execute;
209 finally
210 sl.Free;
211 end;
212 end;
213end;
214
215procedure TBCfrmStyle.ActionNewFromFileExecute(Sender: TObject);
216begin
217 if OpenDialog1.Execute then
218 begin
219 if FileExists(IncludeTrailingBackslash(GetStylesDir)+ExtractFileName(OpenDialog1.FileName)) then
220 raise Exception.Create('This style already exists');
221 CopyFile(OpenDialog1.FileName,IncludeTrailingBackslash(GetStylesDir)+ExtractFileName(OpenDialog1.FileName));
222 ActionRefresh.Execute;
223 end;
224end;
225
226procedure TBCfrmStyle.ActionRefreshExecute(Sender: TObject);
227var
228 sl: TStrings;
229 i: Integer;
230 it: TListItem;
231 h: TBCStyleHeader;
232begin
233 sl := FindAllFiles(GetStylesDir,'*.'+FStyleExt,False);
234 try
235 lvFiles.ItemIndex := -1;
236 lvFiles.Selected := nil;
237 lvFiles.Clear;
238 if (sl<>nil) and (sl.Count>0) then
239 begin
240 lvFiles.BeginUpdate;
241 try
242 for i:=0 to Pred(sl.Count) do
243 begin
244 it := lvFiles.Items.Add;
245 it.Caption := ExtractFileName(sl.Strings[i]);
246 GetStyleHeader(sl.Strings[i],@h);
247 it.SubItems.Add(h.Author); // Author
248 it.SubItems.Add(h.Description); // Description
249 end;
250 lvFiles.ItemIndex := 0;
251 lvFiles.Selected := lvFiles.Items.Item[0];
252 // I noticed that OnSelect event is not called when we change
253 // selected index manually, so we must call it manually
254 lvFilesSelectItem(lvFiles,lvFiles.Selected,True);
255 ActionDelete.Enabled := True;
256 finally
257 lvFiles.EndUpdate;
258 end;
259 end else
260 begin
261 memoLogs.Clear;
262 memoLogs.Visible := False;
263 sptrLog.Visible := False;
264 FPreviewControl.Visible := False;
265 ActionDelete.Enabled := False;
266 end;
267 finally
268 if sl<>nil then sl.Free;
269 end;
270end;
271
272procedure TBCfrmStyle.FormCloseQuery(Sender: TObject; var CanClose: boolean);
273begin
274 if (ModalResult=mrOK) and (lvFiles.ItemIndex=-1) then
275 begin
276 MessageDlg('Assign file', 'No style selected', mtError, [mbOK], 0);
277 CanClose := False;
278 end
279 else
280 CanClose := True;
281end;
282
283procedure TBCfrmStyle.ActionDeleteExecute(Sender: TObject);
284begin
285 if (lvFiles.SelCount=0) or
286 (MessageDlg('Deleting style', 'Do you really want to delete selected style? '+
287 'This action delete file: '+IncludeTrailingBackslash(GetStylesDir)+lvFiles.Selected.Caption,
288 mtConfirmation,mbYesNo,0)=mrNo)
289 then
290 Exit;
291
292 DeleteFile(IncludeTrailingBackslash(GetStylesDir)+lvFiles.Selected.Caption);
293 ActionRefresh.Execute;
294end;
295
296procedure TBCfrmStyle.lvFilesSelectItem(Sender: TObject; Item: TListItem;
297 Selected: Boolean);
298var
299 sl_logs: TStrings;
300 i: Integer;
301begin
302 if Selected and (Item<>nil) then
303 begin
304 memoLogs.Visible := False;
305 sptrLog.Visible := False;
306 memoLogs.Clear;
307 FPreviewControl.Visible := True;
308 ActionDelete.Enabled := True;
309
310 sl_logs := TStringList.Create;
311 try
312 if not FileExists(IncludeTrailingBackslash(GetStylesDir)+Item.Caption) then
313 Exit;
314
315 LoadStyle(FPreviewControl,IncludeTrailingBackslash(GetStylesDir)+Item.Caption,
316 sl_logs);
317 // Because load style override it
318 FPreviewControl.Constraints.MinWidth := 100;
319 FPreviewControl.Constraints.MinHeight := 100;
320 // Logs
321 for i:=0 to Pred(sl_logs.Count) do
322 AddLog(sl_logs.Strings[i],False);
323 finally
324 sl_logs.Free;
325 end;
326 end;
327end;
328
329procedure TBCfrmStyle.AddLog(const AText: String; AClear: Boolean = True);
330begin
331 if AClear then memoLogs.Clear;
332 if not memoLogs.Visible then
333 begin
334 memoLogs.Visible := True;
335 sptrLog.Visible := True;
336 sptrLog.Top := memoLogs.Top - 1;
337 end;
338 memoLogs.Lines.Add(AText);
339end;
340
341function TBCfrmStyle.GetStylesDir: String;
342begin
343 Result := '$PkgDir(bgracontrols)';
344 IDEMacros.SubstituteMacros(Result);
345 Result := IncludeTrailingBackslash(Result)+'styles';
346end;
347
348procedure TBCfrmStyle.CreatePreviewControl;
349begin
350 FPreviewControl := TControlClass(FControl.ClassType).Create(Self);
351 FPreviewControl.Constraints.MinWidth := 100;
352 FPreviewControl.Constraints.MinHeight := 100;
353 FPreviewControl.Parent := gboxPreview;
354 FPreviewControl.Caption := FControl.Caption;
355 if Trim(FPreviewControl.Caption) = '' then
356 FPreviewControl.Caption := 'Demo';
357 FPreviewControl.Visible := False;
358end;
359
360function TBCfrmStyle.GetFileName: String;
361begin
362 if lvFiles.ItemIndex=-1 then
363 Result := ''
364 else
365 Result := IncludeTrailingBackslash(GetStylesDir)+lvFiles.Selected.Caption;
366end;
367
368constructor TBCfrmStyle.Create(AControl: TControl;
369 const AFileExt: String);
370
371 // It seems that method LoadImage load icon on each call. Others lazarus
372 // component editors doesn't check if icon exist but I will do. Small memory leak
373 // reduction :P
374 function _LoadImage(AIdx: Integer; const AName: String): Integer;
375 begin
376 Result := IDEImages.GetImageIndex(AIdx,AName);
377 if Result=-1 then
378 Result := IDEImages.LoadImage(AIdx,AName);
379 end;
380begin
381 inherited Create(Application);
382
383 FControl := AControl;
384 FStyleExt := AFileExt;
385
386 CreatePreviewControl;
387 ActionRefresh.Execute;
388
389 ToolBar1.Images := IDEImages.Images_16;
390 ActionList1.Images := ToolBar1.Images;
391 ActionDelete.ImageIndex := _LoadImage(16,'laz_delete');
392 ActionNewFromCtrl.ImageIndex := _LoadImage(16,'laz_add');
393 ActionNewFromFile.ImageIndex := _LoadImage(16,'laz_open');
394 ActionRefresh.ImageIndex := _LoadImage(16,'laz_refresh');
395
396 ActionDelete.Enabled := False;
397
398 OpenDialog1.Filter := 'BC Style|*.'+FStyleExt;
399 OpenDialog1.DefaultExt := FStyleExt;
400 OpenDialog1.InitialDir := GetStylesDir;
401end;
402
403{$R *.lfm}
404
405{ TBCStyleComponentEditor }
406
407procedure TBCStyleComponentEditor.BeginUpdate;
408begin
409 if Component.InheritsFrom(TBCStyleGraphicControl) then
410 TBCStyleGraphicControl(Component).BeginUpdate
411 else
412 if Component.InheritsFrom(TBCStyleCustomControl) then
413 TBCStyleCustomControl(Component).BeginUpdate;
414end;
415
416procedure TBCStyleComponentEditor.EndUpdate;
417begin
418 if Component.InheritsFrom(TBCStyleGraphicControl) then
419 TBCStyleGraphicControl(Component).EndUpdate
420 else
421 if Component.InheritsFrom(TBCStyleCustomControl) then
422 TBCStyleCustomControl(Component).EndUpdate;
423end;
424
425function TBCStyleComponentEditor.GetStyleExtension: String;
426begin
427 if Component.InheritsFrom(TBCStyleGraphicControl) then
428 Result := TBCStyleGraphicControl(Component).StyleExtension
429 else
430 if Component.InheritsFrom(TBCStyleCustomControl) then
431 Result := TBCStyleCustomControl(Component).StyleExtension
432 else
433 Result := '';
434end;
435
436procedure TBCStyleComponentEditor.DoShowEditor;
437var f: TBCfrmStyle;
438begin
439 if GetStyleExtension='' then
440 begin
441 MessageDlg('Empty ext', Format('Class %s has empty style extension',
442 [Component.ClassName]),mtError,[mbOK],0);
443 Exit;
444 end;
445
446 f := TBCfrmStyle.Create(TControl(Component),GetStyleExtension);
447 try
448 if (f.ShowModal=mrOK) and FileExists(f.FileName) then
449 begin
450 try
451 BeginUpdate;
452 LoadStyle(Component,f.FileName);
453 finally
454 EndUpdate;
455 end;
456 end;
457 finally
458 f.Free;
459 end;
460end;
461
462procedure TBCStyleComponentEditor.ExecuteVerb(Index: Integer);
463begin
464 case Index of
465 0: DoShowEditor;
466 end;
467end;
468
469function TBCStyleComponentEditor.GetVerb(Index: Integer): String;
470begin
471 Result := 'Assign style';
472end;
473
474function TBCStyleComponentEditor.GetVerbCount: Integer;
475begin
476 Result := 1;
477end;
478
479initialization
480 RegisterComponentEditor([TBCStyleGraphicControl, TBCStyleCustomControl], TBCStyleComponentEditor);
481 RegisterPropertyEditor(ClassTypeInfo(TBCStyleDummyProperty),nil,'',TBCSylePropertyEditor);
482
483end.
484
Note: See TracBrowser for help on using the repository browser.