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