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