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