1 {
2 ***************************************************************************
3 * *
4 * This source is free software; you can redistribute it and/or modify *
5 * it under the terms of the GNU General Public License as published by *
6 * the Free Software Foundation; either version 2 of the License, or *
7 * (at your option) any later version. *
8 * *
9 * This code is distributed in the hope that it will be useful, but *
10 * WITHOUT ANY WARRANTY; without even the implied warranty of *
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
12 * General Public License for more details. *
13 * *
14 * A copy of the GNU General Public License is available on the World *
15 * Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
16 * obtain it by writing to the Free Software Foundation, *
17 * Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
18 * *
19 ***************************************************************************
20 }
21 unit AboutFrm;
22
23 {$mode objfpc}{$H+}
24
25 interface
26
27 uses
28 Classes, SysUtils,
29 // LCL
30 Forms, Controls, Graphics, StdCtrls, Buttons, ExtCtrls, ComCtrls, Menus,
31 LCLIntf, LazConf, InterfaceBase, LCLPlatformDef, Clipbrd, LCLVersion,
32 // LazUtils
33 FPCAdds, LazFileUtils,
34 // Codetools
35 DefineTemplates,
36 // IDE
37 LazarusIDEStrConsts, EnvironmentOpts;
38
39 type
40
41 { TScrollingText }
42
43 TScrollingText = class(TGraphicControl)
44 private
45 FActive: boolean;
46 FActiveLine: integer; //the line over which the mouse hovers
47 FBuffer: TBitmap;
48 FEndLine: integer;
49 FLineHeight: integer;
50 FLines: TStrings;
51 FNumLines: integer;
52 FOffset: integer;
53 FStartLine: integer;
54 FStepSize: integer;
55 FTimer: TTimer;
ActiveLineIsURLnull56 function ActiveLineIsURL: boolean;
57 procedure DoTimer(Sender: TObject);
58 procedure SetActive(const AValue: boolean);
59 procedure Init;
60 procedure DrawScrollingText(Sender: TObject);
61 protected
62 procedure DoOnChangeBounds; override;
63 procedure MouseDown(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); override;
64 procedure MouseMove(Shift: TShiftState; X,Y: Integer); override;
65 public
66 constructor Create(AOwner: TComponent); override;
67 destructor Destroy; override;
68
69 property Active: boolean read FActive write SetActive;
70 property Lines: TStrings read FLines write FLines;
71 end;
72
73 { TAboutForm }
74
75 TAboutForm = class(TForm)
76 CloseButton: TBitBtn;
77 BuildDateLabel: TLABEL;
78 AboutMemo: TMEMO;
79 CopyToClipboardButton: TSpeedButton;
80 DocumentationLabel: TLabel;
81 DocumentationURLLabel: TLabel;
82 FPCVersionLabel: TLabel;
83 LogoImage: TImage;
84 miVerToClipboard: TMenuItem;
85 OfficialLabel: TLabel;
86 OfficialURLLabel: TLabel;
87 VersionPage: TTabSheet;
88 ButtonPanel: TPanel;
89 PlatformLabel: TLabel;
90 PopupMenu1: TPopupMenu;
91 VersionLabel: TLABEL;
92 RevisionLabel: TLabel;
93 Notebook: TPageControl;
94 AboutPage: TTabSheet;
95 ContributorsPage: TTabSheet;
96 AcknowledgementsPage:TTabSheet;
97 procedure AboutFormCreate(Sender:TObject);
98 procedure CopyToClipboardButtonClick(Sender: TObject);
99 procedure FormClose(Sender: TObject; var {%H-}CloseAction: TCloseAction);
100 procedure FormShow(Sender: TObject);
101 procedure miVerToClipboardClick(Sender: TObject);
102 procedure NotebookPageChanged(Sender: TObject);
103 procedure URLLabelMouseDown(Sender: TObject; {%H-}Button: TMouseButton;
104 {%H-}Shift: TShiftState; {%H-}X, {%H-}Y: Integer);
105 procedure URLLabelMouseEnter(Sender: TObject);
106 procedure URLLabelMouseLeave(Sender: TObject);
107 private
108 Acknowledgements: TScrollingText;
109 Contributors: TScrollingText;
110 procedure LoadContributors;
111 procedure LoadAcknowledgements;
112 procedure LoadLogo;
113 public
114 end;
115
ShowAboutFormnull116 function ShowAboutForm: TModalResult;
117
118 var
119 LazarusRevisionStr: string;
120
GetLazarusVersionStringnull121 function GetLazarusVersionString: string;
GetLazarusRevisionnull122 function GetLazarusRevision: string;
123
124 implementation
125
126 {$R *.lfm}
127
128 uses
129 GraphUtil, IDEImagesIntf;
130
ShowAboutFormnull131 function ShowAboutForm: TModalResult;
132 var
133 AboutForm: TAboutForm;
134 begin
135 AboutForm:=TAboutForm.Create(nil);
136 Result:=AboutForm.ShowModal;
137 AboutForm.Free;
138 end;
139
GetLazarusVersionStringnull140 function GetLazarusVersionString: string;
141 begin
142 Result:=LazarusVersionStr;
143 end;
144
GetLazarusRevisionnull145 function GetLazarusRevision: string;
146 begin
147 Result:=LazarusRevisionStr;
148 end;
149
150 { TAboutForm }
151
152 procedure TAboutForm.AboutFormCreate(Sender:TObject);
153 const
154 DoubleLineEnding = LineEnding + LineEnding;
155
156 {The compiler generated date string is always of the form y/m/d.
157 This function gives it a string respresentation according to the
158 shortdateformat}
GetLocalizedBuildDatenull159 function GetLocalizedBuildDate(): string;
160 var
161 BuildDate: string;
162 SlashPos1, SlashPos2: integer;
163 Date: TDateTime;
164 begin
165 BuildDate := {$I %date%};
166 SlashPos1 := Pos('/',BuildDate);
167 SlashPos2 := SlashPos1 +
168 Pos('/', Copy(BuildDate, SlashPos1+1, Length(BuildDate)-SlashPos1));
169 Date := EncodeDate(StrToWord(Copy(BuildDate,1,SlashPos1-1)),
170 StrToWord(Copy(BuildDate,SlashPos1+1,SlashPos2-SlashPos1-1)),
171 StrToWord(Copy(BuildDate,SlashPos2+1,Length(BuildDate)-SlashPos2)));
172 Result := FormatDateTime('yyyy-mm-dd', Date);
173 end;
174
175 begin
176 Notebook.PageIndex:=0;
177 Caption:=lisAboutLazarus;
178 VersionLabel.Caption := lisVersion+': '+ GetLazarusVersionString;
179 RevisionLabel.Caption := lisRevision+LazarusRevisionStr;
180 BuildDateLabel.Caption := lisDate+': '+GetLocalizedBuildDate;
181 FPCVersionLabel.Caption:= lisFPCVersion+{$I %FPCVERSION%};
182 PlatformLabel.Caption:=GetCompiledTargetCPU+'-'+GetCompiledTargetOS
183 +'-'+LCLPlatformDisplayNames[GetDefaultLCLWidgetType];
184
185 VersionPage.Caption:=lisVersion;
186 AboutPage.Caption:=lisMenuTemplateAbout;
187 ContributorsPage.Caption:=lisContributors;
188 ContributorsPage.DoubleBuffered := True;
189 AcknowledgementsPage.Caption:=lisAcknowledgements;
190 AcknowledgementsPage.DoubleBuffered := True;
191 miVerToClipboard.Caption := lisVerToClipboard;
192
193 VersionLabel.Font.Color:= clWhite;
194
195 AboutMemo.Lines.Text:=
196 Format(lisAboutLazarusMsg,[DoubleLineEnding,DoubleLineEnding,DoubleLineEnding]);
197
198 OfficialLabel.Caption := lisAboutOfficial;
199 OfficialURLLabel.Caption := 'http://www.lazarus-ide.org';
200 DocumentationLabel.Caption := lisAboutDocumentation;
201 DocumentationURLLabel.Caption := 'http://wiki.lazarus.freepascal.org';
202
203 LoadContributors;
204 LoadAcknowledgements;
205 CloseButton.Caption:=lisBtnClose;
206
207 CopyToClipboardButton.Caption := '';
208 CopyToClipboardButton.Images := IDEImages.Images_16;
209 CopyToClipboardButton.ImageIndex := IDEImages.LoadImage('laz_copy');
210 CopyToClipboardButton.Hint := lisVerToClipboard;
211 end;
212
213 procedure TAboutForm.CopyToClipboardButtonClick(Sender: TObject);
214 begin
215 miVerToClipboardClick(nil);
216 end;
217
218 procedure TAboutForm.FormClose(Sender: TObject; var CloseAction: TCloseAction);
219 begin
220 Acknowledgements.Active := False;
221 Contributors.Active := False;
222 end;
223
224 procedure TAboutForm.FormShow(Sender: TObject);
225 begin
226 LoadLogo;
227 end;
228
229 procedure TAboutForm.miVerToClipboardClick(Sender: TObject);
230 begin
231 Clipboard.AsText := 'Lazarus ' + LazarusVersionStr + ' r' + LazarusRevisionStr +
232 ' FPC ' + {$I %FPCVERSION%} + ' ' + PlatformLabel.Caption;
233 end;
234
235 procedure TAboutForm.NotebookPageChanged(Sender: TObject);
236 begin
237 if Assigned(Contributors) then
238 Contributors.Active:=NoteBook.ActivePage = ContributorsPage;
239 if Assigned(Acknowledgements) then
240 Acknowledgements.Active:=NoteBook.ActivePage = AcknowledgementsPage;
241 CopyToClipboardButton.Visible := Notebook.ActivePage = VersionPage;
242 end;
243
244 procedure TAboutForm.URLLabelMouseDown(Sender: TObject;
245 Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
246 begin
247 OpenURL(TLabel(Sender).Caption);
248 end;
249
250 procedure TAboutForm.URLLabelMouseLeave(Sender: TObject);
251 begin
252 TLabel(Sender).Font.Style := [];
253 TLabel(Sender).Font.Color := clBlue;
254 TLabel(Sender).Cursor := crDefault;
255 end;
256
257 procedure TAboutForm. URLLabelMouseEnter(Sender: TObject);
258 begin
259 TLabel(Sender).Font.Style := [fsUnderLine];
260 TLabel(Sender).Font.Color := clRed;
261 TLabel(Sender).Cursor := crHandPoint;
262 end;
263
264 procedure TAboutForm.LoadContributors;
265 var
266 ContributorsFileName: string;
267 begin
268 ContributorsPage.ControlStyle := ContributorsPage.ControlStyle - [csOpaque];
269 Contributors := TScrollingText.Create(ContributorsPage);
270 Contributors.Name:='Contributors';
271 Contributors.Parent := ContributorsPage;
272 Contributors.Align:=alClient;
273
274 ContributorsFileName:=
275 AppendPathDelim(EnvironmentOptions.GetParsedLazarusDirectory)
276 +'docs'+PathDelim+'Contributors.txt';
277 //debugln('TAboutForm.LoadContributors ',FileExistsUTF8(ContributorsFileName),' ',ContributorsFileName);
278
279 if FileExistsUTF8(ContributorsFileName) then
280 Contributors.Lines.LoadFromFile(ContributorsFileName)
281 else
282 Contributors.Lines.Text:=lisAboutNoContributors;
283 end;
284
285 procedure TAboutForm.LoadAcknowledgements;
286 var
287 AcknowledgementsFileName: string;
288 begin
289 Acknowledgements := TScrollingText.Create(AcknowledgementsPage);
290 Acknowledgements.Name:='Acknowledgements';
291 Acknowledgements.Parent := AcknowledgementsPage;
292 Acknowledgements.Align:=alClient;
293
294 AcknowledgementsFileName:=
295 AppendPathDelim(EnvironmentOptions.GetParsedLazarusDirectory)
296 +'docs'+PathDelim+'acknowledgements.txt';
297
298 if FileExistsUTF8(AcknowledgementsFileName) then
299 Acknowledgements.Lines.LoadFromFile(AcknowledgementsFileName)
300 else
301 Acknowledgements.Lines.Text:=lisAboutNoContributors;
302 end;
303
304 procedure TAboutForm.LoadLogo;
305 begin
306 LogoImage.Picture.LoadFromResourceName(HInstance, 'splash_logo', TPortableNetworkGraphic);
307 ScaleImg(LogoImage.Picture.Bitmap, LogoImage.Width, LogoImage.Height)
308 end;
309
310
311 { TScrollingText }
312
313 procedure TScrollingText.SetActive(const AValue: boolean);
314 begin
315 FActive := AValue;
316 if FActive then
317 Init;
318 FTimer.Enabled:=Active;
319 end;
320
321 procedure TScrollingText.Init;
322 begin
323 FBuffer.Width := Width;
324 FBuffer.Height := Height;
325 FLineHeight := FBuffer.Canvas.TextHeight('X');
326 FNumLines := FBuffer.Height div FLineHeight;
327
328 if FOffset = -1 then
329 FOffset := FBuffer.Height;
330
331 with FBuffer.Canvas do
332 begin
333 Brush.Color := clWhite;
334 Brush.Style := bsSolid;
335 FillRect(0, 0, Width, Height);
336 end;
337 end;
338
339 procedure TScrollingText.DrawScrollingText(Sender: TObject);
340 begin
341 if Active then
342 Canvas.Draw(0,0,FBuffer);
343 end;
344
345 procedure TScrollingText.DoTimer(Sender: TObject);
346 var
347 w: integer;
348 s: string;
349 i: integer;
350 begin
351 if not Active then
352 Exit;
353
354 Dec(FOffset, FStepSize);
355
356 if FOffSet < 0 then
357 FStartLine := -FOffset div FLineHeight
358 else
359 FStartLine := 0;
360
361 FEndLine := FStartLine + FNumLines + 1;
362 if FEndLine > FLines.Count - 1 then
363 FEndLine := FLines.Count - 1;
364
365 FBuffer.Canvas.FillRect(Rect(0, 0, FBuffer.Width, FBuffer.Height));
366
367 for i := FEndLine downto FStartLine do
368 begin
369 s := Trim(FLines[i]);
370
371 //reset buffer font
372 FBuffer.Canvas.Font.Style := [];
373 FBuffer.Canvas.Font.Color := clBlack;
374
375 //skip empty lines
376 if Length(s) > 0 then
377 begin
378 //check for bold format token
379 if s[1] = '#' then
380 begin
381 s := copy(s, 2, Length(s) - 1);
382 FBuffer.Canvas.Font.Style := [fsBold];
383 end
384 else
385 begin
386 //check for url
387 if Pos('http://', s) = 1 then
388 begin
389 if i = FActiveLine then
390 begin
391 FBuffer.Canvas.Font.Style := [fsUnderline];
392 FBuffer.Canvas.Font.Color := clRed;
393 end
394 else
395 FBuffer.Canvas.Font.Color := clBlue;
396 end;
397 end;
398
399 w := FBuffer.Canvas.TextWidth(s);
400 FBuffer.Canvas.TextOut((FBuffer.Width - w) div 2, FOffset + i * FLineHeight, s);
401 end;
402 end;
403
404 //start showing the list from the start
405 if FStartLine > FLines.Count - 1 then
406 FOffset := FBuffer.Height;
407 Invalidate;
408 end;
409
ActiveLineIsURLnull410 function TScrollingText.ActiveLineIsURL: boolean;
411 begin
412 if (FActiveLine > 0) and (FActiveLine < FLines.Count) then
413 Result := Pos('http://', FLines[FActiveLine]) = 1
414 else
415 Result := False;
416 end;
417
418 procedure TScrollingText.DoOnChangeBounds;
419 begin
420 inherited DoOnChangeBounds;
421
422 Init;
423 end;
424
425 procedure TScrollingText.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
426 Y: Integer);
427 begin
428 inherited MouseDown(Button, Shift, X, Y);
429
430 if ActiveLineIsURL then
431 OpenURL(FLines[FActiveLine]);
432 end;
433
434 procedure TScrollingText.MouseMove(Shift: TShiftState; X, Y: Integer);
435 begin
436 inherited MouseMove(Shift, X, Y);
437
438 //calculate what line is clicked from the mouse position
439 FActiveLine := (Y - FOffset) div FLineHeight;
440
441 Cursor := crDefault;
442
443 if (FActiveLine >= 0) and (FActiveLine < FLines.Count) and ActiveLineIsURL then
444 Cursor := crHandPoint;
445 end;
446
447 constructor TScrollingText.Create(AOwner: TComponent);
448 begin
449 inherited Create(AOwner);
450
451 ControlStyle := ControlStyle + [csOpaque];
452
453 OnPaint := @DrawScrollingText;
454 FLines := TStringList.Create;
455 FTimer := TTimer.Create(nil);
456 FTimer.OnTimer:=@DoTimer;
457 FTimer.Interval:=30;
458 FBuffer := TBitmap.Create;
459
460 FStepSize := 1;
461 FStartLine := 0;
462 FOffset := -1;
463 end;
464
465 destructor TScrollingText.Destroy;
466 begin
467 FLines.Free;
468 FTimer.Free;
469 FBuffer.Free;
470 inherited Destroy;
471 end;
472
473 initialization
474 lcl_revision_func := @GetLazarusRevision;
475
476 end.
477
478