rxresexp.pas

rx library V2.7.7a component use in delphi7 to delphi 2006

        EnableMenuItem(FProjectResources, True);
      end;
{$IFNDEF RX_D4}
    fnProjectDesktopLoad:
      FProjectResources.LoadDesktop(FileName);
    fnProjectDesktopSave:
      FProjectResources.SaveDesktop(FileName);
{$ENDIF}
  end;
end;

{$IFDEF RX_D3}
procedure TAddInNotifier.EventNotification(NotifyCode: TEventNotification;
  var Cancel: Boolean);
begin
  { Nothing to do here but needs to be overridden anyway }
end;
{$ENDIF}
{$endif}

{ TProjectNotifier }

constructor TProjectNotifier.Create(AProjectResources: TRxProjectResExpert);
begin
  inherited Create;
  FProjectResources := AProjectResources;
end;

procedure TProjectNotifier.Notify(NotifyCode: TNotifyCode);
begin
  if FProjectResources = nil then Exit;
  case NotifyCode of
    ncModuleDeleted:
      begin
        if RxResourceEditor <> nil then RxResourceEditor.Close;
        EnableMenuItem(FProjectResources, False);
        FProjectResources.CloseProject;
      end;
    ncModuleRenamed, ncProjResModified:
      begin
        FProjectResources.UpdateProjectResInfo;
        EnableMenuItem(FProjectResources, True);
      end;
  end;
end;

{$IFDEF RX_D6}   // Polaris
procedure TProjectNotifier.ComponentRenamed(const AComponent: TComponent;
  const OldName, NewName: string);
{$ELSE}
procedure TProjectNotifier.ComponentRenamed(ComponentHandle: Pointer;
  const OldName, NewName: string);
{$ENDIF}
begin
  { Nothing to do here but needs to be overridden anyway }
end;

{ TResourceEntry }

constructor TResourceEntry.Create(AEntry: TIResourceEntry);
var
  P: PChar;
begin
  inherited Create;
  FChildren := TList.Create;
  FHandle := AEntry.GetEntryHandle;
  P := AEntry.GetResourceType;
  if HiWord(Longint(P)) = 0 then begin
    FResType := CheckResType(LoWord(Longint(P)));
    FTypeId := LoWord(Longint(P));
  end;
  FType := ResTypeName(P);
  P := AEntry.GetResourceName;
  if HiWord(Longint(P)) = 0 then
    FNameId := LoWord(Longint(P));
  FName := StrText(P);
  FSize := AEntry.GetDataSize;
end;

destructor TResourceEntry.Destroy;
begin
  FChildren.Free;
  inherited Destroy;
end;

function TResourceEntry.GetResourceName: PChar;
begin
  if FNameId > 0 then Result := MakeIntResource(FNameId)
  else Result := PChar(FName);
end;

function TResourceEntry.GetResourceType: PChar;
begin
  if FTypeId > 0 then Result := MakeIntResource(FTypeId)
  else Result := PChar(FType);
end;

function TResourceEntry.GetName: string;
begin
  Result := FName;
end;

function TResourceEntry.GetTypeName: string;
begin
  Result := FType;
end;

function TResourceEntry.EnableEdit: Boolean;
begin
  Result := FResType in [rtpGroupCursor, rtpBitmap, rtpGroupIcon, rtpRCData,
    rtpAniCursor, rtpCustom];
end;

function TResourceEntry.EnableRenameDelete: Boolean;
begin
  Result := FResType in [rtpCustom, rtpGroupCursor, rtpBitmap, rtpGroupIcon,
    rtpRCData, rtpAniCursor, rtpPredefined];
  if (FResType = rtpGroupIcon) then
    Result := CompareText(GetName, 'MAINICON') <> 0;
end;

function TResourceEntry.GetCursorOrIcon(ResFile: TIResourceFile;
  IsIcon: Boolean): HIcon;
var
  Entry, ChildEntry: TIResourceEntry;
  I: Integer;
begin
  Result := 0;
  if not (FResType in [rtpGroupIcon, rtpGroupCursor]) then Exit;
  Entry := ResFile.FindEntry(GetResourceType, GetResourceName);
  try
    I := LookupIconIdFromDirectory(Entry.GetData, IsIcon);
    if I > 0 then begin
      if IsIcon then
        ChildEntry := ResFile.FindEntry(RT_ICON, PChar(I))
      else
        ChildEntry := ResFile.FindEntry(RT_CURSOR, PChar(I));
      if ChildEntry <> nil then
      try
        with ChildEntry do
          Result := CreateIconFromResourceEx(GetData, GetDataSize,
            IsIcon, $30000, 0, 0, $80);
      finally
        ChildEntry.Free;
      end;
    end;
  finally
    Entry.Free;
  end;
end;

procedure TResourceEntry.GetIconData(ResFile: TIResourceFile; Stream: TStream);
var
  Data: TIconData;
  Entry: TIResourceEntry;
  I: Integer;
  P: PChar;
begin
  if not (FResType in [rtpGroupIcon, rtpGroupCursor]) then Exit;
  Data := TIconData.Create;
  try
    Entry := ResFile.FindEntry(GetResourceType, GetResourceName);
    try
      Data.LoadResourceGroup(Entry.GetData, Entry.GetDataSize);
    finally
      Entry.Free;
    end;
    for I := 0 to Data.FHeader.Count - 1 do begin
      P := MakeIntResource(Data.FNames^[I]);
      if FResType = rtpGroupIcon then
        Entry := ResFile.FindEntry(RT_ICON, P)
      else {rtpGroupCursor}
        Entry := ResFile.FindEntry(RT_CURSOR, P);
      try
        Data.LoadResourceItem(I, Entry.GetData, Entry.GetDataSize);
      finally
        Entry.Free;
      end;
    end;
    Data.SaveToStream(Stream);
  finally
    Data.Free;
  end;
end;

function TResourceEntry.GetBitmap(ResFile: TIResourceFile): TBitmap;

  function GetDInColors(BitCount: Word): Integer;
  begin
    case BitCount of
      1, 4, 8: Result := 1 shl BitCount;
      else Result := 0;
    end;
  end;

var
  Header: PBitmapFileHeader;
  BI: PBitmapInfoHeader;
  BC: PBitmapCoreHeader;
  Entry: TIResourceEntry;
  Mem: TMemoryStream;
  ClrUsed: Integer;
begin
  Result := nil;
  if FResType <> rtpBitmap then Exit;
  Mem := TMemoryStream.Create;
  try
    Entry := ResFile.FindEntry(GetResourceType, GetResourceName);
    try
      Mem.SetSize(Entry.GetDataSize + SizeOf(TBitmapFileHeader));
      Move(Entry.GetData^, Pointer(PChar(Mem.Memory) +
        SizeOf(TBitmapFileHeader))^, Mem.Size);
      Header := PBitmapFileHeader(Mem.Memory);
      BI := PBitmapInfoHeader(PChar(Mem.Memory) + SizeOf(TBitmapFileHeader));
      { fill header }
      with Header^ do begin
        if BI^.biSize = SizeOf(TBitmapInfoHeader) then begin
          ClrUsed := BI^.biClrUsed;
          if ClrUsed = 0 then ClrUsed := GetDInColors(BI^.biBitCount);
          bfOffBits :=  ClrUsed * SizeOf(TRGBQuad) +
            SizeOf(TBitmapInfoHeader) + SizeOf(TBitmapFileHeader);
        end
        else begin
          BC := PBitmapCoreHeader(PChar(Mem.Memory) +
            SizeOf(TBitmapFileHeader));
          ClrUsed := GetDInColors(BC^.bcBitCount);
          bfOffBits :=  ClrUsed * SizeOf(TRGBTriple) +
            SizeOf(TBitmapCoreHeader) + SizeOf(TBitmapFileHeader);
        end;
        bfSize := bfOffBits + BI^.biSizeImage;
        bfType := $4D42; { BM }
      end;
    finally
      Entry.Free;
    end;
    Result := TBitmap.Create;
    try
      Result.LoadFromStream(Mem);
    except
      Result.Free;
      raise;
    end;
  finally
    Mem.Free;
  end;
end;

procedure TResourceEntry.GetData(ResFile: TIResourceFile; Stream: TStream);
var
  Entry: TIResourceEntry;
begin
  Entry := ResFile.FindEntry(GetResourceType, GetResourceName);
  try
    Stream.WriteBuffer(Entry.GetData^, Entry.GetDataSize);
  finally
    Entry.Free;
  end;
end;

function TResourceEntry.GetGraphic(ResFile: TIResourceFile): TGraphic;
begin
  Result := nil;
  case FResType of
    rtpBitmap: Result := GetBitmap(ResFile);
    rtpGroupIcon:
      begin
        Result := TIcon.Create;
        try
          TIcon(Result).Handle := GetCursorOrIcon(ResFile, True);
        except
          Result.Free;
          raise;
        end;
      end;
  end;
end;

function TResourceEntry.Rename(ResFile: TIResourceFile;
  const NewName: string): Boolean;
var
  P: PChar;
  AName: string;
  Id: Word;
  Code: Integer;
  Entry: TIResourceEntry;
begin
  Result := False;
  Entry := ResFile.FindEntry(GetResourceType, GetResourceName);
  try
    Val(NewName, Id, Code);
    if Code = 0 then P := MakeIntResource(Id)
    else begin
      if not IsValidIdent(NewName) then
        raise Exception.Create(Format(sInvalidName, [NewName]));
      AName := AnsiUpperCase(NewName);
      P := PChar(AName);
    end;
    Result := Entry.Change(Entry.GetResourceType, P);
    if Result then begin
      P := Entry.GetResourceName;
      if HiWord(Longint(P)) = 0 then FNameId := LoWord(Longint(P));
      FName := StrText(P);
    end;
  finally
    Entry.Free;
  end;
end;

{ TRxProjectResExpert }

{$ifdef use_toolsapi}

procedure TRxProjectResExpert.CreateResourcesMenuItem;
var
  MainMenu: TMainMenu;
  ViewMenu: TMenuItem;
  NTAServices: INTAServices;
begin
  if not Supports(BorlandIDEServices, INTAServices, NTAServices) then
    exit;
  MainMenu := NTAServices.GetMainMenu;
  if not Assigned(MainMenu) then
    exit;
  ViewMenu := MainMenu.Owner.FindComponent('ViewsMenu') as TMenuItem;
  if not Assigned(ViewMenu) then
    exit;
  ProjectResourcesItem := TMenuItem.Create(MainMenu.Owner);
  ProjectResourcesItem.Name := 'ViewPrjResourceItem';
  ProjectResourcesItem.Caption := sMenuItemCaption;
  ProjectResourcesItem.OnClick := ProjectResourcesClick;
  ViewMenu.Insert(1, ProjectResourcesItem);
end;

procedure TRxProjectResExpert.RegisterNotifier;
var
  OTAServices: IOTAServices;
begin
  if not Supports(BorlandIDEServices, IOTAServices, OTAServices) then
    exit;
  FNotifierIdx := OTAServices.AddNotifier(AddInNotifier);
end;

procedure TRxProjectResExpert.UnRegisterNotifier;
var
  OTAServices: IOTAServices;
begin
  if FNotifierIdx <> 0 then begin
    if not Supports(BorlandIDEServices, IOTAServices, OTAServices) then
      exit;
    OTAServices.RemoveNotifier(FNotifierIdx);
    FNotifierIdx := 0;
  end;
end;

{$else}

procedure TRxProjectResExpert.CreateResourcesMenuItem;
var
  MainMenu: TIMainMenuIntf;
  ProjSrcMenu: TIMenuItemIntf;
  ViewMenu: TIMenuItemIntf;
  MenuItems: TIMenuItemIntf;
begin
  inherited Create;
  FResourceList := TStringList.Create;
  if not Assigned(ToolServices) then
    exit;
  MainMenu := ToolServices.GetMainMenu;
  if MainMenu <> nil then
  try
    MenuItems := MainMenu.GetMenuItems;
    if MenuItems <> nil then
    try
      ProjSrcMenu := MainMenu.FindMenuItem('ViewPrjSourceItem');
      if ProjSrcMenu <> nil then
      try
        ViewMenu := ProjSrcMenu.GetParent;
        if ViewMenu <> nil then
        try
          if (MainMenu.FindMenuItem('ViewPrjResourceItem')=nil) then // Polaris
          ProjectResourcesItem := ViewMenu.InsertItem(
            ProjSrcMenu.GetIndex, GetMenuText, 'ViewPrjResourceItem',
            '', 0, 0, 0, [mfVisible], ProjectResourcesClick);
        finally
          ViewMenu.Free;
        end;
      finally
        ProjSrcMenu.Free;
      end;
    finally
      MenuItems.Free;
    end;
  finally
    MainMenu.Free;
  end;
end;

procedure TRxProjectResExpert.RegisterNotifier;
begin
  if Assigned(ToolServices) then begin
    AddInNotifier := TAddInNotifier.Create(Self);
{$IFDEF RX_D4}
    ToolServices.AddNotifierEx(AddInNotifier);
{$ELSE}
    ToolServices.AddNotifier(AddInNotifier);
{$ENDIF}
  end;
end;

procedure TRxProjectResExpert.UnRegisterNotifier;
begin
  if Assigned(ToolServices) and Assigned(AddInNotifier) then
    ToolServices.RemoveNotifier(AddInNotifier);
end;

{$endif}

constructor TRxProjectResExpert.Create;
begin
  inherited Create;
  FResourceList := TStringList.Create;
  CreateResourcesMenuItem;
  RegisterNotifier;
end;

destructor TRxProjectResExpert.Destroy;
begin
  try
    if RxResourceEditor <> nil then RxResourceEditor.Free;
    UnregisterNotifier;
    CloseProject;
    ProjectResourcesItem.Free;
    AddInNotifier.Free;
    FResourceList.Free;
  except
    on e: exception do
      ;
    // for whatever reason there can be exceptions here, ignore them
  end;
  inherited Destroy;
end;

function TRxProjectResExpert.GetName: string;
begin
  Result := sExpertName;
end;

function TRxProjectResExpert.GetAuthor: string;
begin
  Result := '';
end;

{$ifndef use_toolsapi}
function TRxProjectResExpert.GetComment: string;
begin
  Result := '';
end;

function TRxProjectResExpert.GetPage: string;
begin
  Result := '';
end;

function TRxProjectResExpert.GetGlyph: HICON;
begin
  Result := 0;
end;