umain.~pas

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

  sTxtStarHead: string = 'TPF0';
var
  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
        if (FileExists(lstBox.Items[index])) then
        begin
          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);
          msTmp.Clear;
          CodeCovAnsiTOGB(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;
        end;
      except
        lstFailBox.Items.Add(lstBox.Items[index]);
      end;
    end;
  finally
    FreeAndNil(msIn);
    FreeAndNil(msTmp);
  end;
end;

procedure TfrmMain.CodeCovAnsiTOGB(input, output: TMemoryStream; Findex:
  integer);
const
  sShowTrue = #13#10'您确定要进行转换吗?';
  sConst1 = 'Font.Name=''新宋体''';
var
  SaveSeparator: Char;
  Parser: TParser;
  iSize, iCurLine: integer;
  sTmp, sCovStr, sShowMsg: string;
  wsSrc, wsDest: WideString;
  SymList, slTmp: TStringList;
begin
  input.Seek(0, soFromBeginning);
  slTmp := TStringList.Create;
  slTmp.LoadFromStream(input);
  input.Seek(0, soFromBeginning);
  Parser := TParser.Create(input);
  SaveSeparator := DecimalSeparator;
  DecimalSeparator := '.';
  SymList := TStringList.Create;
  try
    iSize := input.Size;
    while ((Parser.SourcePos < iSize) and (Parser.Token <> toEof)) do
    begin
      if ((Parser.Token = toString) or (Parser.Token = toWString)) then
      begin
        wsSrc := Parser.TokenString;
        wsDest := Parser.TokenString;
        if (Parser.Token = toWString) then wsDest := QuotedStr(Parser.TokenWideString);
        if (SymList.Count >= 5) then SymList.Delete(0);
        SymList.Add(wsDest);
      end else
      begin
        wsSrc := Parser.TokenString;
        if (SymList.Count >= 5) then SymList.Delete(0);
        SymList.Add(wsSrc);
        sCovStr := GetLastString(SymList, 5);
        sShowMsg := sCovStr + sShowTrue;
        //改变字符集;
        if (
          miCovCharset.Checked and
          (Pos('Font.Charset=', sCovStr) >= 1) and
          (wsSrc = 'ANSI_CHARSET') and
          ((not miShowCovFont.Checked) or
          (Application.MessageBox(PChar(sShowMsg),
          '系统提示', MB_YESNO) = IDYES))
          ) then
        begin
          wsDest := 'GB2312_CHARSET';
          iCurLine := Parser.SourceLine;
          sTmp := slTmp.Strings[iCurLine - 1];
          sTmp := StringReplace(sTmp, 'ANSI_CHARSET', wsDest, []);
          slTmp.Strings[iCurLine - 1] := sTmp;
          //改变字号
        end;
      end;
      Parser.NextToken;
    end;
    output.Clear;
    slTmp.SaveToStream(output);
    output.Seek(0, soFromBeginning);
  finally
    DecimalSeparator := SaveSeparator;
    FreeAndNil(Parser);
    FreeAndNil(SymList);
    FreeAndNil(slTmp)
  end;
end;

procedure TfrmMain.CodeGetObjectDef(var input: TMemoryStream; output: TStrings;
  const SrcFileName: string);
var
  iSize, index: integer;
  SaveSeparator: Char;
  Token, LastToken: Char;
  Parser: TParser;
  FirstObject,FirstClass, LastClass,EventClass, CovClass: string;
  wsSrc, sSym, sTmp, sTmpClass, sTmpLists, sEventName, sEventFun: string;
  sFunParam: string;
  SymList, ObjDefList, ObjList,
    EventFunList, EventFunDefList, CodeList,
    ClassStatck, UserUnitList, sTestList: TStringList;
begin
  input.Seek(0, soFromBeginning);
  Parser := TParser.Create(input);
  SaveSeparator := DecimalSeparator;
  DecimalSeparator := '.';
  SymList := TStringList.Create;
  EventFunList := TStringList.Create;
  EventFunDefList := TStringList.Create;
  CodeList := TStringList.Create;
  ClassStatck := TStringList.Create;
  ObjDefList := TStringList.Create;
  ObjList := TStringList.Create;
  UserUnitList := TStringList.Create;
  sTestList := TStringList.Create;
  FirstObject := '';
  FirstClass := '';  
  try
    try
      iSize := input.Size;
      while ((Parser.SourcePos < iSize) and (Parser.Token <> toEof)) do
      begin
        wsSrc := Parser.TokenString;
        if (SymList.Count >= 4) then SymList.Delete(0);
        SymList.AddObject(wsSrc, TObject(Parser.Token));
        Token := Char(SymList.Objects[0]);
        //该类的对象定义;
        sSym := SymList.Strings[0];
        if (
          (SymList.Count = 4) and (Token = toSymbol) and
          ((Pos(UpperCase('object'), UpperCase(SymList.Strings[0])) >= 1) or
          (Pos(UpperCase('inherited'), UpperCase(SymList.Strings[0])) >= 1))
          ) then
        begin
          if (FirstObject <> '') then
            if HasCovClass(AdoQryClass, SymList.Strings[3], CovClass, UserUnitList) then
            begin
              sTmp := #09#09 + SymList.Strings[1] + ':' + CovClass + ';';
              ObjList.Add(sTmp);
            end else
            begin
              sTmp := #09#09 + SymList.Strings[1] + ':' + SymList.Strings[3] + ';';
              ObjList.Add(sTmp);
            end
          else
          begin
           FirstObject:=SymList.Strings[1];
           FirstClass:=SymList.Strings[3];
          end;
        end;
        sTmpClass := SymList.Text;
        sTmpLists := ClassStatck.Text;
        {LastClass 该代码段检查并设置当前类}
        //如果(符号为"object"且完成一个完整的对象定义)或者(符合为"<")则进栈,并看是否要更新当前类;
        Token := Char(SymList.Objects[0]);
        LastToken := #0;
        if (SymList.Count > 0) then LastToken := Char(SymList.Objects[SymList.Count - 1]);
        //if ((SymList.Count > 0) and (SymList.Strings[SymList.Count - 1] = '<')) then
        //showmessage(SymList.Strings[SymList.Count - 1]);
        //wsSrc := Parser.TokenString;        
        if (
          ((SymList.Count = 4) and (Token = toSymbol) and
          ((Pos(UpperCase('object'), UpperCase(SymList.Strings[0])) >= 1) or
          (Pos(UpperCase('inherited'), UpperCase(SymList.Strings[0])) >= 1))
          ) or
          ((SymList.Count > 0) and (LastToken = '<') and (SymList.Strings[SymList.Count - 1] = '<'))
          ) then
        begin
          if ((Pos(UpperCase('object'), UpperCase(SymList.Strings[0])) >= 1) or
            (Pos(UpperCase('inherited'), UpperCase(SymList.Strings[0])) >= 1)) then
            sTmp := SymList.Strings[3]
          else
            sTmp := SymList.Strings[SymList.Count - 1];
          ClassStatck.Add(sTmp);
          //sTestList.Add(StringReplace(ClassStatck.Text, #13#10, ',', [rfReplaceAll]));
          if (sTmp <> '<') then LastClass := sTmp;
        end;
        //如果(符号为"end"且不是在"<"内)或者(符合为">")则出栈,并看是否要更新当前类;
        LastToken := #0;
        if (SymList.Count > 0) then LastToken := Char(SymList.Objects[SymList.Count - 1]);
        if ((SymList.Count > 0) and
           (((LastToken = toSymbol)
              and(SymList.Strings[SymList.Count - 1] = 'end') and (ClassStatck.Count>0)
              and (ClassStatck.Strings[ClassStatck.Count - 1] <> '<'))
              or ((LastToken='>') and (SymList.Strings[SymList.Count - 1] = '>'))
           )
          ) then
        begin
          if (ClassStatck.Count > 0) then ClassStatck.Delete(ClassStatck.Count - 1);
          //sTestList.Add(StringReplace(ClassStatck.Text, #13#10, ',', [rfReplaceAll]));
          if ((ClassStatck.Count > 0) and (ClassStatck.Strings[ClassStatck.Count - 1] <> '<')) then
            LastClass := ClassStatck.Strings[ClassStatck.Count - 1];
        end; 
        {LastClass 结束}
        //
        {添加定义}
        //根据设置提示是否增加类事件定义,判断是事件的依据为前两个字母为"On"
        index := SymList.Count - 1;
        sSym := ''; if (index >= 0) then sSym := SymList.Strings[0];
        EventClass:=LastClass;
        if (LastClass=FirstClass) then EventClass:='TForm';
        if (
          (miUnknowEvent.Checked) and
          (SymList.Count > 0) and (Token = toSymbol) and
          (ClassStatck.Count > 0) and (ClassStatck.Strings[ClassStatck.Count - 1] <> '<') and
          (Length(sSym) >= 6) and (AnsiStartsStr('On', sSym)) and
          (not HasEvent(AdoQryEvent, EventClass, sSym, sFunParam)) and
          (Application.MessageBox(PAnsiChar('您确定要增加类'+EventClass+':'+sSym+'事件定义吗?'), '系统提示', MB_YESNO) = IDYES)
          ) then
        begin
          AddEvent(Adoqry, EventClass, sSym, '(Sender:TObject)', True);
        end;
        //根据设置提示是否增加类定义,目的是为了对未知的类用功能相近的类来代替
        if ((miUnKnowClass.Checked) and
          (SymList.Count = 4) and (Token = toSymbol) and
          ((Pos('object', SymList.Strings[0]) >= 1) or (Pos('inherited', SymList.Strings[0]) >= 1)) and
          (ClassStatck.Count > 0) and (ClassStatck.Strings[ClassStatck.Count - 1] <> '<') and
          (LastClass<>FirstClass) and
          (not HasCovClass(AdoQryClass, LastClass, LastClass, UserUnitList)) and
          (Application.MessageBox(PAnsiChar('您确定要增加类定义吗?'+LastClass+'定义吗?'), '系统提示', MB_YESNO) = IDYES)
          ) then
        begin
          AddCovClass(AdoQry, LastClass, LastClass, nil, True);
        end;
        {结束添加定义}
        //
        //增加事件处理函数的定义及空实现;
        sSym := '';
        if (SymList.Count > 0) then sSym := SymList.Strings[0];
        EventClass:=LastClass;
        if (LastClass=FirstClass) then EventClass:='TForm';        
        if (
          (SymList.Count = 4) and (Token = toSymbol) and
          (ClassStatck.Count > 0) and (ClassStatck.Strings[ClassStatck.Count - 1] <> '<') and
          (Length(sSym) >= 6) and (Pos('On', sSym) >= 1) and              
          (HasEvent(AdoQryEvent,EventClass, sSym, sFunParam))
          ) then
        begin
          sEventFun := Trim(SymList.Strings[2]);
          if (sSym='OnClose') then ShowMessage(sSym);
          if (not EventFunList.IndexOf(UpperCase(sEventFun)) >= 0) then
          begin
            EventFunList.Add(UpperCase(sEventFun));
            sTmp := #09#09 + 'procedure ' + sEventFun + sFunParam + ';';
            EventFunDefList.Add(sTmp);
            sTmp := 'procedure ' + FirstObject + '.' + sEventFun + sFunParam + ';'#13#10 +
              'begin'#13#10 +
              '  // TODO -cMM: default body'#13#10 +
              'end;'#13#10;
            CodeList.Add(sTmp);
          end;
        end;
        Application.ProcessMessages;
        Parser.NextToken;
      end;
      if (ObjList.Count > 0) then ObjList.Delete(0);
      Output.Clear;
      sTmp := Format('unit %s;'#13#10 + 'interface'#13#10 + 'uses'#13#10 +
        #9'Windows,Messages,SysUtils,StrUtils,Classes,Graphics,Controls,Forms;', [SrcFileName]);
      Output.Add(sTmp);
      //TfrmMain = class(TForm)
      sTmp := Format('Type'#13#10#9'%s=class(TForm)'#13#10, [FirstClass]);
      Output.Add(sTmp);
      Output.AddStrings(ObjList);
      Output.AddStrings(EventFunDefList);      
      sTmp := #9'public'#13#10#9#9'{ Public declarations }'#13#10#9'end;'#13#10#13#10;
      Output.Add(sTmp);
      sTmp :=Format( 'var'#13#10'%s:%s;'#13#10,[FirstObject,FirstClass]);
      Output.Add(sTmp);
      Output.Add('implementation'#13#10);
      Output.Add('{$R *.dfm}'#13#10);      
      Output.AddStrings(CodeList);
    finally
      DecimalSeparator := SaveSeparator;
      FreeAndNil(Parser);
      FreeAndNil(SymList);
      FreeAndNil(ObjDefList);
      FreeAndNil(ObjList);
      FreeAndNil(EventFunList);
      FreeAndNil(EventFunDefList);
      FreeAndNil(CodeList);
      FreeAndNil(ClassStatck);
      FreeAndNil(UserUnitList);
      //sTestList.SaveToFile('D:\DFM_BIGToGB\ClassText.txt');
      FreeAndNil(sTestList);
    end;
  except
    on E:Exception do begin  end;
  end;
end;

procedure TfrmMain.DFMPas1Click(Sender: TObject);
const
  sBinHead: string = #255#10#00;
  sTxtStarHead: Pchar = 'TPF0'#0;
  IsRun:Boolean=False;   
var
  //fsIn:TFileStream;
  msIn, msTmp: TMemoryStream;
  index, iCovType: Integer;
  sSrcTxt, sDestTxt, sSrcFileName, sHead: string;
  pcFirst: Integer;

  {fmCreate,fmOpenRead,fmOpenWrite,fmOpenReadWrite}
begin
  if IsRun then Exit;
  msIn := TMemoryStream.Create();
  msTmp := TMemoryStream.Create();
  lstFailBox.Clear;
  IsRun:=True;
  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);
        sSrcFileName:=ExtractFileName(lstBox.Items[index]);
        sSrcFileName:=ChangeFileExt(sSrcFileName,'');
        memDest.Clear;
        CodeGetObjectDef(msIn, MemDest.Lines, sSrcFileName);
        if ((not miShowTrue.Checked) or
          (Application.MessageBox('你是否确定要转换!',
          '系统提示', MB_YESNO) = IDYES)) then
        begin
          sSrcTxt := lstBox.Items[index];
          sDestTxt := sSrcTxt + '.Pas';
          memDest.lines.SaveToFile(sDestTxt);
        end;
      except
        lstFailBox.Items.Add(lstBox.Items[index]);
      end;
    end;
  finally
    FreeAndNil(msIn);
    FreeAndNil(msTmp);
    IsRun:=False;
  end;
end;

function TfrmMain.HasCovClass(var Query: TAdoQuery; ClassName: string; var
  CovClass: string; const UseUnit: TStringList): Boolean;
var
  sUseUnit: string;
  sSQL:String;
begin
  Result := False;
  if not Assigned(Query) then exit;
  sSQL:=ForMat('select * from ClassList where IsUse=True and UCase(ClassName)=Ucase(''%s'')',[ClassName]);
  ActiveSQL(Query,sSQL);
  if ((Query.Active) and (Query.RecordCount>0)) then
  try
    CovClass :=Query.FieldByName( 'CovClassName').AsString;
    sUseUnit := Query.FieldByName( 'UseUnit').AsString;;
    if Assigned(UseUnit) then
    begin
      UseUnit.Clear;
      UseUnit.Text := StringReplace(sUseUnit, ',', #13#10, [rfReplaceAll]);
    end;
    Result:=True;    
  except
  end;
end;

end.