mainform.pas

學習資料網上下載

 | procedure DetachMenu                                                 |
 |                                                                      |
 | Global procedure - detaches a menu to a button (the ...Object one)   |
 *----------------------------------------------------------------------*)
procedure DetachMenu (const buttonCaption : string);
var
  i : Integer;
  btn : TToolButton;
begin
  if csDestroying in fmMain.ComponentState then Exit;
  btn := Nil;
  for i := 0 to fmMain.tbMenu.ButtonCount - 1 do
    if fmMain.tbMenu.Buttons [i].Caption = buttonCaption then
    begin
      btn := fmMain.tbMenu.Buttons [i];
      break
    end;

  if Assigned (btn) then
  begin
    btn.Visible := False;
    btn.MenuItem := Nil
  end
end;

(*----------------------------------------------------------------------*
 | function GetTypeName                                                 |
 |                                                                      |
 | Get the display name for a resource type                             |
 *----------------------------------------------------------------------*)
function GetTypeName (const tp : string) : string;
var
  i : Integer;
begin
  i := ResourceNameToInt (tp);

  case i of
    Integer (RT_BITMAP)       : result := rstBitmap;
    Integer (RT_ICON)         : result := rstIcon;
    Integer (RT_CURSOR)       : result := rstCursor;
    Integer (RT_MENU)         : result := rstMenu;
    Integer (RT_DIALOG)       : result := rstDialog;
    Integer (RT_STRING)       : result := rstString;
    Integer (RT_ACCELERATOR)  : Result := rstAccelerator;
    Integer (RT_RCDATA)       : result := rstRCData;
    Integer (RT_MESSAGETABLE) : result := rstMessageTable;
    Integer (RT_VERSION)      : result := rstVersion;
    Integer (RT_GROUP_CURSOR) : result := rstGroupCursor;
    Integer (RT_GROUP_ICON)   : result := rstGroupIcon;
    Integer (RT_XPMANIFEST)   : result := rstXPManifest;
    else
      result := tp
  end
end;

(*----------------------------------------------------------------------*
 | function GetTypeImage                                                |
 |                                                                      |
 | Get the image index for a resource type                              |
 *----------------------------------------------------------------------*)
function GetTypeImage (const tp : string) : Integer;
var
  i : Integer;
begin
  Result := 0;
  i := ResourceNametoInt (tp);

  case i of
    Integer (RT_VERSION) : i := 8;
    Integer (RT_MESSAGETABLE) : i := Integer (RT_STRING)
  end;

  if (i >= 0) and (i < 10) then
    Result := i
  else
    if tp = 'MIDI' then
      Result := 12
    else
      if tp = 'WAVE' then
       Result := 13
end;

(*----------------------------------------------------------------------*
 | function GetGraphicsClass : TGraphicClass                            |
 |                                                                      |
 | Get a graphic class associated with an extension                     |
 |                                                                      |
 | Parameters:                                                          |
 |                                                                      |
 |   ext : string                 The extension to find.                |
 |                                                                      |
 | The function returns the graphics class                              |
 *----------------------------------------------------------------------*)
function GetGraphicsClass (ext : string) : TGraphicClass;
begin
  ext := UpperCase (ext);
  if (ext <> '') and (ext [1] = '.') then
    Delete (ext, 1, 1);

  if ext = 'BMP' then
    Result := TBitmap
  else
    if (ext = 'WMF') or (ext = 'EMF') then
      Result := TMetafile
    else
      if ext = 'ICO' then
        Result := TExIcon
      else
        if ext = 'CUR' then
          Result := TExCursor
        else
          if (ext = 'JPG') or (ext = 'JPEG') then
            Result := TJpegImage
          else
            if ext = 'GIF' then
              Result := TGIFImage
            else
              if ext = 'PNG' then
                result := TPngObject
              else
                Result := Nil
end;

function CreateCompatibleGraphic (graphic : TGraphic; newCls : TGraphicClass) : TGraphic;
var
  viaBitmap : boolean;
  bmp : TBitmap;
  gif : TGifImage;
begin
  viaBitmap := (newCls = TPNGObject);

  result := newCls.Create;
  try
    if viaBitmap then
    begin
      bmp := TBitmap.Create;
      try
        bmp.Assign (graphic);

    (*
        bmp.Width := graphic.Width;
        bmp.Height := graphic.Height;
        bmp.Palette := graphic.Palette;
    *)
        result.Assign (bmp)
      finally
        bmp.Free
      end
    end
    else
      if newCls = TGifImage then
      begin
        gif := TGifImage (result);
        gif.DitherMode := dmFloydSteinberg;
        gif.ColorReduction := rmQuantizeWindows;
        result.Assign (graphic);
      end
      else
        result.Assign (graphic)
  except
    FreeAndNil (result)
  end
end;

{ TfmMain }

(*----------------------------------------------------------------------*
 | procedure TfmMain.actFileOpenExecute                                 |
 |                                                                      |
 | FileOpen action handler.                                             |
 *----------------------------------------------------------------------*)
procedure TfmMain.actFileOpenFileExecute(Sender: TObject);
begin
  Application.ProcessMessages;  // Ensures that toolbar button doesn't temporarily disappear

  OpenDialog.InitialDir := MRUList1.MRUDirectory;
  if OpenDialog.Execute then
    OpenFile (OpenDialog.FileName);
end;

(*----------------------------------------------------------------------*
 | procedure TfmMain.actFileSaveAsExecute                               |
 |                                                                      |
 | FileSaveAs action handler                                            |
 *----------------------------------------------------------------------*)
procedure TfmMain.actFileSaveAsExecute(Sender: TObject);
begin
  SaveFileAs
end;

(*----------------------------------------------------------------------*
 | procedure TfmMain.actFilePrintExecute                                |
 |                                                                      |
 | FilePrint action handler                                             |
 *----------------------------------------------------------------------*)
procedure TfmMain.actFilePrintExecute(Sender: TObject);
begin
  if PrintDialog.Execute then
end;

(*----------------------------------------------------------------------*
 | procedure TfmMain.actFileNewExecute                                  |
 |                                                                      |
 | FileNew action handler                                               |
 *----------------------------------------------------------------------*)
procedure TfmMain.actFileNewExecute(Sender: TObject);
begin
  if SaveChanges then
  begin
    FreeAndNil (fResourceModule);
    ClearUndoDetails;
    fResourceModule := TResModule.Create; // Create an empty .RES module
    FileName := '';
    UpdateDisplay
  end
end;

(*----------------------------------------------------------------------*
 | procedure TfmMain.actFileExitExecute                                 |
 |                                                                      |
 | FileExit action handler                                              |
 *----------------------------------------------------------------------*)
procedure TfmMain.actFileExitExecute(Sender: TObject);
begin
  Close
end;

(*----------------------------------------------------------------------*
 | procedure TfmMain.FormDestroy                                        |
 |                                                                      |
 | Tidy up                                                              |
 *----------------------------------------------------------------------*)
procedure TfmMain.FormDestroy(Sender: TObject);
begin
  fResourceModule.Free;
  fProperties.Free;
end;

(*----------------------------------------------------------------------*
 | procedure TfmMain.UpdateDisplay                                      |
 |                                                                      |
 | Update the display by building the tree view.                        |
 *----------------------------------------------------------------------*)
procedure TfmMain.UpdateDisplay;
var
  i : Integer;
  rootNode, sectionNode : TTreeNode;
  section : TImageSection;
  peModule : TPEResourceModule;

//------------------------------------------------------------------
// procedure AddResources.  Add the resources to the tree view
// at the specified node.
  procedure AddResources (node : TTreeNode);
  var
    j, k : Integer;
    lastTp, lastName : string;
    lastTypeItem, lastNameItem, lastLangItem, itm : TTreeNode;
    grp : TIconCursorGroupResourceDetails;
    grpDetails : TIconCursorResourceDetails;
    details : TResourceDetails;
    st : string;
  begin
    lastTp := '~';
    lastName := '~';
    lastNameItem := Nil;
    lastTypeItem := Nil;
    for j := 0 to fResourceModule.ResourceCount - 1 do
    begin
      details := fResourceModule.ResourceDetails [j];

      if (details.ResourceName <> lastName) or (details.ResourceType <> lastTp) then
      begin
        if details.ResourceType <> lastTp then
        begin
          lastTp := details.ResourceType;

          if not (details is TIconCursorResourceDetails) then
          begin
                                                // Add 'Type' node

            lastTypeItem := tvResources.Items.AddChild (node, GetTypeName (details.ResourceType));
            lastTypeItem.ImageIndex := imgClosedFolder;
            lastTypeItem.SelectedIndex := imgClosedFolder;
          end

        end;

        if not (details is TIconCursorResourceDetails) then

        begin   // Don't add Icon/Cursor resources.  They're added by their resource group

                // Add 'Name' node

          st := details.ResourceName;
          if details is TStringResourceDetails then
            st := ResIDToStringsId (details.ResourceName)
          else
            st := details.ResourceName;
            
          lastNameItem := tvResources.Items.AddChild (lastTypeItem, st);
          lastNameItem.ImageIndex := imgClosedFolder;
          lastNAmeItem.SelectedIndex := imgClosedFolder;
          lastName := details.ResourceName
        end
      end;

      if not (details is TIconCursorResourceDetails) then
      begin
        if Details.ResourceLanguage = 0 then
          st := rstLanguageNeutral
        else
          st := Languages.NameFromLocaleID [Details.ResourceLanguage];

                // Add Language node - contains the resource details
        lastLangItem := tvResources.Items.AddChildObject (lastNameItem, st, details);

        if details is TIconCursorGroupResourceDetails then
        begin
                // If we've added a Icon or Cursor group, add the icon or cursor resources
          grp := TIconCursorGroupResourceDetails (details);
          lastLangItem.ImageIndex := imgClosedFolder;
          lastLangItem.SelectedIndex := imgClosedFolder;

          for k := 0 to grp.ResourceCount - 1 do
          begin
            grpDetails := grp.ResourceDetails [k];
            if Assigned (grpDetails) then
            begin
              case grpDetails.PixelFormat of
                pf1Bit : st := Format (rstColors, [2]);
                pf4Bit : st := Format (rstColors, [16]);
                pf8Bit : st := Format (rstColors, [256]);
                pf15Bit : st := Format (rstColors, [32768]);
                pf16Bit : st := Format (rstColors, [65536]);
                pf24Bit : st := rstHighColor;
                pf32Bit : st := rstTrueColor;
                else
                  st := sUnknown
              end;
              st := Format ('%dx%d %s', [grpDetails.Width, grpDetails.Height, st]);
              itm := tvResources.Items.AddChildObject (lastLangItem, st, grpDetails);
              itm.ImageIndex := GetTypeImage (grpDetails.ResourceType);
              itm.SelectedIndex := itm.ImageIndex;
            end
            else
              tvResources.Items.AddChild (lastLangItem, '???');
          end
        end
        else
        begin
          lastLangItem.ImageIndex := GetTypeImage (details.ResourceType);
          lastLangItem.SelectedIndex := lastLangItem.ImageIndex
        end
      end
    end
  end;

begin { UpdateDisplay }
  SwitchView (Nil);

  if not Assigned (fResourceModule) then Exit;

  fCOFFSectionsShowing := fProperties.ShowCOFFSections;


  tvResources.Items.BeginUpdate;