uresbuilder.pas

res可视化压缩

  Result := Result + #13#10 + Trim(Copy(sLine, Pos(' ', sLine) + 1, 1000));
end;

procedure TFrmResBuilder.ListViewItemMoveUpDown(lv: TListView; Item: TListItem;
  MoveUp, SetFocus: Boolean);
var 
  DestItem : TListItem; 
begin 
  if (Item = nil) or 
    ((Item.Index - 1 < 0) and MoveUp) or
    ((Item.Index + 1 >= lv.Items.Count) and (not MoveUp)) 
    then Exit; 
  lv.Items.BeginUpdate; 
  try 
    if MoveUp then 
      DestItem := lv.Items.Insert(Item.Index - 1) 
    else 
      DestItem := lv.Items.Insert(Item.Index + 2); 
    DestItem.Assign(Item); 
    lv.Selected := DestItem; 
    Item.Free; 
  finally 
    lv.Items.EndUpdate; 
  end; 
  if SetFocus then lv.SetFocus;
  DestItem.MakeVisible(False); 
end;

procedure TFrmResBuilder.ActDeleteExecute(Sender: TObject);
begin
  if Msgbox('您确实要删除该项吗？', '询问', True, 2) then
  begin
    DeleteListView(lvResources);
    edtResName.Text := '';
    edtFile.Text := '';
    cbResType.ItemIndex := 0;
  end;
  ActSaveALL.Enabled := True;
  ActCompile.Enabled := False;
  listViewToTreeView(lvResources, TvResources);
end;

procedure TFrmResBuilder.ActSaveALLExecute(Sender: TObject);
begin
  if lvResources.Items.Count <= 0 then
  begin
    Msgbox('还没有增加脚本，无法保存！');
    Exit;
  end;

  if PathName = DefaultFileName then
  begin
    SaveDialog.FileName := PathName;

    if SaveDialog.Execute then
    begin
      PathName := SaveDialog.FileName;
    end; //if

    if PathName = DefaultFileName then Exit else
    try
      //输出Rc脚本
      SaveListView(lvResources, PathName, '  ');
    except
      on E: Exception do
      begin
        Msgbox(E.Message, '错误');
      end;
    end; //try
  end
  else
  begin
    try
      //输出Rc脚本
      SaveListView(lvResources, PathName, '  ');
    except
      on E: Exception do
      begin
        Msgbox(E.Message, '错误');
      end;
    end; //try
  end;
  Caption := 'ResBuilder ' + GetBuildInfo + ' - ' + ExtractFileName(PathName);
  StatusBar1.Panels[0].Text := PathName;
  ActSaveALL.Enabled := False;
  ActSaveAs.Enabled := True;
  ActCompile.Enabled := True;
end;

procedure TFrmResBuilder.ActSaveAsExecute(Sender: TObject);
begin
 //
end;

procedure TFrmResBuilder.bClick(Sender: TObject);
begin
  if OpenDialog.Execute then
  begin
    edtFile.SetFocus;
    edtFile.Text := OpenDialog.FileName;
  end;
end;

procedure TFrmResBuilder.edtFileChange(Sender: TObject);
var
  Ext: string;
begin
  Ext := UpperCase(ExtractFileExt(edtFile.Text));
  with cbResType do
  begin
    if Ext = '' then
      ItemIndex := 0
    else if Ext = '.AVI' then
      ItemIndex := 1
    else if Ext = '.BMP' then
      ItemIndex := 2
    else if Ext = '.CUR' then
      ItemIndex := 3
    else if Ext = '.ICO' then
      ItemIndex := 4
    else if Ext = '.WAV' then
      ItemIndex := 5
    else
      ItemIndex := 6
  end;
end;

procedure TFrmResBuilder.edtFileEnter(Sender: TObject);
begin
  edtFile.OnChange := edtFileChange;
end;

procedure TFrmResBuilder.edtFileExit(Sender: TObject);
begin
  edtFile.OnChange := nil;
end;

procedure TFrmResBuilder.FormCreate(Sender: TObject);
var
  MyMenu: HMENU;
begin
  ActNewItems.Enabled := True;
  //添加系统菜单
  MyMenu := GetSystemMenu(Handle, false);
  AppendMenu(MyMenu, MF_SEPARATOR, 0, '');
  AppendMenu(MyMenu, MF_STRING, idHelp, '帮助');
  AppendMenu(MyMenu, MF_STRING, idAbout, '关于');
end;

procedure TFrmResBuilder.FormShow(Sender: TObject);
begin
  Self.Caption := 'ResBuilder ' + GetBuildInfo;

  if not FileExists(ExtractFilePath(Paramstr(0)) + 'brcc32.exe') then
  begin
    Msgbox('编译器文件不存在！请指定编译器！');
    aClick(Sender);
  end
  else
    edtResBrcc32.Text := ExtractFilePath(Paramstr(0)) + 'brcc32.exe';
  ActNewItemsExecute(Sender);

end;

function TFrmResBuilder.GetBuildInfo: string;
var
  VerInfoSize: DWORD;
  VerInfo: Pointer;
  VerValueSize: DWORD;
  VerValue: PVSFixedFileInfo;
  Dummy: DWORD;
  V1, V2, V3, V4: Word;
begin
  VerInfoSize := GetFileVersionInfoSize(PChar(ParamStr(0)), Dummy);
  if VerInfoSize = 0 then begin
    Dummy := GetLastError;
    Result := '0.0.0.0';
  end; {if}
  GetMem(VerInfo, VerInfoSize);
  GetFileVersionInfo(PChar(ParamStr(0)), 0, VerInfoSize, VerInfo);
  VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);
  with VerValue^ do
  begin
    V1 := dwFileVersionMS shr 16;
    V2 := dwFileVersionMS and $FFFF;
    V3 := dwFileVersionLS shr 16;
    V4 := dwFileVersionLS and $FFFF;
  end;
  Result := IntToStr(V1) + '.'
    + IntToStr(V2) + '.'
    + IntToStr(V3) + '.'
    + IntToStr(V4);
  FreeMem(VerInfo, VerInfoSize);
end;

procedure TFrmResBuilder.lvResourcesChange(Sender: TObject; Item: TListItem;
  Change: TItemChange);
begin
  lvResourcesClick(Sender);
end;

procedure TFrmResBuilder.lvResourcesClick(Sender: TObject);
begin
  if lvResources.ItemIndex = -1 then
  begin
    ActDelete.Enabled := False;
    ActModify.Enabled := False;
    Exit;
  end
  else
  begin
    ActDelete.Enabled := True;
    ActModify.Enabled := True;
  end;
  with lvResources.Selected do
  begin
    edtResName.Text := SubItems[0];

    with cbResType do
    begin
      if SubItems[1] = '' then
        ItemIndex := 0
      else if SubItems[1] = 'AVI' then
        ItemIndex := 1
      else if SubItems[1] = 'BITMAP' then
        ItemIndex := 2
      else if SubItems[1] = 'CURSOR' then
        ItemIndex := 3
      else if SubItems[1] = 'ICON' then
        ItemIndex := 4
      else if SubItems[1] = 'WAVE' then
        ItemIndex := 5
      else if SubItems[1] = 'RCDATA' then
        ItemIndex := 6
    end; //with

    edtFile.Text := SubItems[2];
  end;
end;

procedure TFrmResBuilder.lvResourcesCustomDrawItem(Sender: TCustomListView;
  Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
begin
  if item.Index mod 2 = 1 then
  begin
    sender.Canvas.Brush.Color := $00DEE7EF;
  end
  else
  begin
    sender.Canvas.Brush.Color := clwhite;
  end;
end;

procedure TFrmResBuilder.sbUpDownDownClick(Sender: TObject);
var
  I: Integer;
begin
  try
    I := StrToInt(edtResName.Text);
  except
    I := 0;
  end;
  edtResName.Text := IntToStr(I - 1);
end;

procedure TFrmResBuilder.sbUpDownUpClick(Sender: TObject);
var
  I: Integer;
begin
  try
    I := StrToInt(edtResName.Text);
  except
    I := 0;
  end;
  edtResName.Text := IntToStr(I + 1);
end;

procedure TFrmResBuilder.WMSysCommand(var Message: TWMSysCommand);
begin
  inherited;
  if Message.CmdType = idHelp then
    ActHelpContentsExecute(Self);
  if Message.CmdType = idAbout then
    Application.MessageBox('==   可视化Delphi资源编译器 1.1  == ' +
      #13#10#13#10#13#10 +
      ' 一个好用的可视化Delphi资源编译器软件' + #13#10 +
      ' For Windows 98/2K/XP/2003/Vista' + #13#10 +
      '  CodeGear RAD Studio 2007 编译 ' + #13#10#13#10 +
      ' 作者  : 焦国庆' + #13#10 +
      ' Email : [e-mail]' + #13#10
      , '关于');
end;

//------------------------------调用盒子的， 其他原创---------------------------

procedure TFrmResBuilder.RunDosInMemo(Que: string; EnMemo: TMemo);
const
  CUANTOBUFFER = 2000;
var
  Seguridades: TSecurityAttributes;
  PaLeer, PaEscribir: THandle;
  start: TStartUpInfo;
  ProcessInfo: TProcessInformation;
  Buffer: Pchar;
  BytesRead: DWord;
  CuandoSale: DWord;
begin
  with Seguridades do
  begin
    nlength := SizeOf(TSecurityAttributes);
    binherithandle := true;
    lpsecuritydescriptor := nil;
  end;
  {Creamos el pipe...}
  if Createpipe(PaLeer, PaEscribir, @Seguridades, 0) then
  begin
    Buffer := AllocMem(CUANTOBUFFER + 1);
    FillChar(Start, Sizeof(Start), #0);
    start.cb := SizeOf(start);
    start.hStdOutput := PaEscribir;
    start.hStdInput := PaLeer;
    start.dwFlags := STARTF_USESTDHANDLES +
      STARTF_USESHOWWINDOW;
    start.wShowWindow := SW_HIDE;

    if CreateProcess(nil,
      PChar(Que),
      @Seguridades,
      @Seguridades,
      true,
      NORMAL_PRIORITY_CLASS,
      nil,
      nil,
      start,
      ProcessInfo)
      then
    begin
        {Espera a que termine la ejecucion}
      repeat
        CuandoSale := WaitForSingleObject(ProcessInfo.hProcess, 100);
        Application.ProcessMessages;
      until (CuandoSale <> WAIT_TIMEOUT);
        {Leemos la Pipe}
      repeat
        BytesRead := 0;
        {Llenamos un troncho de la pipe, igual a nuestro buffer}
        ReadFile(PaLeer, Buffer[0], CUANTOBUFFER, BytesRead, nil);
        {La convertimos en una string terminada en cero}
        Buffer[BytesRead] := #0;
        {Convertimos caracteres DOS a ANSI}
        OemToAnsi(Buffer, Buffer);
        EnMemo.Text := EnMemo.text + string(Buffer);
      until (BytesRead < CUANTOBUFFER);
    end;
    FreeMem(Buffer);
    CloseHandle(ProcessInfo.hProcess);
    CloseHandle(ProcessInfo.hThread);
    CloseHandle(PaLeer);
    CloseHandle(PaEscribir);
  end;
end;

//---------------------------------Lv ※ TV-------------------------------------

procedure TFrmResBuilder.AppendListView(Statetype: Integer; ListView: TListView; ListColumn1,
  ListColumn2, ListColumn3: string);
var
  item: TListItem;
begin
  try
    ListView.Items.BeginUpdate;

    item := ListView.Items.Add;
    item.Caption := '';
    item.StateIndex := Statetype;

    item.SubItems.Add(ListColumn1);
    item.SubItems.Add(ListColumn2);
    item.SubItems.Add(ListColumn3);
    ListView.Refresh;
  finally
    ListView.Items.EndUpdate;
  end;
end;

procedure TFrmResBuilder.ModifyListView(Statetype: Integer; ListView: TListView;
  ListColumn1, ListColumn2, ListColumn3: string);
begin
  if ListView.ItemIndex <> -1 then
    with ListView.Selected do
    begin
      Caption := '';
      StateIndex := Statetype;
      SubItems[0] := ListColumn1;
      SubItems[1] := ListColumn2;
      SubItems[2] := ListColumn3;
    end;
end;

procedure TFrmResBuilder.DeleteListView(ListView: TListView);
begin
  if ListView.ItemIndex <> -1 then
    with ListView.Selected do
    begin
      ListView.DeleteSelected;
      ListView.ItemIndex := -1;
    end;
end;

function TFrmResBuilder.SaveListView(ListView: TListView; FileName,
  Devider: string): Boolean;
var
  sl: TStringList;
  i, j: Integer;
  item: TListItem;
  line: string;
begin
  Result := False;

  if ListView.Items.Count <> 0 then //在不为空的情况下
  begin
    sl := TStringList.Create;
    for i := 0 to ListView.Items.Count - 1 do
    begin
      item := ListView.Items.Item[i];
      line := item.Caption;
      for j := 0 to item.SubItems.Count - 1 do
      begin
        line := line + Devider + item.SubItems.Strings[j];
      end;
      sl.Add(line);
    end;

    try
      sl.SaveToFile(FileName);
      Result := True;
    finally
      sl.Free;
    end;
  end
  else
  begin
    Exit;
  end;
end;

//------------------------------------------------------------------------------

procedure TFrmResBuilder.listViewToTreeView(ListView: TListView;
  TreeView: TTreeView);
  function AddResToTV(aRootNode: TTreeNode;ResFlag, ResType: string;
    aImgIndex:Integer): Boolean;
  var
    tvNode: TTreeNode;
    iIndex: Integer;
  begin
    tvNode:=aRootNode.getFirstChild;
    while tvNode<>nil do
    begin
      if tvNode.Text = ResType then
        Break;
      tvNode := tvNode.GetNext;
    end;
    if tvNode = nil then
    begin
      tvNode := TreeView.Items.AddChild(aRootNode, ResType);
      tvNode.ImageIndex := aImgIndex;
      tvNode.SelectedIndex := aImgIndex;
    end;
    tvNode := TreeView.Items.AddChild(tvNode, ResFlag);
    tvNode.ImageIndex := 7;
    tvNode.SelectedIndex := 7;
  end;
var
  iCount: Integer;
  RootNode: TTreeNode;
begin
  if ListView.Items.Count > 0 then
  try
    TreeView.Items.BeginUpdate;
    TreeView.Items.Clear;
    RootNode := TvResources.Items.AddFirst(nil, DefaultFileName);
    RootNode.ImageIndex := 0;
    RootNode.SelectedIndex := 0;
    for iCount := 0 to lvResources.Items.Count - 1 do
    with ListView.Items.Item[iCount] do
    begin
      AddResToTV(RootNode, SubItems[0] , SubItems[1], StateIndex);
    end;

    TreeView.FullExpand;
    TreeView.Refresh;
  finally
    TreeView.Items.EndUpdate;
  end;
end;

//------------------------------------------------------------------------------

end.