u1.pas

来自「这是一个在图形界面下的资源编译程序」· PAS 代码 · 共 512 行

unit U1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Grids, ExtCtrls, ComCtrls;

Const
   FixBin:Array[0..31] of Byte=($00,$00,$00,$00,$20,$00,$00,$00,
                                $FF,$FF,$00,$00,$FF,$FF,$00,$00,
                                $00,$00,$00,$00,$00,$00,$00,$00,
                                $00,$00,$00,$00,$00,$00,$00,$00);

DataSpac:Array[0..17] of Byte=($00,$00,$00,$00,$00,$00,$30,$00,$04,
                               $08,$00,$00,$00,$00,$00,$00,$00,$00);

ICO16Dat:Array[0..15] of Byte=($00,$00,$00,$00,$10,$10,$04,$08,//(30H~3FH)
                               $00,$00,$00,$00,$00,$00,$00,$00);

ICOType:Array[0..7] of Byte=($FF,$FF,$03,$00,$FF,$FF,$01,$00);//ICO类型值(28H)
ICOEnd1:Array[0..3] of Byte=($14,$00,$00,$00);
//ICOEnd2:DWord;相对偏移值
ICOEnd3:Array[0..3] of Byte=($FF,$FF,$0E,$00);
//ICOEnd4:Buf;//资源名的UnCode码
ICOEnd5:Array[0..25] of Byte=($30,$10,$04,$08,$00,$00,$00,$00,
                              $00,$00,$00,$00,$00,$00,$01,$00,
                              $01,$00,$20,$20,$10,$00,$01,$00,
                              $04,$00);
//ICOEd6:DWord;数据长度
ICOEnd:Word=$0001;
Type RGBI=Record
     R:Byte;
     G:Byte;
     B:Byte;
     I:Byte;
 End;
Type
   BmpHead=Record
     BM       :Word; //标志BM
   FileLen    :DWord;//文件长度
     BL1      :Word; //保留1
     BL2      :Word; //保留2
 Bit_OffSet   :DWord;//位图数据偏移
   Info_Len   :DWord;//信息长度
   Bit_Width  :DWord;//位图宽度
   Bit_Height :DWord;//位图长度
   Bit_Page   :Word; //位图页
   Bit_Color  :Word; //位图颜色数
   Bit_Zip    :Word; //压缩标志
   Bit_RGBI   :RGBI;
End;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    B1: TButton;
    StrG1: TStringGrid;
    CBox1: TComboBox;
    SaveDlg: TSaveDialog;
    BWr: TButton;
    OpenDlg: TOpenDialog;
    B2: TButton;
    Label1: TLabel;
    EdFn: TEdit;
    B3: TButton;
    Splitter1: TSplitter;
    M1: TRichEdit;
    procedure FormCreate(Sender: TObject);
    procedure B1Click(Sender: TObject);
    procedure StrG1DrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
    procedure StrG1SelectCell(Sender: TObject; ACol, ARow: Integer;
      var CanSelect: Boolean);
    procedure CBox1Change(Sender: TObject);
    procedure CBox1Exit(Sender: TObject);
    procedure BWrClick(Sender: TObject);
    procedure BWrExit(Sender: TObject);
    procedure StrG1KeyPress(Sender: TObject; var Key: Char);
    procedure CBox1KeyPress(Sender: TObject; var Key: Char);
    procedure CBox1KeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure EdFnChange(Sender: TObject);
    procedure B3Click(Sender: TObject);
    procedure B2Click(Sender: TObject);
  private
    { Private declarations }
  public

  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
Left:=(Screen.Width-width) div 2;
Top:=(Screen.Height-Height) div 2;
StrG1.Rows[0].Text:='行号'#10'资源名'#10'资源类型'#10'资源文件';
StrG1.ColWidths[0]:=35;
StrG1.Cells[0,1]:='1';
end;

procedure TForm1.B1Click(Sender: TObject);
Var FLen,OffSet,X,M:DWord;
    FOut,FIn:File of Byte;
    B:Byte;
I,N,K,R,Idx,Cnt:Integer;
S1,S2,Fn:String;
    B1:Array[0..3] of Byte;
    Bmp:BMPHead;
begin
M1.Lines.Clear;
Cnt:=0;
M1.Lines.Add('输出文件:'+EdFn.Text);
M1.Lines.Add(#13#10'******************************************************************'#13#10);
If FileExists(EdFn.Text) Then
   if MessageBox(Handle,'文件已存在,你要覆盖吗?','文件已存在',33)<>1 Then
   Begin
    M1.SelAttributes.Color:=clRed;
    M1.SelAttributes.Style:=[fsItalic];
    M1.Lines.Add('文件已存在,你放弃了编译');
    M1.SelAttributes.Color:=M1.Font.Color;
    M1.SelAttributes.Style:=[];
    Exit;
   End;

AssignFile(FOut,EdFn.Text);
ReWrite(FOut);
BlockWrite(FOut,FixBin,32);//文件头

For R:=1 To StrG1.RowCount-1 do
Begin
X:=0;
S1:=UpperCase(Trim(StrG1.Cells[2,R]));//类型名
S2:=UpperCase(Trim(StrG1.Cells[1,R]));//资源名
Fn:=Trim(StrG1.Cells[3,R]);

if (S1='')or(S2='')or(Fn='') Then
Begin
M1.SelAttributes.Color:=clRed;
M1.SelAttributes.Style:=[fsItalic];
 M1.Lines.Add('错误: 第 '+StrG1.Cells[0,R]+' 行数据不完成!');
M1.SelAttributes.Color:=M1.Font.Color;
M1.SelAttributes.Style:=[];
 Continue;
End;

if (S2[1]>='0')and(S2[1]<='9') Then
Begin
M1.SelAttributes.Color:=clRed;
M1.SelAttributes.Style:=[fsItalic];
 M1.Lines.Add('错误: 第 '+StrG1.Cells[0,R]+' 资源名不能以数字开头!');
M1.SelAttributes.Color:=M1.Font.Color;
M1.SelAttributes.Style:=[];
 Continue;
End;

Idx:=CBox1.Items.IndexOf(S1);
if Idx<0 Then Continue;
if Not FileExists(Fn) Then
Begin
M1.SelAttributes.Color:=clRed;
M1.SelAttributes.Style:=[fsItalic];
 M1.Lines.Add('错误: 第 '+StrG1.Cells[0,R]+' 行文件:'+Fn+' 不存在!');
M1.SelAttributes.Color:=M1.Font.Color;
M1.SelAttributes.Style:=[];
 Continue;
End;

AssignFile(FIn,Fn);
filemode := 0;
ReSet(Fin);

FLen:=FileSize(FIn);

N:=Length(S1);
K:=Length(S2);//资源名长度
OffSet:=(N+K)*2+28;

Case Idx of
 3:OffSet:=OffSet-10;//RCDATA
 4:Begin // BITMAP
BlockRead(FIn,BMP,Sizeof(BMP));
if BMP.BM<>19778 Then
Begin
M1.SelAttributes.Color:=clRed;
M1.SelAttributes.Style:=[fsItalic];
M1.Lines.Add('错误: 文件 '+Fn+' 不是一个有效的位图文件！');
M1.SelAttributes.Color:=M1.Font.Color;
M1.SelAttributes.Style:=[];
CloseFile(FIn);
Continue;
End;
    X:=14;
    FLen:=FLen-X;
    OffSet:=K*2+30;
   End;
 5:Begin // ICON
    X:=22;//数据是从ICO文件的22处开始的
    FLen:=FLen-X;
    OffSet:=$00000020;
   End;
End;

M1.Lines.Add('正在加入资源:'+Fn+' 数据长度:'+IntToStr(FLen)+' 字节');

BlockWrite(FOut,FLen,4);  //写入数据长度

BlockWrite(FOut,OffSet,4); //写入相对偏移

Case Idx of
 3:Begin
    B1[0]:=$FF;
    B1[1]:=$FF;
    B1[2]:=$0A;
    B1[3]:=$00;
    BlockWrite(FOut,B1[0],4); //写入类型值
   End;

 4:Begin
    B1[0]:=$FF;
    B1[1]:=$FF;
    B1[2]:=$02;
    B1[3]:=$00;
    BlockWrite(FOut,B1[0],4); //写入类型值
   End;

 5:Begin
    BlockWrite(FOut,ICOType,8);//写入ICO类型值
    BlockWrite(FOut,ICO16Dat,16);//写入30H~3FH处数据

    Seek(FIn,X);
     For I:=0 To FLen-1 do //写入ICO文件数据
      Begin
        Read(FIn,B);
        Write(FOut,B);
      End;
     BlockWrite(FOut,ICOEnd1,4);
     if K and $1=$1 Then M:=32+(K-1)*2 Else M:=32+K*2;
     BlockWrite(FOut,M,4);//相对偏移值(ICOEnd2)
     BlockWrite(FOut,ICOEnd3,4);

      For N:=0 To K-1 do //类型名转为UnCode
       Begin
          B:=Ord(S2[N+1]);
          Write(FOut,B);
          B:=0;
          Write(FOut,B);
       End;
       B:=0;
       For N:=1 To M-24-K*2 Do Write(FOut,B);//补0
       
      BlockWrite(FOut,ICOEnd5,26);
      BlockWrite(FOut,FLen,4);//写入数据长度
      BlockWrite(FOut,ICOEnd,2);//
      CloseFile(FIn);
      Inc(Cnt);
      Continue;
   End;

  0,1,2:Begin
      For I:=0 To N-1 do //类型名转为UnCode
       Begin
        B:=Ord(S1[I+1]);
        Write(FOut,B);
        B:=0;
        Write(FOut,B);
       End;

        B:=0;
        Write(FOut,B);
        Write(FOut,B);

        End;
End;

For I:=0 To K-1 do //资源名转为UnCode
Begin
B:=Ord(S2[I+1]);
Write(FOut,B);
B:=0;
Write(FOut,B);
End;

BlockWrite(FOut,DataSpac,18);//间隔

Seek(FIn,X);
For I:=0 To FLen-1 do
Begin
Read(FIn,B);
Write(FOut,B);
End;

K:=FLen Mod 4;

if K<>0 Then
  For N:=1 To 4-K do
    Begin
     B:=0;
     Write(FOut,B);
    End;

CloseFile(FIn);
Inc(Cnt);
End;

CloseFile(FOut);
M1.Lines.Add(#13#10'******************************************************************'#13#10);
if Cnt>0 Then
Begin
M1.Lines.Add('编译完成,共编译了 '+IntToStr(Cnt)+' 个资源');
ShowMessage('编译完成');
End Else
Begin
M1.SelAttributes.Color:=clRed;
M1.SelAttributes.Style:=[fsItalic];
M1.Lines.Add(#13#10'没有任何资源被编译!');
M1.SelAttributes.Color:=M1.Font.Color;
M1.SelAttributes.Style:=[];
DeleteFile(EdFn.Text);
End;

end;

procedure TForm1.StrG1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
Var S:String;
    H:Integer;
    R:TRect;
    C,Fc:TColor;
    AJ:Word;
Begin
 inherited;
R:=Rect;
S:=UpperCase(StrG1.Cells[ACol,ARow]);
H:=StrG1.Canvas.TextHeight(S);
C:=StrG1.Canvas.Brush.Color;
Fc:=StrG1.Font.Color;

 R.Top:=R.Top+((Rect.Bottom-Rect.Top)-H) div 2;
 R.Bottom:=R.Top+H;

if StrG1.Cells[0,ARow]='-' Then
Begin
  StrG1.Canvas.Font.Color:=clRed;
  StrG1.Canvas.Font.Style:=StrG1.Canvas.Font.Style+[fsBold];
End;
if (ACol=3)and(ARow>0) Then AJ:=DT_LEFT Else AJ:=DT_CENTER;
  StrG1.Canvas.FillRect(Rect);
  DrawText(StrG1.Canvas.Handle,PChar(s),Length(s),R,AJ or DT_Word_EllIPSIS);

StrG1.Canvas.Brush.Color:=C;
StrG1.Canvas.Font.Style:=StrG1.Canvas.Font.Style-[fsBold];
StrG1.Canvas.Font.Color:=Fc;

End;

procedure TForm1.StrG1SelectCell(Sender: TObject; ACol, ARow: Integer;
  var CanSelect: Boolean);
var
   R:TRect;
  begin
      if ((ACol=2)and(ARow<>0))   then
      begin
          R        :=   StrG1.CellRect(ACol,ARow);
          R.Left   :=   R.Left   +  StrG1.Left;
          R.Right  :=   R.Right  +  StrG1.Left;
          R.Top    :=   R.Top    +  StrG1.Top;
          R.Bottom :=   R.Bottom +  StrG1.Top;

          with   CBox1   do
          begin
              Tag:=0;
              Left      :=   R.Left+1;
              Top       :=   R.Top +2;
              Width     :=   (R.Right+1)-R.Left;
              Height    :=   (R.Bottom+1)-R.Top;
              ItemIndex :=   Items.IndexOf(StrG1.Cells[ACol,ARow]);
              Visible   :=   True;
              SetFocus;
          end;
      end Else CBox1.Visible:=False;

      if ((ACol=3)and(ARow>0))   then
      begin
          R        :=   StrG1.CellRect(ACol,ARow);
          R.Left   :=   R.Left   +  StrG1.Left;
          R.Right  :=   R.Right  +  StrG1.Left;
          R.Top    :=   R.Top    +  StrG1.Top;
          R.Bottom :=   R.Bottom +  StrG1.Top;

          with   BWr   do
          begin
              Left      :=   R.Right-Width;
              Top       :=   R.Top +2;
              Height    :=   (R.Bottom+1)-R.Top-1;
              Visible   :=   True;
              SetFocus;
          end;
      end Else BWr.Visible:=False;

End;

procedure TForm1.CBox1Change(Sender: TObject);
var
R:Integer;
Begin
      inherited;
 With CBox1 do
  Begin
     R:=StrG1.Row;
     if (StrG1.Col=2) then
       StrG1.Cells[2,R]:=Items[ItemIndex]
     else
       StrG1.Cells[StrG1.Col,R]:=Items[ItemIndex];
   End;
End;

procedure TForm1.CBox1Exit(Sender: TObject);
begin
if CBox1.Tag=1 Then StrG1.Cells[2,StrG1.Row]:='';
CBox1.Visible:=False;
end;

procedure TForm1.BWrClick(Sender: TObject);
begin
OpenDlg.FileName:=StrG1.Cells[StrG1.Col,StrG1.Row];
if OpenDlg.Execute Then
Begin
 StrG1.Cells[StrG1.Col,StrG1.Row]:=OpenDlg.FileName;
End;
end;

procedure TForm1.BWrExit(Sender: TObject);
begin
BWr.Visible:=False;
end;

procedure TForm1.StrG1KeyPress(Sender: TObject; var Key: Char);
Var R:Integer;
    S,C1:String;
begin
 R:=StrG1.Row;
StrG1.Cells[0,R]:=IntToStr(R);
if (R=StrG1.RowCount-1)and(Key=#13) Then
Begin
StrG1.RowCount:=StrG1.RowCount+1;
StrG1.Row:=StrG1.Row+1;
StrG1.Cells[0,StrG1.Row]:=IntToStr(StrG1.Row);
Exit;
End;
C1:=StrG1.Cells[0,R];
StrG1.Cells[0,R]:='';
S:=Trim(StrG1.Rows[R].Text);
StrG1.Cells[0,R]:=C1;
if (S='')and(Key=#8) Then
Begin
if R>1 Then
  Begin
   StrG1.Row:=StrG1.Row-1;
   StrG1.RowCount:=StrG1.RowCount-1;
  End;
  Exit;
End;

end;

procedure TForm1.CBox1KeyPress(Sender: TObject; var Key: Char);
begin
if Key=#8 Then
Begin
 CBox1.Tag:=1;
 CBox1.ItemIndex:=-1;
End Else CBox1.Tag:=0;
end;

procedure TForm1.CBox1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
if Key=46 Then
Begin
 CBox1.Tag:=1;
 CBox1.ItemIndex:=-1;
End Else CBox1.Tag:=0;
end;

procedure TForm1.EdFnChange(Sender: TObject);
begin
B1.Enabled:=(EdFn.Text<>'');
end;

procedure TForm1.B3Click(Sender: TObject);
begin
SaveDlg.FileName:=EdFn.Text;
if SaveDlg.Execute Then
Begin
 EdFn.Text:=SaveDlg.FileName;
End;
end;

procedure TForm1.B2Click(Sender: TObject);
begin
Close;
end;

end.