unit usplashabout; {$mode objfpc}{$H+} interface { Credits ======= uversion.pas by Mike Thompson - mike.cornflake@gmail.com originally as VersionSupport.pas See uversion.pas header for more details All other code by Gordon Bamber - minesadorada@charcodelvalle.com ======================================================== SplashAbout component by minesadorada@charcodelvalle.com ======================================================== Licence: LGPL licence. Free to use and/or abuse in your code. Purpose ======= Constructs a Splash screen and/or About form with as little effort and resources as possible :) The windows and controls are created and destroyed on-the-fly to reduce application size Choice to only use externally-deployed graphics to reduce executable size For use in any Lazarus 1.x/FPC 2.x application Files needed to install component ================================================= uspalshabout.lpk usplashabout.pas,uversion.pas, license.lrs,masks.lrs,splashabout_ico.lrs (resource files) Optional Files in the same folder as your application (ONLY if Graphics=saExternalFiles) ======================================================================================== Optional: .(bmp/jpg/gif) Optional: .ico Optional: .bmp Optional: .jpg How to use in your project (see example project) ================================================ Use the Property Editor to set propertes and call ShowSplash and/or ShowAbout in your form code == Property tips == // If SplashAbout1.DelaySeconds set to zero, then SplashScreen will close only when your application becomes idle // TitleStyle allows you to use default Application or Form icons and titles or set your own (via Icon and UserTitle properties) // // == External files or built-in resources? (Graphics=saResources or Graphics=saExternalFiles) == // Using saResources will increase the size of your executable whereas saExternalFiles will not // HOWEVER any external files specified MUST be deployed in the same folder as your executable. // If Graphics=saResources, then (optionally) set the properties: // BitmapBackGround, BitmapMaskColor, BitmapMaskMono and Icon // If Graphics=saExternalFiles then (optionally) set the properties // ExternalFileBackGroundImage,ExternalFileIcon,ExternalFileMaskColorImage and ExternalFileMonoImage // * Note that ExternalFileOptions flags can control which are displayed // The optional properties MaskMonoImage and MaskColour Image // can make a shaped splash form (See the example app for ideas) // For MaskMonoImage, optimum source: .BMP image, 2-bit color depth or more, black area=invisible, white area=visible. Size >= 320 x 240 // If a jpg file is specified by mistake, it will be converted to a (large filesize 24bbp!) .bmp and saved to disk on first run. // For MaskColorImage, use a standard colour JPG file with a white background // This allows a shaped jpg image to be shown as a splash screen - very dramatic! // // SplashAbout1.LicenseFile ; // Default is for Licence button to be absent on ShowAbout method // SplashAbout1.CreditText:='Freeware by minesadorada'; // OPTIONAL: Default is no text // SplashAbout1.Author:='Mines A. Dorada'; // OPTIONAL. Default is boilerplate text in LicenseFile Path // SplashAbout1.SupportContact:='minesadorada@charcodelvalle.com'; // OPTIONAL. Default is boilerplate text in LicenseFile Path // SplashAbout1.Description:='My description'; // Will replace build info text if ShowDescription=True ===================================== EXAMPLE USE in the form create method ===================================== procedure TForm1.FormCreate(Sender: TObject); begin SplashAbout1.ShowSplash; end; ============================= EXAMPLE USE in About.. button ============================= procedure TForm1.Button1Click(Sender: TObject); begin SplashAbout1.ShowAbout; end; } uses Buttons, Classes, Controls, Forms, Graphics, SysUtils, LCLIntf, LCLType, LResources, Dialogs, ExtCtrls, PropEdits, ScrollTextClass, StdCtrls, StrUtils, uversion,uPoweredBy; type tFormType = (fSplash, fAbout); // Same dialog used for both // The license text is stored in the component as a resource. // If saUserFile then a file 'license.txt' must be present in the same folder as the executeable tLicenseFile = (saNone, saGPL, saLGPL, saMIT, saModifiedGPL, saUserFile); // To use your own icon and title then use saUserTitle TTitleStyleType = (saUserTitle, saForm, saApplication); // List of built-in shaped screens. Use saUserImage for your own shaped screen. tmasktype = (saNomask, saRoundedRect, saBigCog, saBigFlower, saBigSplash, saUserImage); // Default is to use internal graphics resources (BitMap.. properties) tGraphicType = (saExternalFiles, saResources); // Default is saResizeGraphic tResizeMode = (saNoResize, saResizeGraphic, saResizeWindow); // Used to make up an options list (when Graphics=saExternalFiles) tExternalFileOptionsType = (saExternalBackground, saExternalIcon, saExternalMaskColorImage, saExternalMaskMonoImage); tExternalFileOptions = set of tExternalFileOptionsType; // Used in property editor (TypeInfo cast) tSplashAboutString = string; const C_DEFAULTSPLASHWIDTH = 320; C_DEFAULTSPLASHHEIGHT = 240; C_LINUXEXTRASPLASHHEIGHT = 40; C_DEFAULTSPLASHHEIGHT_LINUX = C_DEFAULTSPLASHHEIGHT + C_LINUXEXTRASPLASHHEIGHT; C_DEFAULTLICENSEFORMWIDTH = 500; C_DEFAULTLICENSEFORMWIDTH_LINUX = C_DEFAULTLICENSEFORMWIDTH + 100; C_DEFAULTLICENSEFORMHEIGHT = 400; C_DEFAULTLICENSEFORMHEIGHT_LINUX = C_DEFAULTLICENSEFORMHEIGHT + 50; C_SPLASHABOUT_ERROR = 'SplashAbout Component Error'; C_SPLASHABOUT_VERSION = '1.4.3.0'; type TSplashAbout = class(TComponent) private fSplashForm: TForm; fFormType: tFormType; fIcon: TIcon; fDelaySeconds: integer; fTitleString: string; fBackGroundColor: TColor; fExternalFileIcon, fExternalFileBackGroundImage, fExternalFileMaskMonoImage, fExternalFileMaskColorImage: string; fBackGroundBitmap, fMaskMonoBitmap, fMaskColorBitmap: TBitMap; fVersionInfoString: string; fAppVersionString: string; fLicenseFile: tLicenseFile; fLicenseTypeString: string; fOrganisationString: string; fAuthorString: string; fSupportContactString: string; fCloseOnIdle: boolean; szLicenseFile: string; fTitleStyle: TTitleStyleType; fShowDescription: boolean; fDescriptionStringList: TStrings; fFormTitleString: string; fFormIcon: TIcon; fMaskType: tMaskType; fAboutString: tSplashAboutString; fGraphicType: tGraphicType; fExternalFileOptions: tExternalFileOptions; fFont: TFont; fPoweredBy:TPoweredBy; // Credits screen vars fCreditLines: TStrings; fShowCreditButton: boolean; fCreditsTextfileName: string; fFormSplashWidth, fFormSplashHeight: integer; fFormAboutWidth, fFormAboutHeight: integer; fFormSplashTextAlign: TAlignment; fFormAboutTextAlign: TAlignment; fVersionString: string; fResizeMode: tResizeMode; fShowPoweredBy: boolean; // Used by various buttons to close Splash or About foerm procedure CloseForm(Sender: TObject); // Main method to construct a splash or about dialog procedure ShowForm; // Called From ShowForm procedure ShowLicense(Sender: TObject); // Called when credits button is clicked procedure ShowCredits(Sender: TObject); // Only called is a developer specifies a jpg 2-colour image by mistake function MakeBMPfromJPG(var JPGFilePath: string): boolean; // Used when DelaySeconds=0 procedure ApplicationOnIdle(Sender: TObject; var {%H-}Done: boolean); // Property Set procedure procedure SetBackGroundBitmap(const AValue: TBitmap); // Property Set procedure procedure SetMaskMonoBitmap(const AValue: TBitmap); platform; // Property Set procedure procedure SetMaskColorBitmap(const AValue: TBitmap); platform; // Property Set procedure procedure SetStrings(const AValue: TStrings); // Property Set procedure procedure SetCreditLines(const AValue: TStrings); // Property Set procedure procedure SetFont(const AValue: TFont); protected public // Called when component is dropped onto a form constructor Create(AOwner: TComponent); override; // Called when component is deleted from a form destructor Destroy; override; // Usually called in Form.Create procedure ShowSplash; // Usually called from Help/About menu click procedure ShowAbout; published // Duration of the Splash screen property DelaySeconds: integer read fDelaySeconds write fDelaySeconds default 2; // Colour of the Splash and About dialogs if no background image specified property BackGroundColor: TColor read fBackGroundColor write fBackGroundColor default clSkyBlue; // If Titlestyle is set to saUserTitle this .ico file can be displayed property ExternalFileIcon: string read fExternalFileIcon write fExternalFileIcon; // If Graphics is set to saExternalFiles this .jpg will be used property ExternalFileBackGroundImage: string read fExternalFileBackGroundImage write fExternalFileBackGroundImage; // If Graphics is set to saExternalFiles this .bmp will be used property ExternalFileMaskMonoImage: string read fExternalFileMaskMonoImage write fExternalFileMaskMonoImage; platform; // If Graphics is set to saExternalFiles this .jpg will be used property ExternalFileMaskColorImage: string read fExternalFileMaskColorImage write fExternalFileMaskColorImage; platform; // These options allow you to experiment with external file settings property ExternalFileOptions: tExternalFileOptions read fExternalFileOptions write fExternalFileOptions default [saExternalBackground, saExternalIcon, saExternalMaskColorImage, saExternalMaskMonoImage]; // Sets the font for all text on the Splash and About dialogs property Font: TFont read fFont write SetFont; // If Graphics is set to saResources this bitmap will be used property BitmapBackGround: TBitMap read fBackGroundBitmap write SetBackGroundBitmap; // If Graphics is set to saResources this bitmap will be used property BitmapMaskMono: TBitmap read fMaskMonoBitmap write SetMaskMonoBitmap; platform; // If Graphics is set to saResources this bitmap will be used property BitmapMaskColor: TBitMap read fMaskColorBitmap write SetMaskColorBitmap; platform; // User icon used if Graphics=saResources and TitleStyle=saUserTitle property Icon: TIcon read fIcon write fIcon; // Default:saNoMask Set saUserImage to use a shaped splash screen and saNoMask for a standard screen property MaskType: tMaskType read fMaskType write fMaskType default saNomask; // If not saNone then a [License] button will be available on the About Dialog property LicenseFile: tLicenseFile read fLicenseFile write fLicenseFile default saNone; // Determines whether to use built-in bitmaps or external files property Graphics: tGraphicType read fGraphicType write fGraphicType default saResources; // Your Organisation is displayed in the About Dialog and the License screen property Organisation: string read fOrganisationString write fOrganisationString; // Displayed in the license screen property SupportContact: string read fSupportContactString write fSupportContactString; // Displayed in the license screen property Author: string read fAuthorString write fAuthorString; // saApplication uses the Application properties, saForm uses the Form properties property TitleStyle: TTitleStyleType read fTitleStyle write fTitleStyle default saApplication; // If saTitleStyle=saUserTitle then this value is displayed property UserTitle: string read fTitleString write fTitleString; // If TRUE then the Description property text is displayed in the About dialog property ShowDescription: boolean read fShowDescription write fShowDescription; // If ShowDescription=TRUE then this text is displayed in the About dialog property Description: TStrings read fDescriptionStringList write SetStrings; // Double-click or click the ellipsis button property About: tSplashAboutString read fAboutString; // If shaped form then this property is ignored property FormSplashWidth: integer read fFormSplashWidth write fFormSplashWidth default C_DEFAULTSPLASHWIDTH; // If shaped form then this property is ignored property FormSplashHeight: integer read fFormSplashHeight write fFormSplashHeight default C_DEFAULTSPLASHHEIGHT; // Use default value for the best layout property FormAboutWidth: integer read fFormAboutWidth write fFormAboutWidth default C_DEFAULTSPLASHWIDTH; // Use default value for the best layout property FormAboutHeight: integer read fFormAboutHeight write fFormAboutHeight default C_DEFAULTSPLASHHEIGHT; // Default is taCenter property FormSplashTextAlign: TAlignment read fFormSplashTextAlign write fFormSplashTextAlign default taCenter; // Default is taCenter property FormAboutTextAlign: TAlignment read fFormAboutTextAlign write fFormAboutTextAlign default taCenter; // Version number of SplashAbout source code property Version: string read fVersionString; {$IFNDEF LINUX} // If TRUE then ShowSplash is preceded by a 'Powered by Lazarus' splash property ShowPoweredBy: boolean read fShowPoweredBy write fShowPoweredBy default False; platform; {$ENDIF} // String list for scrolling credits property CreditLines: TStrings read fCreditLines write SetCreditLines; // Show the Credits button? property ShowCreditButton: boolean read fShowCreditButton write fShowCreditButton; // If this text file is present in the executable folder the contents will be used // to populate the scrolling Credits window property CreditsTextfileName: string read fCreditsTextfileName write fCreditsTextfileName; // Affects how the background bitmap behaves property ResizeMode: TResizeMode read fResizeMode write fResizeMode default saResizeGraphic; property PoweredBy:TPoweredBy read fPoweredBy write fPoweredBy; end; TAboutPropertyEditor = class(TClassPropertyEditor) // Custom property editor for 'About' property public procedure Edit; override; function GetAttributes: TPropertyAttributes; override; function GetValue: string; override; end; procedure Register; implementation procedure Register; // Called when installing component into the Lazarus IDE begin {$I splashabout_ico.lrs} // Only use for the unique type 'tSplashAboutString' RegisterPropertyEditor(TypeInfo(tSplashAboutString), TSplashAbout, 'About', TAboutPropertyEditor); // Register subcomponent class property editor RegisterPropertyEditor(TypeInfo(TPoweredBy), TSplashAbout, 'PoweredBy', TClassPropertyEditor); RegisterComponents('Additional', [TSplashAbout]); end; // == START PROPERTY EDITOR CODE FOR About PROPERTY == procedure TAboutPropertyEditor.Edit; // Shows a dialog when About property is double-clicked var tAboutForm: TForm; OKbutton: TBitBtn; lbl_Description: TLabel; sz: string; begin sz := 'SplashAbout component for Lazarus' + LineEnding + 'by minesadorada@charcodelvalle.com' + LineEnding + LineEnding; sz += 'Methods:' + LineEnding; sz += 'SplashAbout1.ShowSplash' + LineEnding; sz += 'SplashAbout1.ShowAbout' + LineEnding; sz += LineEnding + 'Version: ' + C_SPLASHABOUT_VERSION + LineEnding; sz += 'License: LGPL'; tAboutForm := TForm.CreateNew(nil); try //.. finally FreeAndNil everything with tAboutForm do begin // Form position := poScreenCenter; borderstyle := bsToolWindow; Caption := 'About SplashAbout Component'; formstyle := fsSystemStayOnTop; color := clSkyBlue; Height := 240; Width := 320; okbutton := TBitBtn.Create(tAboutForm); okbutton.Kind := bkClose; okbutton.left := (Width div 2) - okbutton.Width div 2; okbutton.top := Height - okbutton.Height - 10; okbutton.parent := tAboutForm; lbl_Description := Tlabel.Create(tAboutForm); lbl_Description.left := 8; lbl_Description.Top := 30; lbl_Description.Width := 304; lbl_Description.Height := 200; lbl_Description.Autosize := False; lbl_Description.Alignment := taCenter; lbl_Description.Caption := sz; lbl_Description.parent := tAboutForm; ShowModal; end; finally FreeAndNil(lbl_Description); FreeAndNil(okbutton); FreeAndNil(tAboutForm); end; end; function TAboutPropertyEditor.GetAttributes: TPropertyAttributes; // Show the ellipsis begin Result := [paDialog, paReadOnly]; end; function TAboutPropertyEditor.GetValue: string; // Override standard string read method begin Result := '(About)'; end; // == END PROPERTY EDITOR CODE FOR About PROPERTY == destructor TSplashAbout.Destroy; begin Application.RemoveOnIdleHandler(@ApplicationOnIdle); FreeAndNil(fBackGroundBitmap); FreeAndNil(fMaskMonoBitmap); FreeAndNil(fMaskColorBitmap); FreeAndNil(fIcon); FreeAndNil(fDescriptionStringList); FreeAndNil(fFont); FreeAndNil(fCreditLines); inherited Destroy; end; constructor TSplashAbout.Create(AOwner: TComponent); // Initialise private vars var Frm: TForm; begin If (AOwner=Nil) then begin raise Exception.CreateFmt('%s : Sorry this component cannot be created in code',[C_SPLASHABOUT_ERROR]); Exit; end; inherited Create(AOwner); // From main form [Create(Self)] if (AOwner is TForm) then begin Frm := AOwner as TForm; fFormTitleString := Frm.Caption; fFormIcon := Frm.Icon; end; DelaySeconds := 2; BackGroundColor := clSkyBlue; fAppVersionString := LineEnding; // Use uversion unit public methods to populate (Credit: Mike Thompson) if (GetFileVersion <> 'No build information available') then fAppVersionString += 'Version ' + GetFileVersion + LineEnding + LineEnding; fVersionInfoString := fAppVersionString + 'Made with: ' + GetLCLVersion; fVersionInfoString += ' and ' + GetCompilerInfo + LineEnding; fVersionInfoString += 'For: ' + GetTargetInfo + ' (' + GetWidgetSet + ')' + LineEnding; fVersionInfoString += 'Last Compiled: ' + GetCompiledDate; // Optional property values fExternalFileBackGroundImage := ''; fExternalFileMaskMonoImage := ''; fTitleStyle := saApplication; fTitleString := 'My Application'; fCloseOnIdle := False; fExternalFileOptions := [saExternalBackground, saExternalIcon, saExternalMaskColorImage, saExternalMaskMonoImage]; fGraphicType := saResources; // Initialise property resources fBackGroundBitmap := TBitMap.Create; fMaskMonoBitmap := TBitMap.Create; fMaskColorBitmap := TBitMap.Create; fDescriptionStringList := TStringList.Create; fIcon := TIcon.Create; fFont := TFont.Create; fFont.Size := 10; fFormSplashWidth := C_DEFAULTSPLASHWIDTH; fFormSplashHeight := C_DEFAULTSPLASHHEIGHT; fFormAboutWidth := C_DEFAULTSPLASHWIDTH; fFormAboutHeight := C_DEFAULTSPLASHHEIGHT; {$IFDEF LINUX} fFormSplashHeight := C_DEFAULTSPLASHHEIGHT_LINUX; {$ENDIF} fFormSplashTextAlign := taCenter; fFormAboutTextAlign := taCenter; fVersionString := C_SPLASHABOUT_VERSION; fCreditLines := TStringList.Create; fCreditsTextfileName := 'credits.txt'; fResizeMode := saResizeGraphic; // Use tPoweredBy as a subcomponent // Register a TClassPropertyEditor in order to display it correctly fPoweredBy := TPoweredBy.Create(Self); fPoweredBy.SetSubComponent(true); // Tell the IDE to store the modified properties fPoweredBy.Name:='PoweredBy'; end; procedure TSplashAbout.ApplicationOnIdle(Sender: TObject; var Done: boolean); begin if fSplashForm = nil then exit; if fCloseOnIdle then if fSplashForm.Visible then begin fSplashForm.ModalResult := 11;//mrClose; Done := True; end; end; function TSplashAbout.MakeBMPfromJPG(var JPGFilePath: string): boolean; // The BitmapMaskMono has to be a BMP image file (ideally 2bbp). // If the developer sets the property to a JPG image file, then this routine // will convert it to BMP and save it to disk. The resulting BMP file is likely // to be a huge 24bbp file! // WARNING! The routine overwrites any existing BMP with the name name as the old JPG var JPG: TJpegImage; BMP: TBitmap; s: string; begin Result := False; if not FileExists(JPGFilePath) then exit; try JPG := TJpegImage.Create; BMP := TBitmap.Create; try JPG.LoadFromFile(JPGFilePath); BMP.Assign(jpg); s := ChangeFileExt(JPGFilePath, '.bmp'); if FileExists(s) then ShowMessageFmt('Over-writing old %s', [s]); BMP.SaveToFile(s); if FileExists(s) then begin JPGFilePath := s; Result := True; end; except On E: Exception do MessageDlg(C_SPLASHABOUT_ERROR, 'There is something wrong with the MaskImage JPG File' + LineEnding + 'Error detail: ' + e.message, mtError, [mbOK], 0); end; finally BMP.Free; JPG.Free; end; end; procedure TSplashAbout.ShowCredits(Sender: TObject); var CreditsForm: TForm; CloseButton: TBitBtn; ScrollWindow: TScrollTextClass; begin // Create a window, scroller and close button on-the-fly CreditsForm := TForm.Create(nil); CloseButton := TBitBtn.Create(CreditsForm); ScrollWindow := TScrollTextClass.Create(CreditsForm); try with CreditsForm do begin position := poScreenCenter; borderstyle := bsToolWindow; Caption := fTitleString + ': Credits'; formstyle := fsSystemStayOnTop; Color := clBlack; // For a black border // Use the same window size as the License window {$IFDEF WINDOWS} // More compact GUI? Width := C_DEFAULTLICENSEFORMWIDTH; Height := C_DEFAULTLICENSEFORMHEIGHT; {$ELSE WINDOWS} Width := C_DEFAULTLICENSEFORMWIDTH_LINUX; Height := C_DEFAULTLICENSEFORMHEIGHT_LINUX; {$ENDIF} // Close Button CloseButton.Kind := bkClose; CloseButton.left := (Width div 2) - CloseButton.Width div 2; CloseButton.top := Height - CloseButton.Height - 10; CloseButton.parent := CreditsForm; // Scroller panel ScrollWindow.Parent := CreditsForm; ScrollWindow.Align := alClient; ScrollWindow.BorderSpacing.Around := 2; ScrollWindow.BackColor := fBackGroundColor; ScrollWindow.Font.Assign(fFont); // Load from string list? if CreditLines.Count > 0 then ScrollWindow.Lines.Assign(CreditLines); // Load from CreditsTextFile if present // This would overwrite any text in CreditLines if FileExists(fCreditsTextfileName) then ScrollWindow.Lines.LoadFromFile(fCreditsTextfileName); // If both are empty then default text is shown. ScrollWindow.Active := True; // Show modally over the existing modal form PopupParent := TForm(Sender); ShowModal; end; finally CloseButton.Free; ScrollWindow.Free; CreditsForm.Free; end; end; procedure TSplashAbout.ShowLicense(Sender: TObject); // Triggered by License button Click var sLicenseString: string; theList: TStringList; f: integer; LicenceForm: TForm; lblText: TLabel; closebuttton: TBitBtn; r: TLResource; begin // Set to resource name in license.lrs case fLicenseFile of saNone: szLicenseFile := ''; saGPL: szLicenseFile := 'gpl.txt'; saLGPL: szLicenseFile := 'lgpl.txt'; saMIT: szLicenseFile := 'mit.txt'; saModifiedgpl: szLicenseFile := 'modifiedgpl.txt'; saUserFile: szLicenseFile := 'license.txt'; end; if fLicenseFile = saNone then Exit; // Use a string list to split the text file into lines theList := TStringList.Create; // Create a window, label and close button on-the-fly LicenceForm := TForm.Create(nil); lblText := TLabel.Create(LicenceForm); closebuttton := TBitBtn.Create(LicenceForm); // Load up the text into variable 'sLicenseString' sLicenseString := LineEnding + LineEnding + fTitleString + LineEnding; try try if (fLicenseFile = saUserFile) then begin theList.LoadFromFile(szLicenseFile); sLicenseString += LineEnding; if (theList.Count = 0) then raise Exception.CreateFmt('%s does not contain any text', [szLicenseFile]); for f := 0 to TheList.Count - 1 do sLicenseString += TheList[f] + LineEnding; end else begin // Load license text from resource string r := LazarusResources.Find(szLicenseFile); if r = nil then raise Exception.Create('Resource datafile license.lrs is missing'); thelist.Add(r.Value); for f := 0 to TheList.Count - 1 do sLicenseString += TheList[f] + LineEnding; end; except On e: Exception do MessageDlg(C_SPLASHABOUT_ERROR, 'There is something wrong with the Licence text', mtError, [mbOK], 0); end; // Replace boilerplate text if possible sLicenseString := AnsiReplaceText(sLicenseString, '', {$I %DATE%} ); sLicenseString := AnsiReplaceText(sLicenseString, '', fAuthorString); sLicenseString := AnsiReplaceText(sLicenseString, '', '(' + fSupportContactString + ')'); sLicenseString := AnsiReplaceText(sLicenseString, '', fAuthorString); // Make up the form window and controls with LicenceForm do begin // Form {$IFDEF WINDOWS} // More compact GUI? Width := C_DEFAULTLICENSEFORMWIDTH; Height := C_DEFAULTLICENSEFORMHEIGHT; {$ELSE WINDOWS} Width := C_DEFAULTLICENSEFORMWIDTH_LINUX; Height := C_DEFAULTLICENSEFORMHEIGHT_LINUX; {$ENDIF} // autosize:=true; // If you enable autosize, the button placement goes awry! // The Modified GPL has an extra clause if (szLicenseFile = 'modifiedgpl.txt') or (Pos('As a special exception', sLicenseString) > 0) then Height := Height + 100; position := poScreenCenter; borderstyle := bsToolWindow; Caption := fTitleString + ': Licensing'; formstyle := fsSystemStayOnTop; // Label lblText.Align := alClient; lblText.Alignment := taCenter; lblText.Caption := sLicenseString; lblText.Parent := LicenceForm; // Close Button closebuttton.Kind := bkClose; closebuttton.left := (Width div 2) - closebuttton.Width div 2; closebuttton.top := Height - closebuttton.Height - 10; closebuttton.parent := LicenceForm; // Show modally over the existing modal form PopupParent := TForm(Sender); ShowModal; end; finally // Free up all component created resources from memory FreeAndNil(theList); FreeAndNil(lblText); FreeAndNil(closebuttton); FreeAndNil(LicenceForm); end; end; procedure TSplashAbout.CloseForm(Sender: TObject); // Triggered by a Timer.OnTimer event or CloseButton.Click or OnClick begin fSplashForm.Close; // Hide and destroy end; procedure TSplashAbout.ShowSplash; // Set the mode, then create and show the form begin fFormType := fSplash; ShowForm; end; procedure TSplashAbout.ShowAbout; // Set the mode, then create and show the form begin fFormType := fAbout; ShowForm; end; procedure TSplashAbout.ShowForm; // Main method // Construct a form and show it modally // Controls vary according to fFormType variable const TEXT_MARGIN = 30; // Pixels from left and right var OKButton, LicenseButton, CreditsButton: TBitBtn; Delaytimer, scrolltimer: TTimer; lbl_Title, lbl_VersionInfo: TLabel; img_icon, img_background: TImage; bevel: TBevel; MyBitMap: TBitMap; FormRect: TRect; sVersionInfoString: string; iFormHeight, iFormWidth: integer; szMaskName: string; bUsingResourceMask, bMaskPSplash: boolean; iCount: integer; bLicenseButtonVisible, bCreditsButtonVisible: boolean; label NOTEXT; // Used in a GoTo begin // Show 'Powered by Lazarus?' if ((fShowPoweredBy = True) and ((fFormType = fSplash))) then fPoweredBy.ShowPoweredByForm; bMaskPSplash := False; // Toggle used in background image code bUsingResourceMask := False; // True if saRoundedRect etc are used //Establish License case fLicenseFile of saNone: begin szLicenseFile := ''; fLicenseTypeString := ''; end; saGPL: begin szLicenseFile := 'gpl.txt'; fLicenseTypeString := 'GPL License'; end; saLGPL: begin szLicenseFile := 'lgpl.txt'; fLicenseTypeString := 'Library GPL License'; end; saMIT: begin szLicenseFile := 'mit.txt'; fLicenseTypeString := 'MIT License'; end; saModifiedgpl: begin szLicenseFile := 'modifiedgpl.txt'; fLicenseTypeString := 'Modified GPL License'; end; saUserFile: begin szLicenseFile := 'license.txt'; fLicenseTypeString := 'Proprietry License'; end; end; // Set resource name if appropriate, else filename of user image case fMaskType of saNoMask: szMaskName := 'none'; saUserImage: szMaskName := fExternalFileMaskMonoImage; saRoundedRect: szMaskName := 'roundedrect'; saBigCog: szMaskName := 'bigcog'; saBigFlower: szMaskName := 'bigflower'; saBigSplash: szMaskName := 'bigsplash'; end; // Temporarily create the form and controls fSplashForm := TForm.CreateNew(nil); if (fTitleStyle = saApplication) then fTitleString := Application.Title; if (fTitleStyle = saForm) then fTitleString := fFormTitleString; fSplashForm.Font := fFont; // The created form is parent to all the controls bevel := TBevel.Create(fSplashForm); OKButton := TBitBtn.Create(fSplashForm); LicenseButton := TBitBtn.Create(fSplashForm); CreditsButton := TBitBtn.Create(fSplashForm); Delaytimer := TTimer.Create(fSplashForm); Scrolltimer := TTimer.Create(fSplashForm); lbl_Title := TLabel.Create(fSplashForm); lbl_VersionInfo := TLabel.Create(fSplashForm); img_icon := TImage.Create(fSplashForm); img_background := TImage.Create(fSplashForm); MyBitmap := TBitMap.Create; iFormHeight := fFormSplashHeight; iFormWidth := fFormSplashWidth; if fFormType = fAbout then begin iFormHeight := fFormAboutHeight; iFormWidth := fFormAboutWidth; end; lbl_Title.ParentFont := True; lbl_VersionInfo.ParentFont := True; // Now set positions and properties try //.. finally FreeAndNil everything with fSplashForm do begin // Form position := poScreenCenter; if fFormType = fAbout then borderstyle := bsToolWindow else borderstyle := bsnone; Caption := 'About ' + fTitleString; formstyle := fsSystemStayOnTop; color := fBackGroundColor; // Set constraints so that if ResizeMode=ResizeWindow // then the form can't disappear nor overwhelm the screen Constraints.MaxWidth := 1024; Constraints.MaxHeight := 768; Constraints.MinWidth := 320; Constraints.MinHeight := 240; Height := iFormHeight; Width := iFormWidth; // Shaped form? // Form is sized to mask image (MUST be BMP file) // Text is centred in a 320 x 240 invisible frame {$IFNDEF LINUX}// Problem with Canvas.Draw in linux! // Skip this mask code block if MaskType is saNoMask if (fFormType = fSplash) and (fMaskType <> saNoMask) then begin // Deal with user-supplied image first if (fMaskType = saUserImage) then if ((fGraphicType = saExternalFiles) and (saExternalMaskMonoImage in fExternalFileOptions)) then if (FileExists(fExternalFileMaskMonoImage)) then begin // Try to convert a jpg file if specified as such if ExtractFileExt(fExternalFileMaskMonoImage) = '.jpg' then if MakeBMPfromJPG(fExternalFileMaskMonoImage) = False then MessageDlg(C_SPLASHABOUT_ERROR, 'There is something wrong with the MaskImage or MaskPImage File', mtError, [mbOK], 0) else MessageDlg(C_SPLASHABOUT_ERROR, 'The MaskImage should be a .BMP file. Your jpg has been converted and saved as a bmp. Please amend the property.', mtInformation, [mbOK], 0); // Load the user image into the BitMap MyBitMap.LoadFromFile(fExternalFileMaskMonoImage); //MyBitmap.SetSize(iFormWidth,iFormHeight); end else // Looks like the specified user image isn't in the application folder begin MessageDlg(C_SPLASHABOUT_ERROR, 'Cannot find MaskImage ' + fExternalFileMaskMonoImage, mtError, [mbOK], 0); exit; end; // Deal with Bitmap resource if (fGraphicType = saResources) then if Assigned(fMaskMonoBitmap) then begin MyBitMap.Assign(fMaskMonoBitmap); // MyBitmap.SetSize(iFormWidth,iFormHeight); end; // Stock image specified, so load from masks.lrs if (fMaskType <> saUserImage) then begin MyBitmap.LoadFromLazarusResource(szMaskName); bUsingResourceMask := True; end; // Now to use the loaded BitMap try // ShowMessageFmt('MyBitMap.Height = %d,MyBitMap.Width=%d',[MyBitMap.Height,MyBitMap.Width]); if MyBitMap.Height >= iFormHeight then iFormHeight := MyBitMap.Height; if MyBitMap.Width >= iFormWidth then iFormWidth := MyBitMap.Width; MyBitMap.Transparent := True; MyBitMap.TransparentColor := clBlack; Height := iFormHeight; Width := iFormWidth; FormRect.Top := 0; FormRect.left := 0; FormRect.Right := Width; FormRect.Bottom := Height; // Use StretchDraw Canvas.StretchDraw(FormRect, MyBitmap); // Canvas.Draw(0, 0, MyBitMap); // raises Floating Point Error in 64-bit Nix (!??) SetShape(MyBitMap); bevel.Visible := False; except On e: Exception do MessageDlg(C_SPLASHABOUT_ERROR, 'There is something wrong with the MaskMonoImage or MaskColourImage File' + LineEnding + 'Error detail: ' + e.message, mtError, [mbOK], 0); end; end; {$ENDIF} // Delay Timer if fFormType = fSplash then begin if fDelaySeconds = 0 then fCloseOnIdle := True else fCloseOnIdle := False; if FCloseOnIdle then Application.AddOnIdleHandler(@ApplicationOnIdle) else begin // Fix negative values if fDelaySeconds < 1 then fDelaySeconds := 1; // Fix developer mistakenly specifying milliseconds if fDelaySeconds > 1000 then fDelaySeconds := fDelaySeconds div 1000; delaytimer.Interval := fDelaySeconds * 1000; delaytimer.OnTimer := @CloseForm; delaytimer.Enabled := True; end; end; // bevel // Controls are placed relative to the bevel window if fFormType = fAbout then begin bevel.Width := fFormAboutWidth; bevel.Height := fFormAboutHeight; end else begin bevel.Width := fFormSplashWidth; bevel.Height := fFormSplashHeight; end; if iFormHeight > bevel.Height then bevel.Top := (iFormHeight - bevel.Height) div 2 else bevel.Top := 0; if iFormWidth > bevel.Width then bevel.Left := (iFormWidth - bevel.Width) div 2 else bevel.Left := 0; bevel.BorderSpacing.Around := 4; bevel.BorderSpacing.InnerBorder := 4; bevel.Parent := fSplashForm; bevel.onClick := @CloseForm; // BackGround image - load from file or resource if ((fResizeMode = saResizeGraphic) or (bUsingResourceMask = True)) then img_background.Stretch := True else img_background.Stretch := False; img_background.Align := alClient; img_background.Parent := fSplashForm; img_background.SendToBack; if ((fGraphicType = saExternalFiles) and (FileExists(fExternalFileBackGroundImage))) or ((fGraphicType = saResources) and (Assigned(fBackGroundBitmap))) then begin try if ((fGraphicType = saExternalFiles) and (saExternalBackground in fExternalFileOptions)) then img_background.Picture.LoadFromFile(fExternalFileBackGroundImage); if (fGraphicType = saResources) then img_background.Picture.Assign(fBackGroundBitmap); if (fResizeMode = saResizeWindow) then begin if (fGraphicType = saResources) then begin // Expand the form to suit the image iFormHeight := fBackGroundBitmap.Height; iFormWidth := fBackGroundBitmap.Width; end else begin // Expand the form to suit the image iFormHeight := img_background.Height; iFormWidth := img_background.Width; end; Height := iFormHeight; Width := iFormWidth; bevel.Align := alClient; end; except On e: Exception do MessageDlg(C_SPLASHABOUT_ERROR, 'There is something wrong with the Background Image', mtError, [mbOK], 0); end; end; // In splash screen override BackGroundImage with MaskColorImage? if (fFormType = fSplash) and (fMaskType = saUserImage) then begin if (fGraphicType = saExternalFiles) then // Check images exist if (FileExists(fExternalFileMaskColorImage)) and (FileExists(fExternalFileMaskMonoImage)) and (saExternalMaskColorImage in fExternalFileOptions) and (saExternalMaskMonoImage in fExternalFileOptions) then begin try img_background.Picture.LoadFromFile(fExternalFileMaskColorImage); bMaskPSplash := True; // Triggers GoTo statement that skips text and icon elements except On e: Exception do MessageDlg(C_SPLASHABOUT_ERROR, 'There is something wrong with the External mask color Image', mtError, [mbOK], 0); end; end; if (fGraphicType = saResources) and Assigned(fMaskColorBitmap) then begin img_background.Picture.Assign(fMaskColorBitmap); bMaskPSplash := True; end; end; if bMaskPSplash then begin // Mask images should not resize the form img_background.Stretch := True; Height := iFormHeight; Width := iFormWidth; bevel.Align := alClient; end; // If a shaped mask with image is the splash screen then don't display any text or icon if bMaskPSplash then goto NOTEXT; // Title if fFormType = fSplash then begin lbl_Title.Top := bevel.Top + 64; lbl_Title.Left := bevel.Left + TEXT_MARGIN; lbl_Title.AutoSize := False; lbl_Title.Width := bevel.Width - (TEXT_MARGIN * 2); lbl_Title.Font := fFont; lbl_Title.Font.Style := [fsBold]; lbl_Title.Font.Size := 12; lbl_Title.Height := 32; lbl_Title.Alignment := fFormSplashTextAlign; if (fTitleString = '') then lbl_Title.Caption := Application.Title else lbl_Title.Caption := fTitleString; lbl_Title.Parent := fSplashForm; end; // Icon // Icon can come from: Icon property, External file, Form or Application img_icon.Width := 32; img_icon.Height := 32; img_icon.Top := bevel.Top + 20; img_icon.Left := bevel.left + ((bevel.Width - 32) - 20); img_icon.Stretch := True; img_icon.Parent := fSplashForm; // Fallback is to the Application icon, then Form icon, then nil. try // A new Application is always assigned a default icon if (fTitleStyle = saApplication) then if Assigned(Application.Icon) then img_icon.Picture.Icon := Application.Icon; // The Form may not have an icon if (fTitleStyle = saForm) then if (fFormIcon = nil) then img_icon.Picture.Icon := fFormIcon else if Assigned(Application.Icon) then img_icon.Picture.Icon := Application.Icon; // Fall back to application and form icons if necessary if (fTitleStyle = saUserTitle) then begin if ((fGraphicType = saExternalFiles) and (saExternalIcon in fExternalFileOptions)) then begin if FileExists(fExternalFileIcon) then begin fIcon.LoadFromFile(fExternalFileIcon); img_icon.Picture.Icon := fIcon; end else if (fFormIcon <> nil) then img_icon.Picture.Icon := fFormIcon else if Assigned(Application.Icon) then img_icon.Picture.Icon := Application.Icon; end; if (fGraphicType = saResources) then if Assigned(fIcon) then img_icon.Picture.Icon := fIcon else if (fFormIcon <> nil) then img_icon.Picture.Icon := fFormIcon else if Assigned(Application.Icon) then img_icon.Picture.Icon := Application.Icon; end; except On e: Exception do MessageDlg(C_SPLASHABOUT_ERROR, 'There is something wrong with the Icon', mtError, [mbOK], 0); end; // About dialog buttons // For code clarity, use these flags bCreditsButtonVisible := False; bLicenseButtonVisible := False; // Close Button (positioned in the centre) if fFormType = fAbout then begin OKButton.Kind := bkClose; OKButton.left := (Width div 2) - OKButton.Width div 2; OKButton.top := Height - OKButton.Height - 10; OKButton.parent := fSplashForm; // Do we need to show the Credits and/or License buttons? if (fShowCreditButton = True) then bCreditsButtonVisible := True; // License Button // Don't show if LicenseFile=saNone or LicenseFile=saUserText and 'license.txt' is missing if (fLicenseFile <> saUserFile) or ((fLicenseFile = saUserFile) and (FileExists(szLicenseFile))) then if (fLicenseFile <> saNone) then bLicenseButtonVisible := True; // License button if bLicenseButtonVisible then // Put it on the right begin LicenseButton.Top := OKButton.Top; LicenseButton.Caption := 'License...'; LicenseButton.left := Width - LicenseButton.Width - 10; LicenseButton.OnClick := @ShowLicense; LicenseButton.Parent := fSplashForm; end; // Credits button if bCreditsButtonVisible then // Put it on the right begin CreditsButton.Kind := bkCustom; CreditsButton.top := OKButton.top; CreditsButton.Left := Width - CreditsButton.Width - 10; ; CreditsButton.Caption := 'Credits..'; CreditsButton.OnClick := @ShowCredits; CreditsButton.parent := fSplashForm; end; // Reposition the various buttons? if (bLicenseButtonVisible and bCreditsButtonVisible) then begin CreditsButton.Left := LicenseButton.Left - CreditsButton.Width; OKButton.left := CreditsButton.Left - OKButton.Width; end; end; // Version Info or Description lbl_VersionInfo.Autosize := False; lbl_VersionInfo.WordWrap := True; lbl_VersionInfo.Left := bevel.left + TEXT_MARGIN; lbl_VersionInfo.Width := bevel.Width - TEXT_MARGIN * 2; lbl_VersionInfo.Height := bevel.Height - 50; if fFormType = fAbout then lbl_VersionInfo.Alignment := fFormAboutTextAlign else lbl_VersionInfo.Alignment := fFormSplashTextAlign; sVersionInfoString := ''; if fFormType = fAbout then sVersionInfoString += fTitleString; if fOrganisationString <> '' then sVersionInfoString += LineEnding + fOrganisationString; // Show description or VersionInfo? if (fShowDescription = True) then begin sVersionInfoString += LineEnding + fAppVersionString; if (fDescriptionStringList.Count > 0) then for iCount := 0 to fDescriptionStringList.Count - 1 do begin sVersionInfoString += fDescriptionStringList[iCount] + LineEnding; end else // User has not set the Description property sVersionInfoString += 'No Description'; end else sVersionInfoString += LineEnding + fVersionInfoString; if fLicenseTypeString <> '' then sVersionInfoString += LineEnding + LineEnding + 'Released under ' + fLicenseTypeString; lbl_VersionInfo.Caption := sVersionInfoString; if fFormType = fSplash then lbl_VersionInfo.Top := Bevel.Top + (bevel.Height div 2) - 50 else lbl_VersionInfo.Top := 40; lbl_VersionInfo.Parent := fSplashForm; lbl_VersionInfo.onClick := @CloseForm; NOTEXT: // Now show the completed form Application.ProcessMessages; ShowModal; end; finally // Controls normally destroyed with parent // but if Try block fails, ensure no memory leaks FreeAndNil(bevel); FreeAndNil(img_icon); FreeAndNil(img_background); FreeAndNil(lbl_Title); FreeAndNil(lbl_VersionInfo); FreeAndNil(OKButton); FreeAndNil(LicenseButton); FreeAndNil(CreditsButton); FreeAndNil(delaytimer); FreeAndNil(Scrolltimer); FreeAndNil(MyBitMap); FreeAndNil(fSplashForm); end; end; // Various Set property routines // Note that the object properties are Assigned to procedure TSplashAbout.SetBackGroundBitmap(const AValue: TBitmap); begin fBackGroundBitmap.Assign(AValue); end; procedure TSplashAbout.SetMaskMonoBitmap(const AValue: TBitmap); begin fMaskMonoBitmap.Assign(AValue); end; procedure TSplashAbout.SetMaskColorBitmap(const AValue: TBitmap); begin fMaskColorBitmap.Assign(AValue); end; procedure TSplashAbout.SetStrings(const AValue: TStrings); begin fDescriptionStringList.Assign(AValue); end; procedure TSplashAbout.SetFont(const AValue: TFont); begin fFont.Assign(AValue); end; procedure TSplashAbout.SetCreditLines(const AValue: TStrings); begin fCreditlines.Assign(AValue); end; initialization // Load license text and masks as lazarus resources {$I license.lrs} {$I masks.lrs} {$Hint Don't worry about the 'Warning: Symbol xxx is not portable' messages} {$Hint The 'not portable' code is stuff that won't work outside of Windows} {$Hint ..so I flagged it as such in the component code} end.