umain.~pas

DELPHI DFM资源文件内码批量转换程序

  {fmCreate,fmOpenRead,fmOpenWrite,fmOpenReadWrite}
begin
  msIn := TMemoryStream.Create();
  msTmp := TMemoryStream.Create();
  lstFailBox.Clear;
  try
    for index := 0 to lstBox.Count - 1 do
    begin
      try
        msIn.LoadFromFile(lstBox.Items[index]);
        msIn.Seek(0, soFromBeginning);
        memSrc.Lines.LoadFromStream(msIn);
      //
        msIn.Seek(0, soFromBeginning);
      //
        if (not miNotCovert.Checked) then
        begin
          msTmp.Clear;
          if (miGBKSToT.Checked) then
            iCovType := 1
          else
            iCovType := 2;
          CodeConvert(msIn, msTmp, iCovType);
          msIn.Clear; msTmp.Seek(0, soFromBeginning);
          msIn.LoadFromStream(msTmp);
        end;
      //
        memDest.Clear;
        memDest.Lines.LoadFromStream(msIn);
        if ((not miShowTrue.Checked) or
          (Application.MessageBox('你是否确定要转换!',
          '系统提示', MB_YESNO) = IDYES)) then
        begin
          if (miToBak.Checked) then
          begin
            sSrcTxt := lstBox.Items[index];
            sDestTxt := sSrcTxt + '.Bak';
            CopyFile(PAnsiChar(sSrcTxt), PAnsiChar(sDestTxt), LongBool(0));
            msIn.SaveToFile(sSrcTxt);
          end else
          begin
            sSrcTxt := lstBox.Items[index];
            sDestTxt := sSrcTxt + '.New';
            msIn.SaveToFile(sDestTxt);
          end;
        end;
      except
        lstFailBox.Items.Add(lstBox.Items[index]);
      end;
    end;
  finally
    FreeAndNil(msIn);
    FreeAndNil(msTmp);
  end;
end;

procedure TfrmMain.FindFile(ASourceDir, AExtName: string);
var
  FileRec: TSearchrec;
  Sour, AExt: string;
begin
  Sour := ASourceDir;
  if (Sour[Length(Sour)] <> '\') then Sour := Sour + '\';
  {if not DirectoryExists(ASourceDir) then
  begin
    ShowMessage('来源目录不存在!!');
    exit;
  end;}
  {if not DirectoryExists(ADestDir) then
  begin
    ForceDirectories(ADestDir);
  end;}
  if FindFirst(Sour + '*.*', faAnyfile, FileRec) = 0 then
    repeat
      if ((FileRec.Attr and faDirectory) <> 0) then
      begin
        if (FileRec.Name <> '.') and (FileRec.Name <> '..') then
        begin
          FindFile(Sour + FileRec.Name, AExtName);
        end;
      end
      else
      begin
        AExt := ExtractFileExt(FileRec.Name);
        if (LowerCase(AExt) = AExtName) then
          lstBox.Items.Add(Sour + FileRec.Name);
      end;
    until FindNext(FileRec) <> 0;
  FindClose(FileRec);
end;

procedure TfrmMain.lstBoxDblClick(Sender: TObject);
begin
  OpenDialog.FilterIndex := 3;
  if (SaveDlg.Execute) then
  begin
    lstBox.Items.SaveToFile(SaveDlg.FileName);
  end;
end;

procedure TfrmMain.lstFailBoxDblClick(Sender: TObject);
begin
  if (SaveDlg.Execute) then
  begin
    lstFailBox.Items.SaveToFile(SaveDlg.FileName);
  end;
end;

procedure TfrmMain.tbModFontClick(Sender: TObject);
const
  sBinHead: string = #255#10#00;
  sTxtStarHead: string = 'TPF0';
var
  //fsIn:TFileStream;
  msIn, msTmp: TMemoryStream;
  index: Integer;
  sSrcTxt, sDestTxt, sHead: string;
  pcFirst: Integer;
  {fmCreate,fmOpenRead,fmOpenWrite,fmOpenReadWrite}
begin
  msIn := TMemoryStream.Create();
  msTmp := TMemoryStream.Create();
  lstFailBox.Clear;
  try
    for index := 0 to lstBox.Count - 1 do
    begin
      try
        msIn.Clear;
        msTmp.Clear;
        msIn.LoadFromFile(lstBox.Items[index]);
        msIn.Seek(0, soFromBeginning);
        SetLength(sHead, 51);
        msIn.Read(sHead[1], 50);
        if ((LeftBStr(sHead, 3) = sBinHead) and (miBinToText.Checked)) then
        begin
          msTmp.Clear;
          pcFirst := BStrPos(sHead, sTxtStarHead, 50, 4);
          if (pcFirst <> 0) then
          begin
            msIn.Position := pcFirst - 1;
            ObjectBinaryToText(msIn, msTmp);
            msIn.Clear; msTmp.Seek(0, soFromBeginning);
            msIn.LoadFromStream(msTmp);
          end else
          begin
            raise Exception.Create('二进制资源文件匹配错误！');
          end;
        end;
        ////
        msIn.Seek(0, soFromBeginning);
        memSrc.Lines.LoadFromStream(msIn);
        if (miNumToCode.Checked) then
        begin
          msTmp.Clear;
          CodeNumToStr(msIn, msTmp);
          msIn.Clear; msTmp.Seek(0, soFromBeginning);
          msIn.LoadFromStream(msTmp);
        end;
        msIn.Seek(0, soFromBeginning);
        memSrc.Lines.LoadFromStream(msIn);
        msTmp.Clear;
        CodeCovFont(msIn, msTmp, index);
        msIn.Clear; msTmp.Seek(0, soFromBeginning);
        msIn.LoadFromStream(msTmp);
        msIn.Seek(0, soFromBeginning);
        memDest.Clear;
        memDest.Lines.LoadFromStream(msIn);
        if ((not miShowTrue.Checked) or
          (Application.MessageBox('你是否确定要转换!',
          '系统提示', MB_YESNO) = IDYES)) then
        begin
          if (miToBak.Checked) then
          begin
            sSrcTxt := lstBox.Items[index];
            sDestTxt := sSrcTxt + '.Bak';
            CopyFile(PAnsiChar(sSrcTxt), PAnsiChar(sDestTxt), LongBool(0));
            msIn.SaveToFile(sSrcTxt);
          end else
          begin
            sSrcTxt := lstBox.Items[index];
            sDestTxt := sSrcTxt + '.New';
            msIn.SaveToFile(sDestTxt);
          end;
        end;
      except
        lstFailBox.Items.Add(lstBox.Items[index]);
      end;
    end;
  finally
    FreeAndNil(msIn);
    FreeAndNil(msTmp);
  end;
end;

procedure TfrmMain.MenuItem19Click(Sender: TObject);
begin
  if (SaveDlg.Execute) then
  begin
    lstBox.Items.SaveToFile(SaveDlg.FileName);
  end;
end;

procedure TfrmMain.MenuItem18Click(Sender: TObject);
begin
  OpenDialog.FilterIndex := 3;
  if (OpenDialog.Execute) then
  begin
    lstBox.Clear;
    lstBox.Items.LoadFromFile(OpenDialog.FileName);
  end;
end;

procedure TfrmMain.MenuItem1Click(Sender: TObject);
begin
  if (miSelPas.Checked) then
    OpenDialog.FilterIndex := 1
  else
    OpenDialog.FilterIndex := 2;
  if (OpenDialog.Execute) then
  begin
    lstBox.Clear;
    lstBox.Items.LoadFromFile(OpenDialog.FileName);
  end;
end;

procedure TfrmMain.CodeCovFont(input, output: TMemoryStream; Findex: integer);
const
  //GB2312_CHARSET 宋体
  sShowTrue = #13#10'您确定要进行转换吗?';
  sConst1 = 'Font.Name=''新宋体''';
  sConst12 = 'Font.Name=''MS Sans Serif''';
  sConst21 = 'Font.Charset=CHINESEBIG5_CHARSET';
  sConst22 = 'Font.Charset=DEFAULT_CHARSET';
  sConst31 = 'Font.Height=-11';
  sConst41 = 'ParentFont=False';
var
  SaveSeparator: Char;
  Parser: TParser;
  iSize, iSrcLen, iDestLen, FailCount, iLastHeight, iLastLine: integer;
  sTmp, sCovStr, sShowMsg: string;
  wsSrc, wsDest: WideString;
  SymList: TStringList;
begin
  input.Seek(0, soFromBeginning);
  output.LoadFromStream(input);
  input.Seek(0, soFromBeginning);
  Parser := TParser.Create(input);
  SaveSeparator := DecimalSeparator;
  DecimalSeparator := '.';
  SymList := TStringList.Create;
  try
    iSize := input.Size;
    FailCount := 0;
    iLastHeight := -13;
    iLastLine := 0;
    //miCovFont1 miCovFont2 miCovCharset miH11toH13 miCovToParent
    while ((Parser.SourcePos < iSize) and (Parser.Token <> toEof)) do
    begin
      if ((Parser.Token = toWString) or (Parser.Token = toString)) then
      begin
        wsSrc := QuotedStr(Parser.TokenString);
        wsDest := QuotedStr(Parser.TokenString);
        if (Parser.Token = toWString) then
          wsDest := QuotedStr(Parser.TokenWideString);
        if (SymList.Count >= 5) then SymList.Delete(0);
        SymList.Add(wsDest);
        sCovStr := GetLastString(SymList, 5);
        sShowMsg := sCovStr + sShowTrue;
        //改变字体为宋体
        if (miCovFont1.Checked and
          (AnsiStartsStr('Font.Name=', sCovStr)) and
          ((not miShowCovFont.Checked) or
          (Application.MessageBox(PChar(sShowMsg),
          '系统提示', MB_YESNO) = IDYES))
          ) then
        begin
          wsDest := '''宋体''';
          iSrcLen := CharToByteLen(wsSrc, Length(wsSrc));
          iDestLen := CharToByteLen(wsDest, length(wsDest));
          output.Position := Parser.SourcePos;
          if (iSrcLen >= iDestLen) then
          begin
            sTmp := wsDest + DupeString(' ', iSrcLen - iDestLen);
            output.Write(sTmp[1], charToByteLen(sTmp, Length(sTmp)));
          end else
          begin
            if (FailCount = 0) then
            begin
              Inc(FailCount);
              lstFailBox.Items.Add(lstBox.Items[FIndex]);
            end;
            lstFailBox.Items.Add(wsSrc);
          end;
        end;
      end else
      begin
        wsSrc := Parser.TokenString;
        wsDest := Parser.TokenString;
        if (SymList.Count >= 5) then SymList.Delete(0);
        SymList.Add(wsSrc);
        sCovStr := GetLastString(SymList, 5);
        sShowMsg := sCovStr + sShowTrue;
        //改变字符集;
        if (
          miCovCharset.Checked and
          (AnsiStartsStr('Font.Charset=', sCovStr)) and
          ((not miShowCovFont.Checked) or
          (Application.MessageBox(PChar(sShowMsg),
          '系统提示', MB_YESNO) = IDYES))
          ) then
        begin
          wsDest := 'GB2312_CHARSET';
          iSrcLen := CharToByteLen(wsSrc, Length(wsSrc));
          iDestLen := CharToByteLen(wsDest, length(wsDest));
          output.Position := Parser.SourcePos;
          if (iSrcLen >= iDestLen) then
          begin
            sTmp := wsDest + DupeString(' ', iSrcLen - iDestLen);
            output.Write(sTmp[1], charToByteLen(sTmp, Length(sTmp)));
          end else
          begin
            if (FailCount = 0) then
            begin
              Inc(FailCount);
              lstFailBox.Items.Add(lstBox.Items[FIndex]);
            end;
            lstFailBox.Items.Add(wsSrc);
          end;
        //改变字号
        end else if (
          miH11toH13.Checked and
          (AnsiStartsStr('Font.Height=', sCovStr)) and
          ((not miShowCovFont.Checked) or
          (Application.MessageBox(PChar(sShowMsg),
          '系统提示', MB_YESNO) = IDYES))
          ) then
        begin
          iLastHeight := StrToIntDef(wsSrc, -17);
          iLastLine := Parser.SourceLine;
          //小于16号字的字体转为宋体10号字; 字号越大数值越小;
          if (iLastHeight >= -16) then
          begin
            wsDest := '-13';
            iSrcLen := CharToByteLen(wsSrc, Length(wsSrc));
            iDestLen := CharToByteLen(wsDest, length(wsDest));
            output.Position := Parser.SourcePos;
            if (iSrcLen >= iDestLen) then
            begin
              sTmp := wsDest + DupeString(' ', iSrcLen - iDestLen);
              output.Write(sTmp[1], charToByteLen(sTmp, Length(sTmp)));
            end else
            begin
              if (FailCount = 0) then
              begin
                Inc(FailCount);
                lstFailBox.Items.Add(lstBox.Items[FIndex]);
              end;
              lstFailBox.Items.Add(wsSrc);
            end;
          end;
        end else
        begin
          sCovStr := GetLastString(SymList, 3);
          sShowMsg := sCovStr + sShowTrue;
          //如果先前的字体大小,小于16号,
          //正常情况下,一个组件的资源文件中Font.Height 与ParentFont属性不
          //则把ParentFont设置为True,所有字体属性与欠容器相同;
          if (miCovToParent.Checked and
            (AnsiStartsStr('ParentFont=False', sCovStr)) and
            (
            (Parser.SourceLine - iLastLine > 4) or
            ((iLastHeight >= -16) and (Parser.SourceLine - iLastLine <= 4))
            ) and
            ((not miShowCovFont.Checked) or
            (Application.MessageBox(PChar(sShowMsg),
            '系统提示', MB_YESNO) = IDYES))
            ) then
          begin
            wsDest := 'True';
            iSrcLen := CharToByteLen(wsSrc, Length(wsSrc));
            iDestLen := CharToByteLen(wsDest, length(wsDest));
            output.Position := Parser.SourcePos;
            if (iSrcLen >= iDestLen) then
            begin
              sTmp := wsDest + DupeString(' ', iSrcLen - iDestLen);
              output.Write(sTmp[1], charToByteLen(sTmp, Length(sTmp)));
            end else
            begin
              if (FailCount = 0) then
              begin
                Inc(FailCount);
                lstFailBox.Items.Add(lstBox.Items[FIndex]);
              end;
              lstFailBox.Items.Add(wsSrc);
            end;
          end;
        end;
      end;
      Parser.NextToken;
    end;
    output.Seek(0, soFromBeginning);
  finally
    DecimalSeparator := SaveSeparator;
    FreeAndNil(Parser);
    FreeAndNil(SymList);
  end;
end;

function TfrmMain.GetLastString(AStrList: TStringList; Count: Integer): string;
var
  index: Integer;
begin
  Result := '';
  if not Assigned(AStrList) then Exit;
  if (AStrList.Count < Count) then Exit;
  for index := AStrList.Count - Count to AStrList.Count - 1 do
    Result := Result + AStrList.Strings[index];
end;

procedure TfrmMain.tbModExtClick(Sender: TObject);
var
  index: Integer;
  sSrcTxt, sDestTxt: string;
begin
  lstFailBox.Clear;
  for index := 0 to lstBox.Count - 1 do
  begin
    try
      sSrcTxt := lstBox.Items[Index];
      if (LowerCase(ExtractFileExt(sSrcTxt)) = '.new') then
        sDestTxt := LeftStr(sSrcTxt, Length(sSrcTxt) - 4);
      if (FileExists(sDestTxt)) then
        if (not RenameFile(sDestTxt, sDestTxt + '.Bak')) then
          DeleteFile(sDestTxt);
      if (not RenameFile(sSrcTxt, sDestTxt)) then
        lstFailBox.Items.Add(lstBox.Items[index]);
    except
      lstFailBox.Items.Add(lstBox.Items[index]);
    end;
  end;
end;

procedure TfrmMain.tbAnsiToGBClick(Sender: TObject);
const
  sBinHead: string = #255#10#00;