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, lazutf8classes,
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 DocumentationLabel: TLabel;
80 DocumentationURLLabel: TLabel;
81 FPCVersionLabel: TLabel;
82 LogoImage: TImage;
83 miVerToClipboard: TMenuItem;
84 OfficialLabel: TLabel;
85 OfficialURLLabel: TLabel;
86 VersionPage: TTabSheet;
87 ButtonPanel: TPanel;
88 PlatformLabel: TLabel;
89 PopupMenu1: TPopupMenu;
90 VersionLabel: TLABEL;
91 RevisionLabel: TLabel;
92 Notebook: TPageControl;
93 AboutPage: TTabSheet;
94 ContributorsPage: TTabSheet;
95 AcknowledgementsPage:TTabSheet;
96 procedure AboutFormCreate(Sender:TObject);
97 procedure FormClose(Sender: TObject; var {%H-}CloseAction: TCloseAction);
98 procedure miVerToClipboardClick(Sender: TObject);
99 procedure NotebookPageChanged(Sender: TObject);
100 procedure URLLabelMouseDown(Sender: TObject; {%H-}Button: TMouseButton;
101 {%H-}Shift: TShiftState; {%H-}X, {%H-}Y: Integer);
102 procedure URLLabelMouseEnter(Sender: TObject);
103 procedure URLLabelMouseLeave(Sender: TObject);
104 private
105 Acknowledgements: TScrollingText;
106 Contributors: TScrollingText;
107 procedure LoadContributors;
108 procedure LoadAcknowledgements;
109 public
110 end;
111
ShowAboutFormnull112 function ShowAboutForm: TModalResult;
113
114 var
115 LazarusRevisionStr: string;
116
GetLazarusVersionStringnull117 function GetLazarusVersionString: string;
GetLazarusRevisionnull118 function GetLazarusRevision: string;
119
120 implementation
121
122 {$R *.lfm}
123
ShowAboutFormnull124 function ShowAboutForm: TModalResult;
125 var
126 AboutForm: TAboutForm;
127 begin
128 AboutForm:=TAboutForm.Create(nil);
129 Result:=AboutForm.ShowModal;
130 AboutForm.Free;
131 end;
132
GetLazarusVersionStringnull133 function GetLazarusVersionString: string;
134 begin
135 Result:=LazarusVersionStr;
136 end;
137
GetLazarusRevisionnull138 function GetLazarusRevision: string;
139 begin
140 Result:=LazarusRevisionStr;
141 end;
142
143 { TAboutForm }
144
145 procedure TAboutForm.AboutFormCreate(Sender:TObject);
146 const
147 DoubleLineEnding = LineEnding + LineEnding;
148
149 {The compiler generated date string is always of the form y/m/d.
150 This function gives it a string respresentation according to the
151 shortdateformat}
GetLocalizedBuildDatenull152 function GetLocalizedBuildDate(): string;
153 var
154 BuildDate: string;
155 SlashPos1, SlashPos2: integer;
156 Date: TDateTime;
157 begin
158 BuildDate := {$I %date%};
159 SlashPos1 := Pos('/',BuildDate);
160 SlashPos2 := SlashPos1 +
161 Pos('/', Copy(BuildDate, SlashPos1+1, Length(BuildDate)-SlashPos1));
162 Date := EncodeDate(StrToWord(Copy(BuildDate,1,SlashPos1-1)),
163 StrToWord(Copy(BuildDate,SlashPos1+1,SlashPos2-SlashPos1-1)),
164 StrToWord(Copy(BuildDate,SlashPos2+1,Length(BuildDate)-SlashPos2)));
165 Result := FormatDateTime('yyyy-mm-dd', Date);
166 end;
167
168 begin
169 Notebook.PageIndex:=0;
170 LogoImage.Picture.LoadFromResourceName(HInstance, 'splash_logo', TPortableNetworkGraphic);
171 Caption:=lisAboutLazarus;
172 VersionLabel.Caption := lisVersion+' #: '+ GetLazarusVersionString;
173 RevisionLabel.Caption := lisSVNRevision+LazarusRevisionStr;
174 BuildDateLabel.Caption := lisDate+': '+GetLocalizedBuildDate;
175 FPCVersionLabel.Caption:= lisFPCVersion+{$I %FPCVERSION%};
176 PlatformLabel.Caption:=GetCompiledTargetCPU+'-'+GetCompiledTargetOS
177 +'-'+LCLPlatformDisplayNames[GetDefaultLCLWidgetType];
178
179 VersionPage.Caption:=lisVersion;
180 AboutPage.Caption:=lisMenuTemplateAbout;
181 ContributorsPage.Caption:=lisContributors;
182 ContributorsPage.DoubleBuffered := True;
183 AcknowledgementsPage.Caption:=lisAcknowledgements;
184 AcknowledgementsPage.DoubleBuffered := True;
185 miVerToClipboard.Caption := lisVerToClipboard;
186
187 VersionLabel.Font.Color:= clWhite;
188
189 Constraints.MinWidth:= 460;
190 Constraints.MinHeight:= 380;
191 Width:= 460;
192 Height:= 380;
193
194 AboutMemo.Lines.Text:=
195 Format(lisAboutLazarusMsg,[DoubleLineEnding,DoubleLineEnding,DoubleLineEnding]);
196
197 OfficialLabel.Caption := lisAboutOfficial;
198 OfficialURLLabel.Caption := 'http://www.lazarus-ide.org';
199 DocumentationLabel.Caption := lisAboutDocumentation;
200 DocumentationURLLabel.Caption := 'http://wiki.lazarus.freepascal.org';
201
202 LoadContributors;
203 LoadAcknowledgements;
204 CloseButton.Caption:=lisBtnClose;
205 end;
206
207 procedure TAboutForm.FormClose(Sender: TObject; var CloseAction: TCloseAction);
208 begin
209 Acknowledgements.Active := False;
210 Contributors.Active := False;
211 end;
212
213 procedure TAboutForm.miVerToClipboardClick(Sender: TObject);
214 begin
215 Clipboard.AsText := 'Lazarus ' + LazarusVersionStr + ' r' + LazarusRevisionStr +
216 ' FPC ' + {$I %FPCVERSION%} + ' ' + PlatformLabel.Caption;
217 end;
218
219 procedure TAboutForm.NotebookPageChanged(Sender: TObject);
220 begin
221 if Assigned(Contributors) then
222 Contributors.Active:=NoteBook.ActivePage = ContributorsPage;
223 if Assigned(Acknowledgements) then
224 Acknowledgements.Active:=NoteBook.ActivePage = AcknowledgementsPage;
225 end;
226
227 procedure TAboutForm.URLLabelMouseDown(Sender: TObject;
228 Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
229 begin
230 OpenURL(TLabel(Sender).Caption);
231 end;
232
233 procedure TAboutForm.URLLabelMouseLeave(Sender: TObject);
234 begin
235 TLabel(Sender).Font.Style := [];
236 TLabel(Sender).Font.Color := clBlue;
237 TLabel(Sender).Cursor := crDefault;
238 end;
239
240 procedure TAboutForm. URLLabelMouseEnter(Sender: TObject);
241 begin
242 TLabel(Sender).Font.Style := [fsUnderLine];
243 TLabel(Sender).Font.Color := clRed;
244 TLabel(Sender).Cursor := crHandPoint;
245 end;
246
247 procedure TAboutForm.LoadContributors;
248 var
249 ContributorsFileName: string;
250 begin
251 ContributorsPage.ControlStyle := ContributorsPage.ControlStyle - [csOpaque];
252 Contributors := TScrollingText.Create(ContributorsPage);
253 Contributors.Name:='Contributors';
254 Contributors.Parent := ContributorsPage;
255 Contributors.Align:=alClient;
256
257 ContributorsFileName:=
258 AppendPathDelim(EnvironmentOptions.GetParsedLazarusDirectory)
259 +'docs'+PathDelim+'Contributors.txt';
260 //debugln('TAboutForm.LoadContributors ',FileExistsUTF8(ContributorsFileName),' ',ContributorsFileName);
261
262 if FileExistsUTF8(ContributorsFileName) then
263 LoadStringsFromFileUTF8(Contributors.Lines,ContributorsFileName)
264 else
265 Contributors.Lines.Text:=lisAboutNoContributors;
266 end;
267
268 procedure TAboutForm.LoadAcknowledgements;
269 var
270 AcknowledgementsFileName: string;
271 begin
272 Acknowledgements := TScrollingText.Create(AcknowledgementsPage);
273 Acknowledgements.Name:='Acknowledgements';
274 Acknowledgements.Parent := AcknowledgementsPage;
275 Acknowledgements.Align:=alClient;
276
277 AcknowledgementsFileName:=
278 AppendPathDelim(EnvironmentOptions.GetParsedLazarusDirectory)
279 +'docs'+PathDelim+'acknowledgements.txt';
280
281 if FileExistsUTF8(AcknowledgementsFileName) then
282 LoadStringsFromFileUTF8(Acknowledgements.Lines,AcknowledgementsFileName)
283 else
284 Acknowledgements.Lines.Text:=lisAboutNoContributors;
285 end;
286
287 { TScrollingText }
288
289 procedure TScrollingText.SetActive(const AValue: boolean);
290 begin
291 FActive := AValue;
292 if FActive then
293 Init;
294 FTimer.Enabled:=Active;
295 end;
296
297 procedure TScrollingText.Init;
298 begin
299 FBuffer.Width := Width;
300 FBuffer.Height := Height;
301 FLineHeight := FBuffer.Canvas.TextHeight('X');
302 FNumLines := FBuffer.Height div FLineHeight;
303
304 if FOffset = -1 then
305 FOffset := FBuffer.Height;
306
307 with FBuffer.Canvas do
308 begin
309 Brush.Color := clWhite;
310 Brush.Style := bsSolid;
311 FillRect(0, 0, Width, Height);
312 end;
313 end;
314
315 procedure TScrollingText.DrawScrollingText(Sender: TObject);
316 begin
317 if Active then
318 Canvas.Draw(0,0,FBuffer);
319 end;
320
321 procedure TScrollingText.DoTimer(Sender: TObject);
322 var
323 w: integer;
324 s: string;
325 i: integer;
326 begin
327 if not Active then
328 Exit;
329
330 Dec(FOffset, FStepSize);
331
332 if FOffSet < 0 then
333 FStartLine := -FOffset div FLineHeight
334 else
335 FStartLine := 0;
336
337 FEndLine := FStartLine + FNumLines + 1;
338 if FEndLine > FLines.Count - 1 then
339 FEndLine := FLines.Count - 1;
340
341 FBuffer.Canvas.FillRect(Rect(0, 0, FBuffer.Width, FBuffer.Height));
342
343 for i := FEndLine downto FStartLine do
344 begin
345 s := Trim(FLines[i]);
346
347 //reset buffer font
348 FBuffer.Canvas.Font.Style := [];
349 FBuffer.Canvas.Font.Color := clBlack;
350
351 //skip empty lines
352 if Length(s) > 0 then
353 begin
354 //check for bold format token
355 if s[1] = '#' then
356 begin
357 s := copy(s, 2, Length(s) - 1);
358 FBuffer.Canvas.Font.Style := [fsBold];
359 end
360 else
361 begin
362 //check for url
363 if Pos('http://', s) = 1 then
364 begin
365 if i = FActiveLine then
366 begin
367 FBuffer.Canvas.Font.Style := [fsUnderline];
368 FBuffer.Canvas.Font.Color := clRed;
369 end
370 else
371 FBuffer.Canvas.Font.Color := clBlue;
372 end;
373 end;
374
375 w := FBuffer.Canvas.TextWidth(s);
376 FBuffer.Canvas.TextOut((FBuffer.Width - w) div 2, FOffset + i * FLineHeight, s);
377 end;
378 end;
379
380 //start showing the list from the start
381 if FStartLine > FLines.Count - 1 then
382 FOffset := FBuffer.Height;
383 Invalidate;
384 end;
385
ActiveLineIsURLnull386 function TScrollingText.ActiveLineIsURL: boolean;
387 begin
388 if (FActiveLine > 0) and (FActiveLine < FLines.Count) then
389 Result := Pos('http://', FLines[FActiveLine]) = 1
390 else
391 Result := False;
392 end;
393
394 procedure TScrollingText.DoOnChangeBounds;
395 begin
396 inherited DoOnChangeBounds;
397
398 Init;
399 end;
400
401 procedure TScrollingText.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
402 Y: Integer);
403 begin
404 inherited MouseDown(Button, Shift, X, Y);
405
406 if ActiveLineIsURL then
407 OpenURL(FLines[FActiveLine]);
408 end;
409
410 procedure TScrollingText.MouseMove(Shift: TShiftState; X, Y: Integer);
411 begin
412 inherited MouseMove(Shift, X, Y);
413
414 //calculate what line is clicked from the mouse position
415 FActiveLine := (Y - FOffset) div FLineHeight;
416
417 Cursor := crDefault;
418
419 if (FActiveLine >= 0) and (FActiveLine < FLines.Count) and ActiveLineIsURL then
420 Cursor := crHandPoint;
421 end;
422
423 constructor TScrollingText.Create(AOwner: TComponent);
424 begin
425 inherited Create(AOwner);
426
427 ControlStyle := ControlStyle + [csOpaque];
428
429 OnPaint := @DrawScrollingText;
430 FLines := TStringList.Create;
431 FTimer := TTimer.Create(nil);
432 FTimer.OnTimer:=@DoTimer;
433 FTimer.Interval:=30;
434 FBuffer := TBitmap.Create;
435
436 FStepSize := 1;
437 FStartLine := 0;
438 FOffset := -1;
439 end;
440
441 destructor TScrollingText.Destroy;
442 begin
443 FLines.Free;
444 FTimer.Free;
445 FBuffer.Free;
446 inherited Destroy;
447 end;
448
449 initialization
450 lcl_revision_func := @GetLazarusRevision;
451
452 end.
453
454