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  Author of LazRes: Mattias Gaertner
22  Original idea for GLazRes: Andy Koz
23  Adapted by: Bart Broersma
24
25  GLazRes aims to be a GUI implementation of the LazRes program.
26}
27
28unit glazresmain;
29
30{$mode objfpc}{$H+}
31
32interface
33
34uses
35  Classes, SysUtils, Types, IniFiles,
36  Forms, Controls, Graphics, Dialogs, StdCtrls, Buttons, ExtDlgs, EditBtn,
37  LResources, LCLProc, LCLType,
38  LazFileUtils, LazUTF8;
39
40type
41
42  { TGLazResForm }
43
44  TGLazResForm = class(TForm)
45    ClearBtn: TBitBtn;
46    CloseBtn: TBitBtn;
47    DestEdt: TFileNameEdit;
48    MessagesLabel: TLabel;
49    OpenPictureDialog: TOpenPictureDialog;
50    AddImgBtn: TBitBtn;
51    StartBtn: TBitBtn;
52    FilesLabel: TLabel;
53    FileListBox: TListBox;
54    MsgMemo: TMemo;
55    AddAnyBtn: TBitBtn;
56    LrsLabel: TLabel;
57    OpenDialog: TOpenDialog;
58    DeleteBtn: TBitBtn;
59    procedure AddImgBtnClick(Sender: TObject);
60    procedure ClearBtnClick(Sender: TObject);
61    procedure DeleteBtnClick(Sender: TObject);
62    procedure DestEdtAcceptFileName(Sender: TObject; var {%H-}Value: String);
63    procedure DestEdtEditingDone(Sender: TObject);
64    procedure FileListBoxDrawItem(Control: TWinControl; Index: Integer;
65      ARect: TRect; {%H-}State: TOwnerDrawState);
66    procedure FormClose(Sender: TObject; var {%H-}CloseAction: TCloseAction);
67    procedure FormCreate(Sender: TObject);
68    procedure FormResize(Sender: TObject);
69    procedure FormShow(Sender: TObject);
70    procedure AddAnyBtnClick(Sender: TObject);
71    procedure StartBtnClick(Sender: TObject);
72  private
73    FIniFileName: String;
74    procedure CreateAnchors;
75    procedure ResizeControls({%H-}Dummy: PtrInt);
76    procedure CreateLazarusResourceFile;
77    procedure ConvertFormToText(Stream: TMemoryStream);
78    procedure AddFiles(Names: TStrings);
79    procedure MaybeEnableButtons;
80    procedure AddMessage(const Msg: String);
81    procedure AddMessageFmt(const Msg: String; Args: Array of const);
82    procedure ClearMessages;
83    procedure LoadWindowGeometry;
84    procedure SaveWindowGeometry;
85  public
86
87  end;
88
89var
90  GLazResForm: TGLazResForm;
91
92
93implementation
94
95{$R *.lfm}
96
97resourcestring
98  ErrConvertToText = 'ERROR: unable to convert Delphi form to text: "%s"';
99  ErrFileNotFound = 'ERROR: File not found: "%s"';
100  ErrFileIsResource = 'ERROR: Cannot add resource file to itself ("%s")';
101  ErrCreate = 'ERROR: Cannot create "%s"';
102  ErrNoResourceName = 'ERROR: No resourcename found for "%s"';
103  MsgCreatingLrs = 'Creating "%s"';
104  MsgProcessing = 'Processing "%s"';
105  MsgResourceNameType = ' Resource name = "%s", Type = "%s"';
106  ErrRead = 'ERROR: Cannot read from "%s"';
107  MsgSuccess = 'Done.'+ LineEnding + 'Number of resources added: %d.';
108
109  MsgWrongExt = 'Filename does not have the required extension: fix it?';
110
111  DESaveResourcefileAs = 'Save resourcefile as';
112  DEFilter = 'Lazarus Resource Files|*.lrs|All Files|*';
113  ODOpenExistingFile = 'Open existing file';
114  OPDOpenExistingPicture = 'Open existing picture';
115  OPDFilter ='Graphic (*.png;*.xpm;*.bmp;*.cur;*.ico;*.icns;*.jpeg;*.jpg;*.jpe;*.jfif;*.tif;*.tiff;*.gif;*.pbm;*.pgm;*.ppm;*.gif;*.tga)|*.png;*.xpm;*.bmp;*.cur;*.ico;*.icns;*.jpeg;*.jpg;*.jpe;*.jfif;*.tif;*.tiff;*.gif;*.pbm;*.pgm;*.ppm;*.gif;*.tga|Portable Network Graphic (*.png)|*.png|Pixmap (*.xpm)|*.xpm|Bitmaps (*.bmp)|*.bmp|Cursor (*.cur)|*.cur|Icon (*.ico)|*.ico|Mac OS X Icon (*.icns)|*.icns|Joint Picture Expert Group (*.jpeg;*.jpg;*.jpe;*.jfif)|*.jpeg;*.jpg;*.jpe;*.jfif|Tagged Image File Format (*.tif;*.tiff)|*.tif;*.tiff|Graphics Interchange Format (*.gif)|*.gif|Portable PixMap (*.pbm;*.pgm;*.ppm)|*.pbm;*.pgm;*.ppm|Animated GIF (*.gif)|*.gif|TGA Image File (*.tga)|*.tga|';
116  OPDFilterAll = 'All files';
117  CBtnCancel = 'Cancel';
118
119const
120  AppName = 'GLazRes';
121  IniName = {$ifdef windows}'GLazRes.ini'{$else}'glazres.conf'{$endif};
122  scPosition = 'Position';
123  idLeft = 'Left';
124  idTop = 'Top';
125  idWidth = 'Width';
126  idHeight = 'Height';
127
128//Needed for GetAppConfigDir
129function GetVendorName: String;
130begin
131  Result := '';
132end;
133
134function GetAppName: String;
135begin
136  Result := AppName;
137end;
138
139{TGLazResForm}
140
141// *************** Component Events *********************** //
142
143procedure TGLazResForm.FormCreate(Sender: TObject);
144begin
145  OnGetVendorName := @GetVendorName;
146  OnGetApplicationName := @GetAppName;
147  FIniFileName := GetAppConfigDir(False) + IniName;
148  CreateAnchors;
149  LoadWindowGeometry;
150  DestEdt.DialogTitle := DESaveResourcefileAs;
151  DestEdt.Filter := DEFilter;
152  OpenDialog.Title := ODOpenExistingFile;
153  //OpenDialog.Filter := OPDFilterAll + {$IFDEF WINDOWS} ' (*.*)|*.*|' {$ELSE} ' (*)|*|' {$ENDIF} ;
154  OpenPictureDialog.Title := OPDOpenExistingPicture;
155  OpenPictureDialog.Filter := OPDFilter + OPDFilterAll + {$IFDEF WINDOWS} ' (*.*)|*.*|' {$ELSE} ' (*)|*|' {$ENDIF} ;
156  CloseBtn.Caption := CBtnCancel;
157end;
158
159procedure TGLazResForm.FormShow(Sender: TObject);
160begin
161  MaybeEnableButtons;
162  OnResize := @FormResize;
163  //Using QueueAsyncCall delays the layout until the form is shown,
164  //before that ClientWidht may have wrong value (depending on widgetset and windowmanager)
165  Application.QueueAsyncCall(@ResizeControls,0);
166end;
167
168procedure TGLazResForm.FormClose(Sender: TObject; var CloseAction: TCloseAction);
169begin
170  SaveWindowGeometry;
171end;
172
173
174procedure TGLazResForm.FormResize(Sender: TObject);
175begin
176  ResizeControls(0);
177end;
178
179
180procedure TGLazResForm.DestEdtAcceptFileName(Sender: TObject; var Value: String);
181begin
182  DestEdtEditingDone(DestEdt);
183end;
184
185procedure TGLazResForm.DestEdtEditingDone(Sender: TObject);
186var
187  Fn, Ext: String;
188begin
189  Fn := DestEdt.FileName;
190  Ext := ExtractFileExt(Fn);
191  if (Fn <> '') and (CompareText(Ext, '.lrs') <> 0) then
192  begin
193    if MessageDlg(AppName,MsgWrongExt,mtConfirmation,[mbYes,mbNo],0) = mrYes then
194    begin
195      Fn := ChangeFileExt(Fn, '.lrs');
196      DestEdt.FileName := Fn;
197    end;
198  end;
199  MaybeEnableButtons;
200end;
201
202
203procedure TGLazResForm.StartBtnClick(Sender: TObject);
204begin
205  CreateLazarusResourceFile;
206end;
207
208
209procedure TGLazResForm.AddAnyBtnClick(Sender: TObject);
210begin
211  if OpenDialog.Execute then
212  begin
213    AddFiles(OpenDialog.Files);
214  end;
215end;
216
217procedure TGLazResForm.AddImgBtnClick(Sender: TObject);
218begin
219  if OpenPictureDialog.Execute then
220  begin
221    AddFiles(OpenPictureDialog.Files);
222  end;
223end;
224
225
226procedure TGLazResForm.DeleteBtnClick(Sender: TObject);
227var
228  Index: integer;
229begin
230  for Index := FileListBox.Count - 1 downto 0 do
231  begin
232    if FileListBox.Selected[Index] then
233      FileListBox.Items.Delete(Index);
234  end;
235  MaybeEnableButtons;
236end;
237
238
239procedure TGLazResForm.ClearBtnClick(Sender: TObject);
240begin
241  FileListBox.Items.Clear;
242  MaybeEnableButtons;
243end;
244
245
246procedure TGLazResForm.FileListBoxDrawItem(Control: TWinControl; Index: Integer;
247  ARect: TRect; State: TOwnerDrawState);
248var
249  OldBrushStyle: TBrushStyle;
250  OldTextStyle: TTextStyle;
251  NewTextStyle: TTextStyle;
252  ItemText: String;
253  TheCanvas: TCanvas;
254begin
255  //Objective: draw only the FileName, not the fully qualified path.
256  TheCanvas := (Control as TCustomListBox).Canvas;
257
258  ItemText := ExtractFileName(FileListBox.Items[Index]);
259
260  if not(odBackgroundPainted in State) then
261    TheCanvas.FillRect(ARect);
262
263  OldBrushStyle := TheCanvas.Brush.Style;
264  TheCanvas.Brush.Style := bsClear;
265
266  OldTextStyle := TheCanvas.TextStyle;
267  NewTextStyle := OldTextStyle;
268  NewTextStyle.Layout := tlCenter;
269  NewTextStyle.RightToLeft := Control.UseRightToLeftReading;
270  if Control.UseRightToLeftAlignment then
271  begin
272    NewTextStyle.Alignment := taRightJustify;
273    ARect.Right := ARect.Right - 2;
274  end
275  else
276  begin
277    NewTextStyle.Alignment := taLeftJustify;
278    ARect.Left := ARect.Left + 2;
279  end;
280
281  TheCanvas.TextStyle := NewTextStyle;
282
283  TheCanvas.TextRect(ARect, ARect.Left, ARect.Top, ItemText);
284  TheCanvas.Brush.Style := OldBrushStyle;
285  TheCanvas.TextStyle := OldTextStyle;
286end;
287
288
289
290
291// ***************** Form layout and looks *********************** //
292
293procedure TGLazResForm.CreateAnchors;
294begin
295  DestEdt.AnchorToNeighbour(akTop, 5, LrsLabel);
296  FilesLabel.AnchorToNeighbour(akTop, 10, DestEdt);
297  FileListBox.AnchorToNeighbour(akTop, 5, FilesLabel);
298  AddAnyBtn.AnchorToNeighbour(akTop, 10, FileListBox);
299  AddImgBtn.AnchorToNeighbour(akTop, 10, FileListBox);
300  DeleteBtn.AnchorToNeighbour(akTop, 10, FileListBox);
301  ClearBtn.AnchorToNeighbour(akTop, 10, FileListBox);
302  AddImgBtn.AnchorToNeighbour(akLeft, 5 , AddAnyBtn);
303  DeleteBtn.AnchorToNeighbour(akLeft, 15, AddImgBtn);
304  ClearBtn.AnchorToNeighbour(akLeft, 5, DeleteBtn);
305  MessagesLabel.AnchorToNeighbour(akTop, 10, AddAnyBtn);
306  MsgMemo.AnchorToNeighbour(akTop, 5, MessagesLabel);
307  StartBtn.AnchorToNeighbour(akTop, 10, MsgMemo);
308  CloseBtn.AnchorToNeighbour(akTop, 10, MsgMemo);
309  CloseBtn.AnchorToNeighbour(akLeft, 5, StartBtn);
310end;
311
312
313
314procedure TGLazResForm.ResizeControls(Dummy: PtrInt);
315var
316  CH, CW, LMargin, MinW, MinH, HeightLeft: Integer;
317begin
318  CH := ClientHeight;
319  CW := ClientWidth;
320  LMargin := LrsLabel.Left;
321  MinW :=  ClearBtn.Left + ClearBtn.Width + 2 * LMargin;
322  DestEdt.Width := CW - (2 * LMargin) - DestEdt.ButtonWidth;
323  if (DestEdt.Width < MinW) then DestEdt.Width := MinW;
324  FileListBox.Width := CW - (2 * LMargin);
325  if (FileListBox.Width < MinW) then FileListBox.Width := MinW;
326  MsgMemo.Width := FileListBox.Width;
327  StartBtn.Left := CW - (StartBtn.Width + CloseBtn.Width + 5) - LMargin;
328
329  MinH := 532; //desing time value
330  if CH <= MinH then
331  begin
332    MsgMemo.Height := 138;// design time value;
333    Exit;
334  end;
335  HeightLeft := CH - MsgMemo.Top;
336  MsgMemo.Height := HeightLeft - StartBtn.Height - 10 - 10;
337end;
338
339
340procedure TGLazResForm.LoadWindowGeometry;
341var
342  IniDir: String;
343  Ini: TIniFile;
344  L, T, W, H: LongInt;
345begin
346  IniDir := ExtractFileDir(FIniFileName);
347  if not DirectoryExists(IniDir) then if not ForceDirectories(IniDir) then Exit;
348  try
349    Ini := TIniFile.Create(FIniFileName);
350    try
351      L := Ini.ReadInteger(scPosition, idLeft, Left);
352      T := Ini.ReadInteger(scPosition, idTop, Top);
353      W := Ini.ReadInteger(scPosition, idWidth, Width);
354      H := Ini.ReadInteger(scPosition, idHeight, Height);
355      SetBounds(L, T, W, H);
356    finally
357      Ini.Free;
358    end;
359  except
360    debugln('Error reading geometry from "',FIniFileName,'".');
361  end;
362end;
363
364procedure TGLazResForm.SaveWindowGeometry;
365var
366  IniDir: String;
367  Ini: TIniFile;
368begin
369  IniDir := ExtractFileDir(FIniFileName);
370  if not DirectoryExists(IniDir) then if not ForceDirectories(IniDir) then
371  begin
372    debugln('Unable to create config file "',FIniFileName,'".');
373    Exit;
374  end;
375  try
376    Ini := TIniFile.Create(FIniFileName);
377    try
378      Ini.CacheUpdates := True;
379      Ini.WriteInteger(scPosition, idLeft, Left);
380      Ini.WriteInteger(scPosition, idTop, Top);
381      Ini.WriteInteger(scPosition, idWidth, Width);
382      Ini.WriteInteger(scPosition, idHeight, Height);
383    finally
384      Ini.Free;
385    end;
386  except
387    debugln('Error saving geometry to "',FIniFileName,'".');
388  end;
389end;
390
391procedure TGLazResForm.MaybeEnableButtons;
392begin
393  StartBtn.Enabled := (DestEdt.FileName <> '') and
394                      (FileListBox.Count > 0);
395  DeleteBtn.Enabled := (FileListBox.Count > 0);
396  ClearBtn.Enabled := (FileListBox.Count > 0);
397end;
398
399
400// ************** LRS Creating related procedures ***************** //
401
402procedure TGLazResForm.AddFiles(Names: TStrings);
403var
404  Index: Integer;
405begin
406  for Index := 0 to Names.Count - 1 do
407  begin
408    FileListBox.Items.Add(Names[Index]);
409  end;
410  MaybeEnableButtons;
411end;
412
413
414
415procedure TGLazResForm.ConvertFormToText(Stream: TMemoryStream);
416var TextStream: TMemoryStream;
417begin
418  try
419    try
420      TextStream:=TMemoryStream.Create;
421      FormDataToText(Stream,TextStream);
422      TextStream.Position:=0;
423      Stream.Clear;
424      Stream.CopyFrom(TextStream,TextStream.Size);
425      Stream.Position:=0;
426    except
427      on E: Exception do begin
428        debugln(Format(ErrConvertToText,[E.Message]));
429      end;
430    end;
431  finally
432    TextStream.Free;
433  end;
434end;
435
436
437procedure TGLazResForm.CreateLazarusResourceFile;
438var
439  FileCount, Index:integer;
440  S:string;
441  ResFileStream, BinFileStream: TFileStream;
442  ResMemStream, BinMemStream: TMemoryStream;
443  ResourceFilename, FullResourceFilename, BinFilename, BinExt, ResourceName, ResourceType,
444    ExpS: String;
445begin
446  FileCount := FileListBox.Count;
447  if FileCount = 0 then
448    Exit;
449
450  FullResourceFileName := ExpandFileNameUtf8(DestEdt.FileName);
451  ResourceFileName := ExtractFileName(FullResourceFileName);
452  ClearMessages;
453
454  // check that all resources exists and are not the destination file
455  for Index := 0 to FileCount-1 do
456  begin
457    S := FileListBox.Items[Index]; //FileListBox[Index];
458    if not FileExistsUTF8(S) then
459    begin
460      AddMessageFmt(ErrFileNotfound,[S]);
461      exit;
462    end;
463    ExpS:=ExpandFileNameUTF8(S);
464    if (CompareText(ExpS,FullResourceFilename)=0)
465      or (CompareFilenamesIgnoreCase(ExpandFileNameUTF8(S), FullResourceFilename) = 0) then
466    begin
467      AddMessageFmt(ErrFileIsResource,[S]);
468      exit;
469    end;
470  end;
471  try
472    AddMessageFmt(MsgCreatingLrs,[FullResourceFilename]);
473    ResFileStream:=TFileStream.Create(FullResourceFileName,fmCreate);
474  except
475    AddMessageFmt(ErrCreate,[ResourceFileName]);
476    exit;
477  end;
478  ResMemStream:=TMemoryStream.Create;
479  try
480    for Index := 0 to FileCount - 1 do
481    begin
482      BinFilename:=FileListBox.Items[Index];
483      AddMessageFmt(MsgProcessing,[BinFilename]);
484      try
485        BinFileStream:=TFileStream.Create(BinFilename, fmOpenRead);
486        BinMemStream:=TMemoryStream.Create;
487        try
488          BinMemStream.CopyFrom(BinFileStream, BinFileStream.Size);
489          BinMemStream.Position := 0;
490          BinExt := Utf8UpperCase(ExtractFileExt(BinFilename));
491          if (BinExt='.LFM') or (BinExt='.DFM') or (BinExt='.XFM')
492          then
493          begin
494            ResourceType:='FORMDATA';
495            ConvertFormToText(BinMemStream);
496            ResourceName:=FindLFMClassName(BinMemStream);
497            if ResourceName='' then
498            begin
499              AddMessageFmt(ErrNoResourceName,[BinFileName]);
500              exit;
501            end;
502            AddMessageFmt(MsgResourceNameType,[ResourceName,ResourceType]);
503            LFMtoLRSstream(BinMemStream,ResMemStream);
504          end
505          else
506          begin
507            ResourceType := copy(BinExt,2,length(BinExt)-1);
508            ResourceName := ExtractFileName(BinFilename);
509            ResourceName := copy(ResourceName, 1, Length(ResourceName) - Length(BinExt));
510            if (ResourceName = '') then
511            begin
512              AddMessageFmt(ErrNoResourceName,[BinFileName]);
513              exit;
514            end;
515            AddMessageFmt(MsgResourceNameType,[ResourceName,ResourceType]);
516            BinaryToLazarusResourceCode(BinMemStream, ResMemStream ,ResourceName, ResourceType);
517          end;
518        finally
519          BinFileStream.Free;
520          BinMemStream.Free;
521        end;
522      except
523        AddMessageFmt(ErrRead,[BinfileName]);
524        exit;
525      end;
526    end;
527    ResMemStream.Position := 0;
528    ResFileStream.CopyFrom(ResMemStream, ResMemStream.Size);
529    AddMessageFmt(MsgSuccess,[FileCount]);
530  finally
531    ResMemStream.Free;
532    ResFileStream.Free;
533  end;
534end;
535
536// ****************  User interaction **************** //
537
538procedure TGLazResForm.AddMessage(const Msg: String);
539begin
540  MsgMemo.Lines.Add(Msg);
541end;
542
543procedure TGLazResForm.AddMessageFmt(const Msg: String; Args: array of const);
544begin
545  MsgMemo.Lines.Add(Format(Msg, Args));
546end;
547
548procedure TGLazResForm.ClearMessages;
549begin
550  MsgMemo.Lines.Clear;
551end;
552
553
554end.
555
556