1 {
2 /***************************************************************************
3 projecticon.pas - Lazarus IDE unit
4 ---------------------------------------
5 TProjectIcon is responsible for the inclusion of the
6 icon in windows executables as rc file and others as .lrs.
7
8
9 ***************************************************************************/
10
11 ***************************************************************************
12 * *
13 * This source is free software; you can redistribute it and/or modify *
14 * it under the terms of the GNU General Public License as published by *
15 * the Free Software Foundation; either version 2 of the License, or *
16 * (at your option) any later version. *
17 * *
18 * This code is distributed in the hope that it will be useful, but *
19 * WITHOUT ANY WARRANTY; without even the implied warranty of *
20 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
21 * General Public License for more details. *
22 * *
23 * A copy of the GNU General Public License is available on the World *
24 * Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
25 * obtain it by writing to the Free Software Foundation, *
26 * Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
27 * *
28 ***************************************************************************
29 }
30 unit ProjectIcon;
31
32 {$mode objfpc}{$H+}
33
34 interface
35
36 uses
37 // RTL + LCL
38 Classes, SysUtils, resource, groupiconresource,
39 // LCL
40 LCLProc, Graphics,
41 // LazUtils
42 FileUtil, LazFileUtils, LazFileCache, Laz2_XMLCfg,
43 // Codetools
44 FileProcs,
45 // IdeIntf
46 ProjectResourcesIntf;
47
48 type
49 TIconData = array of byte;
50
51 { TProjectIcon }
52
53 TProjectIcon = class(TAbstractProjectResource)
54 private
55 FData: TIconData;
56 fFileAge: LongInt;
57 fFileAgeValid: Boolean;
58 FIcoFileName: string;
GetIsEmprynull59 function GetIsEmpry: Boolean;
60 procedure SetIcoFileName(AValue: String);
61 procedure SetIconData(const AValue: TIconData);
62 procedure SetIsEmpty(const AValue: Boolean);
63 public
64 constructor Create; override;
65
GetStreamnull66 function GetStream: TStream;
67 procedure SetStream(AStream: TStream);
68 procedure LoadDefaultIcon;
69
UpdateResourcesnull70 function UpdateResources(AResources: TAbstractProjectResources;
71 const MainFilename: string): Boolean; override;
72 procedure WriteToProjectFile(AConfig: {TXMLConfig}TObject; const Path: String); override;
73 procedure ReadFromProjectFile(AConfig: {TXMLConfig}TObject; const Path: String); override;
74
SaveIconFilenull75 function SaveIconFile: Boolean;
76
77 property IconData: TIconData read FData write SetIconData;
78 property IsEmpty: Boolean read GetIsEmpry write SetIsEmpty;
79 property IcoFileName: String read FIcoFileName write SetIcoFileName;
80 end;
81
82 implementation
83
TProjectIcon.GetStreamnull84 function TProjectIcon.GetStream: TStream;
85 begin
86 if length(FData)>0 then
87 begin
88 Result := TMemoryStream.Create;
89 Result.WriteBuffer(FData[0], Length(FData));
90 Result.Position := 0;
91 end
92 else
93 Result := nil;
94 end;
95
96 procedure TProjectIcon.SetStream(AStream: TStream);
97 var
98 NewIconData: TIconData;
99 begin
100 NewIconData := nil;
101 if (AStream <> nil) then
102 begin
103 SetLength(NewIconData, AStream.Size);
104 AStream.ReadBuffer(NewIconData[0], AStream.Size);
105 end;
106 IconData := NewIconData;
107 end;
108
109 procedure TProjectIcon.LoadDefaultIcon;
110 var
111 ResStream: TMemoryStream;
112 Icon: TIcon;
113 begin
114 // Load default icon
115 Icon := TIcon.Create;
116 ResStream := TMemoryStream.Create;
117 try
118 Icon.LoadFromResourceName(HInstance, 'MAINICONPROJECT');
119 Icon.SaveToStream(ResStream);
120 ResStream.Position := 0;
121 SetStream(ResStream);
122 finally
123 ResStream.Free;
124 Icon.Free;
125 end;
126 end;
127
TProjectIcon.UpdateResourcesnull128 function TProjectIcon.UpdateResources(AResources: TAbstractProjectResources;
129 const MainFilename: string): Boolean;
130 var
131 AResource: TStream;
132 AName: TResourceDesc;
133 ARes: TGroupIconResource;
134 ItemStream: TStream;
135 begin
136 Result := True;
137 if FData = nil then
138 Exit;
139
140 IcoFileName := ExtractFilePath(MainFilename)+ExtractFileNameOnly(MainFileName)+'.ico';
141 if FilenameIsAbsolute(FIcoFileName) then
142 if not SaveIconFile then begin
143 debugln(['TProjectIcon.UpdateResources CreateIconFile "'+FIcoFileName+'" failed']);
144 exit(false);
145 end;
146
147 AName := TResourceDesc.Create('MAINICON');
148 ARes := TGroupIconResource.Create(nil, AName); //type is always RT_GROUP_ICON
149 aName.Free; //not needed anymore
150 AResource := GetStream;
151 if AResource<>nil then
152 try
153 ItemStream:=nil;
154 try
155 ItemStream:=ARes.ItemData;
156 except
157 on E: Exception do begin
158 DebugLn(['TProjectIcon.UpdateResources ignoring bug in fcl: ',E.Message]);
159 end;
160 end;
161 if ItemStream<>nil then
162 ItemStream.CopyFrom(AResource, AResource.Size);
163 finally
164 AResource.Free;
165 end
166 else
167 ARes.ItemData.Size:=0;
168
169 AResources.AddSystemResource(ARes);
170 end;
171
172 procedure TProjectIcon.WriteToProjectFile(AConfig: TObject; const Path: String);
173 begin
174 TXMLConfig(AConfig).SetDeleteValue(Path+'General/Icon/Value', BoolToStr(IsEmpty), BoolToStr(true));
175 end;
176
177 procedure TProjectIcon.ReadFromProjectFile(AConfig: TObject; const Path: String);
178 begin
179 with TXMLConfig(AConfig) do
180 begin
181 IcoFileName := ChangeFileExt(FileName, '.ico');
182 IsEmpty := StrToBoolDef(GetValue(Path+'General/Icon/Value', BoolToStr(true)), False);
183 end;
184 end;
185
SaveIconFilenull186 function TProjectIcon.SaveIconFile: Boolean;
187 var
188 fs: TFileStream;
189 begin
190 Result := False;
191 if IsEmpty then exit;
192 if fFileAgeValid and (FileAgeCached(IcoFileName)=fFileAge) then
193 exit(true);
194 // write ico file
195 try
196 fs:=TFileStream.Create(IcoFileName,fmCreate);
197 try
198 fs.Write(FData[0],length(FData));
199 InvalidateFileStateCache(IcoFileName);
200 fFileAge:=FileAgeCached(IcoFileName);
201 fFileAgeValid:=true;
202 Result:=true;
203 finally
204 fs.Free;
205 end;
206 except
207 on E: Exception do
208 debugln(['TProjectIcon.CreateIconFile "'+FIcoFileName+'": '+E.Message]);
209 end;
210 end;
211
212 procedure TProjectIcon.SetIsEmpty(const AValue: Boolean);
213 var
214 NewData: TIconData;
215 fs: TFileStream;
216 begin
217 if IsEmpty=AValue then exit;
218 if AValue then
219 begin
220 IconData := nil;
221 Modified := True;
222 fFileAgeValid := false;
223 end
224 else
225 begin
226 // We need to restore data from the .ico file
227 try
228 fs:=TFileStream.Create(IcoFileName,fmOpenRead);
229 try
230 SetLength(NewData, fs.Size);
231 if length(NewData)>0 then
232 fs.Read(NewData[0],length(NewData));
233 IconData := NewData;
234 fFileAge:=FileAgeCached(IcoFileName);
235 fFileAgeValid:=true;
236 Modified := true;
237 finally
238 fs.Free
239 end;
240 except
241 end;
242 end;
243 end;
244
245 constructor TProjectIcon.Create;
246 begin
247 inherited Create;
248 FData := nil;
249 end;
250
251 procedure TProjectIcon.SetIconData(const AValue: TIconData);
252 begin
253 if (Length(AValue) = Length(FData)) and
254 (FData <> nil) and
255 (CompareByte(AValue[0], FData[0], Length(FData)) = 0)
256 then
257 Exit;
258 FData := AValue;
259 fFileAgeValid := false;
260 {$IFDEF VerboseIDEModified}
261 debugln(['TProjectIcon.SetIconData ']);
262 {$ENDIF}
263 Modified := True;
264 end;
265
TProjectIcon.GetIsEmprynull266 function TProjectIcon.GetIsEmpry: Boolean;
267 begin
268 Result := FData = nil;
269 end;
270
271 procedure TProjectIcon.SetIcoFileName(AValue: String);
272 begin
273 if FIcoFileName=AValue then Exit;
274 FIcoFileName:=AValue;
275 fFileAgeValid:=false;
276 end;
277
278 initialization
279 RegisterProjectResource(TProjectIcon);
280
281 end.
282
283