unit ads_DFMToDlg;
{Copyright(c)2016 Advanced Delphi Systems
Richard Maley
Advanced Delphi Systems
12613 Maidens Bower Drive
Potomac, MD 20854 USA
phone 301-840-1554
dickmaley@advdelphisys.com
The code herein can be used or modified by anyone. Please retain references
to Richard Maley at Advanced Delphi Systems. If you make improvements to the
code please send your improvements to dickmaley@advdelphisys.com so that the
entire Delphi community can benefit. All comments are welcome.
}
(*
Description: ads_DFMToDlg.pas
This unit contains the function DFMToDlg which
converts a delphi form into a dialog function
with all of the underlying code in tact and fully
functional.
If the DFMToDlg is successful True is returned,
otherwise false is returned.
*)
(*UnitIndex Master Index Implementation Section Download UnitsDescription: ads_DFMToDlg.pas This unit contains the following routines.
DFMToDlg DFMToDlg_CreateTxtFile DFMToDlg_GenCreate DFMToDlg_LoadTxtFile DFMToDlg_Populate DFMToDlg_PrepPasFile DFMToDlg_PrepStrings ProcessGlyphs ProcessIcons ProcessImageLists
*) interface Uses Classes; Function DFMToDlg( ConvertExe : String;//The full path and file name of the Delphi Convert utility DFMFile : String;//The full path and file name of the DFM file NewUnitName : String;//The name of the unit that will be created DlgFunctionName : String;//The name of the Dialog function DlgFunctionParams : String;//Complete Dialog function arguments with brackets DlgFunctionBeforeShow : String;//Complete code to be inserted and run before the dialog is shown DlgFunctionReturnCode : String //Complete code to be inserted when modal result is mrOK ): Boolean; //Returns True if modalresult is mrOK, False otherwise implementation Uses ads_File, SysUtils, Windows, Dialogs, ads_Exception, ads_Strg; const UnitName = 'ads_DFMToDlg'; Type TDFMObjects = Array of Array Of String; Var ProcName : String; DFMObjects : TDFMObjects; //Unit Description UnitIndex Master Index
procedure ProcessImageLists(Var lst : TStringList);
Var
sgCompName: String;
sgTopLine : String;
inTopLine : Integer;
sgBotLine : String;
inBotLine : Integer;
inPos : Integer;
sgTemp : String;
sgUpper : String;
inCounter : Integer;
inBitmpTop: Integer;
inBitmpBot: Integer;
lstBefore : TStringList;
lstAfter : TStringList;
lstNew : TStringList;
Begin
sgTopLine := 'TImageList.Create(';
sgBotLine := '};';
inPos := Pos(sgTopLine,lst.Text);
If inPos = 0 Then Exit;
sgTopLine := UpperCase(sgTopLine);
inTopLine := -1;
inBotLine := -1;
inBitmpTop:= -1;
For inCounter := 0 To lst.count - 1 Do
Begin
sgTemp := lst[inCounter];
sgUpper := UpperCase(sgTemp);
inPos := Pos(sgTopLine,sgUpper);
If inPos = 0 Then Continue;
inTopLine:= inCounter;
Break;
End;
If inTopLine = -1 Then Exit;
sgBotLine := UpperCase(sgBotLine);
For inCounter := inTopLine To lst.count - 1 Do
Begin
sgTemp := lst[inCounter];
sgUpper := UpperCase(sgTemp);
inPos := Pos(sgBotLine,sgUpper);
If inPos = 0 Then Continue;
inBotLine:= inCounter;
Break;
End;
If inBotLine = -1 Then Exit;
inBotLine := inBotLine + 1;
sgCompName:= lst[inTopLine];
inPos := Pos(':=',sgCompName);
If inPos = 0 Then Exit;
sgCompName := Trim(Copy(sgCompName,1,inPos-1));
For inCounter := (inTopLine+1) To (inBotLine-1) Do
Begin
sgTemp := lst[inCounter];
sgUpper := UpperCase(sgTemp);
inPos := Pos('BITMAP',sgUpper);
If inPos = 0 Then Continue;
inBitmpTop:= inCounter;
Break;
End;
If inBitmpTop = -1 Then Exit;
inBitmpBot := inBotLine-1;
lstNew := TStringList.Create();
lstBefore := TStringList.Create();
lstAfter := TStringList.Create();
Try
lstNew.Clear;
lstNew.Add(lst[inTopLine]);
lstNew.Add(' StringToImageList_ads(');
lstNew.Add(' '+sgCompName+',');
lstNew.Add(' '+'''object ImageList: TImageList'''+'+#10#13+');
lstNew.Add(' '+''' Left = 25'''+'+#10#13+');
lstNew.Add(' '+''' Top = 25'''+'+#10#13+');
lstNew.Add(' '+''' Bitmap = '''+'+#123+#10#13+');
For inCounter := (inBitmpTop+1) To inBitmpBot Do
Begin
sgTemp := Trim(lst[inCounter]);
inPos := Pos('}',sgTemp);
If inPos = 0 Then
Begin
lstNew.Add(' '+''' '+sgTemp+'''+#10#13+');
End
Else
Begin
lstNew.Add(' '+''' '+Copy(sgTemp,1,Length(sgTemp)-2)+'''+#125+#10#13+');
Break;
End;
End;
lstNew.Add(' '+'''end'''+');');
lstBefore.Clear;
For inCounter := 0 To inTopLine-1 Do
Begin
lstBefore.Add(lst[inCounter]);
End;
lstAfter.Clear;
For inCounter := (inBotLine+1) To lst.Count-1 Do
Begin
lstAfter.Add(lst[inCounter]);
End;
lst.SetText(PChar(lstBefore.Text+lstNew.Text+lstAfter.Text));
Finally
lstNew .Free;
lstBefore.Free;
lstAfter .Free;
End;
End;
//Unit Description UnitIndex Master Index
procedure ProcessGlyphs(Var lst : TStringList);
Var
inPos : Integer;
sgTemp : String;
sgUpper : String;
inCounter : Integer;
inCount : Integer;
inStart : Integer;
inEnd : Integer;
inIndent : Integer;
sgSpaces : String;
sgIndent : String;
Begin
sgSpaces :=
' '+
' '+
' '+
' '+
' ';
For inCounter := 0 To lst.count - 1 Do
Begin
sgTemp := lst[inCounter];
sgUpper := UpperCase(sgTemp);
inPos := Pos('GLYPH.DATA',sgUpper);
If inPos = 0 Then Continue;
inIndent := inPos+2;
sgIndent := Copy(sgSpaces,1,inIndent);
lst[inCounter] := Copy(sgTemp,1,inPos-1)+
'StringToGlyph_ads(Glyph,'+''''+'object TBitmap_ads Bitmap.Data = {'+''''+'+';
inStart := inCounter+1;
inEnd := inCounter + 1000;
If inEnd > lst.Count - 1 Then inEnd := lst.Count - 1;
For inCount := inStart To inEnd Do
Begin
sgTemp := lst[inCount];
sgTemp := Trim(sgTemp);
sgUpper := UpperCase(sgTemp);
inPos := Pos('}',sgUpper);
If inPos = 0 Then
Begin
lst[inCount] := sgIndent+''''+' '+sgTemp+''''+'+';
End
Else
Begin
lst[inCount] := sgIndent+''''+' '+Copy(sgTemp,1,Length(sgTemp)-1)+'end'''+');';
Break;
End;
End;
End;
End;
//Unit Description UnitIndex Master Index
procedure ProcessIcons(Var lst : TStringList);
Var
inPos : Integer;
sgTemp : String;
sgUpper : String;
inCounter : Integer;
inCount : Integer;
inStart : Integer;
inEnd : Integer;
inIndent : Integer;
sgSpaces : String;
sgIndent : String;
Begin
sgSpaces :=
' '+
' '+
' '+
' '+
' ';
For inCounter := 0 To lst.count - 1 Do
Begin
sgTemp := lst[inCounter];
sgUpper := UpperCase(sgTemp);
inPos := Pos('ICON.DATA',sgUpper);
If inPos = 0 Then Continue;
inIndent := inPos+2;
sgIndent := Copy(sgSpaces,1,inIndent);
lst[inCounter] := Copy(sgTemp,1,inPos-1)+
'StringToIcon_ads(Icon,'+''''+'object TIcon_ads Icon.Data = {'+''''+'+';
inStart := inCounter+1;
inEnd := inCounter + 1000;
If inEnd > lst.Count - 1 Then inEnd := lst.Count - 1;
For inCount := inStart To inEnd Do
Begin
sgTemp := lst[inCount];
sgTemp := Trim(sgTemp);
sgUpper := UpperCase(sgTemp);
inPos := Pos('}',sgUpper);
If inPos = 0 Then
Begin
lst[inCount] := sgIndent+''''+' '+sgTemp+''''+'+';
End
Else
Begin
lst[inCount] := sgIndent+''''+' '+Copy(sgTemp,1,Length(sgTemp)-1)+'end'''+');';
Break;
End;
End;
End;
End;
//Unit Description UnitIndex Master Index
Function DFMToDlg_CreateTxtFile(ConvertUtility,FormFile : String): Boolean;
Var
sgTextFile : String;
sgExt : String;
Begin
Result := False;
ProcName := 'DFMToDlg_CreateTxtFile'; Try
sgExt := UpperCase(ExtractFileExt(FormFile));
If sgExt <> '.DFM' Then Exit;
sgTextFile := Copy(FormFile,1,Length(FormFile)-3)+'txt';
If FileExists(sgTextFile) Then DeleteFile(PChar(sgTextFile));
ExecuteNewProcess(
ConvertUtility+' "'+FormFile+'"', //FileName : String;
0 );//Visibility : integer):integer;
Sleep(2000);
Result := FileExists(sgTextFile);
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;
//Unit Description UnitIndex Master Index
Function DFMToDlg_LoadTxtFile(FormTextFile: String; lst: TStrings): String;
Var
lstTemp : TStringList;
Begin
Result := '';
ProcName := 'DFMToDlg_LoadTxtFile'; Try
If lst <> nil Then lst.Clear;
If Not FileExists(FormTextFile) Then Exit;
lstTemp := TStringList.Create();
Try
lstTemp.Clear;
lstTemp.LoadFromFile(FormTextFile);
Result := lstTemp.Text;
If lst <> nil Then lst.SetText(PChar(lstTemp.Text));
Finally
lstTemp.Free;
End;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;
//Unit Description UnitIndex Master Index
Function DFMToDlg_Populate(ObjOwner,ObjParent,Data : String;Var DFMObjects: TDFMObjects): Boolean;
Var
lst : TStringList;
sgObjName : String;
sgObjType : String;
sgObjOwner : String;
sgObjParent : String;
lstProp : TStringList;
sgProperties : String;
sgObjObjects : String;
sgTemp : String;
inObjStart : Integer;
inObjEnd : Integer;
inPropStart : Integer;
inPropEnd : Integer;
inChildStart : Integer;
inChildEnd : Integer;
inCounter : Integer;
inPos : Integer;
inArrayHigh : Integer;
Begin
Result := False;
ProcName := 'DFMToDlg_Populate'; Try
If Data = '' Then Exit;
lst := TStringList.Create();
lstProp := TStringList.Create();
Try
lst.Clear;
lst.SetText(PChar(Data));
While (lst.Text <> '') Or (lst.Count <> 0) Do
Begin
sgObjName := '';
sgObjType := '';
sgObjOwner := '';
sgObjParent := '';
sgObjObjects := '';
sgProperties := '';
inObjStart := -1;
inObjEnd := -1;
inPropStart := -1;
inPropEnd := -1;
inChildStart := -1;
inChildEnd := -1;
For inCounter := 0 To lst.Count - 1 Do
Begin
inPos := Pos('object ',lst[inCounter]);
If inPos = 1 Then
Begin
inObjStart := inCounter;
inPropStart:= inCounter + 1;
Break;
End;
End;
If inObjStart = -1 Then Exit;
For inCounter := inObjStart To lst.Count - 1 Do
Begin
inPos := Pos('end',lst[inCounter]);
If inPos = 1 Then
Begin
inObjEnd := inCounter;
inPropEnd:= inObjEnd - 1;
Break;
End;
End;
If inObjEnd = -1 Then Exit;
For inCounter := inPropStart To inObjEnd-1 Do
Begin
inPos := Pos('object ',lst[inCounter]);
If inPos = 3 Then
Begin
inChildStart := inCounter;
inChildEnd := inObjEnd-1;
inPropEnd := inChildStart-1;
Break;
End;
End;
lstProp.Clear;
For inCounter := inPropStart To inPropEnd Do
Begin
sgTemp := Trim(lst[inCounter]);
lstProp.Add(sgTemp);
End;
sgProperties:= lstProp.Text;
lstProp.Clear;
For inCounter := inChildStart To inChildEnd Do
Begin
If inChildStart = -1 Then Break;
If inChildEnd = -1 Then Break;
sgTemp := lst[inCounter];
sgTemp := Copy(sgTemp,3,Length(sgTemp)-2);
lstProp.Add(sgTemp);
End;
sgObjObjects:= lstProp.Text;
inPos := Pos(':',lst[inObjStart]);
sgObjName := Trim(Copy(lst[inObjStart],8,inPos-8));
sgObjType := Trim(Copy(lst[inObjStart],inPos+1,Length(lst[inObjStart])-inPos+1));
sgObjOwner := ObjOwner;
sgObjParent := ObjParent;
If DFMObjects = nil Then
Begin
inArrayHigh := -1;
End
Else
Begin
Try inArrayHigh := StrToInt(DFMObjects[0,0]); Except inArrayHigh := -1; End;
End;
If inArrayHigh < 0 Then
Begin
inArrayHigh := 1;
SetLength(DFMObjects,7,2);
DFMObjects[0,0] := '0';
DFMObjects[1,0] := 'OBJNAME';
DFMObjects[2,0] := 'OBJTYPE';
DFMObjects[3,0] := 'OBJOWNER';
DFMObjects[4,0] := 'OBJPARENT';
DFMObjects[5,0] := 'OBJPROPERTIES';
DFMObjects[6,0] := 'OBJCHILDREN';
DFMObjects[0,0 ] := IntToStr(inArrayHigh);
DFMObjects[0,inArrayHigh] := IntToStr(inArrayHigh);
DFMObjects[1,inArrayHigh] := sgObjName;
DFMObjects[2,inArrayHigh] := sgObjType;
DFMObjects[3,inArrayHigh] := sgObjOwner;
DFMObjects[4,inArrayHigh] := sgObjParent;
DFMObjects[5,inArrayHigh] := sgProperties;
DFMObjects[6,inArrayHigh] := sgObjObjects;
End
Else
Begin
inArrayHigh := inArrayHigh+1;
SetLength(DFMObjects,7,inArrayHigh+1);
DFMObjects[0,0 ] := IntToStr(inArrayHigh);
DFMObjects[0,inArrayHigh] := IntToStr(inArrayHigh);
DFMObjects[1,inArrayHigh] := sgObjName;
DFMObjects[2,inArrayHigh] := sgObjType;
DFMObjects[3,inArrayHigh] := sgObjOwner;
DFMObjects[4,inArrayHigh] := sgObjParent;
DFMObjects[5,inArrayHigh] := sgProperties;
DFMObjects[6,inArrayHigh] := sgObjObjects;
End;
For inCounter := inObjEnd DownTo inObjStart Do
Begin
lst.Delete(inCounter);
End;
For inCounter := lst.Count-1 DownTo 0 Do
Begin
sgTemp := lst[inCounter];
sgTemp := Trim(sgTemp);
If sgTemp = '' Then lst.Delete(inCounter);
End;
If ObjOwner = 'nil' Then sgObjOwner := sgObjName;
If sgObjObjects <> '' Then
DFMToDlg_Populate(
sgObjOwner , //ObjOwner,
sgObjName , //ObjParent,
sgObjObjects, //Data : String;
DFMObjects );//var DFMObjects: TDFMObjects): String;
End;
Result := True;
Finally
lst.Free;
lstProp.Free;
End;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;
//Unit Description UnitIndex Master Index
Function DFMToDlg_PrepStrings(Var lst: TStringList): String;
Var
inCounter : Integer;
inPos : Integer;
inStart : Integer;
inEnd : Integer;
lstTemp : TStringList;
inLoops : Integer;
sgTemp : String;
sgIndent : String;
Begin
Result := '';
ProcName := 'DFMToDlg_PrepStrings'; Try
//zzzsgIndent := ' ';
sgIndent := ' ';
lstTemp := TStringList.Create();
Try
inLoops := 1;
lstTemp.Clear;
While True Do
Begin
inStart := -1;
inEnd := -1;
For inCounter := 0 To (lst.Count - 1) Do
Begin
sgTemp := lst[inCounter];
inPos := Pos('STRINGS',UpperCase(sgTemp));
If inPos = 0 Then Continue;
inStart := inCounter;
Break;
End;
If inStart = -1 Then Exit;
For inCounter := inStart To (lst.Count - 1) Do
Begin
If inCounter = inStart Then Continue;
sgTemp := lst[inCounter];
inPos := Pos('=',sgTemp);
If inPos = 0 Then Continue;
inEnd := inCounter-1;
Break;
End;
If inEnd = -1 Then inEnd := lst.Count - 1;
For inCounter := inStart To inEnd Do
Begin
sgTemp := lst[inCounter];
sgTemp := Trim(sgTemp);
If Copy(sgTemp,Length(sgTemp),1) = '(' Then
sgTemp := Copy(sgTemp,1,Length(sgTemp)-1);
If Copy(sgTemp,Length(sgTemp),1) = ')' Then
sgTemp := Copy(sgTemp,1,Length(sgTemp)-1);
If inCounter = inStart Then
Begin
sgTemp := StringReplace(sgTemp,'=','',[rfReplaceAll]);
sgTemp := StringReplace(sgTemp,'.strings','',[rfIgnoreCase,rfReplaceAll]);
sgTemp := StringReplace(sgTemp,'(','',[rfReplaceAll]);
sgTemp := Trim(sgTemp);
lstTemp.Add(sgIndent+sgTemp+'.Clear;');
lstTemp.Add(sgIndent+'With '+sgTemp+' Do');
lstTemp.Add(sgIndent+'Begin');
End
Else
Begin
If inCounter = inEnd Then
Begin
lstTemp.Add(sgIndent+' '+'Try Add('+sgTemp+'); Except End;');
lstTemp.Add(sgIndent+'End;');
End
Else
Begin
lstTemp.Add(sgIndent+' '+' Try Add('+sgTemp+'); Except End;');
End;
End;
End;
Result := Result + lstTemp.Text;
For inCounter := inEnd DownTo inStart Do lst.Delete(inCounter);
Inc(inLoops);
If inLoops > 10 Then Break;
End;
Finally
lstTemp.Free;
End;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;
//Unit Description UnitIndex Master Index
Function DFMToDlg_PrepPasFile(PasFile: String): String;
Var
inPos : Integer;
lstTemp : TStringList;
sgTemp : String;
sgIndent : String;
inUsesStrt: Integer;
inUsesEnd : Integer;
inCounter : Integer;
sgUses : String;
sgUsesBef : String;
sgUsesAft : String;
Begin
Result := '';
ProcName := 'DFMToDlg_PrepPasFile'; Try
sgIndent := ' ';
sgUses := '';
If Not FileExists(PasFile) Then Exit;
lstTemp := TStringList.Create();
Try
lstTemp.LoadFromFile(PasFile);
sgTemp := lstTemp.Text;
inPos := Pos('interface',sgTemp);
If inPos > 0 Then
sgTemp := Copy(sgTemp,inPos+9,Length(sgTemp)-(inPos+9)+1);
sgTemp := StringReplace(sgTemp,'{$R *.DFM}','',[rfIgnoreCase,rfReplaceAll]);
sgTemp := StringReplace(sgTemp,'end.','',[rfIgnoreCase,rfReplaceAll]);
//sgTemp := StringReplace(sgTemp,'implementation','',[rfIgnoreCase,rfReplaceAll]);
inUsesStrt:= -1;
inUsesEnd := -1;
inPos := Pos('USES',UpperCase(sgTemp));
If inPos > 0 Then
Begin
sgUses := Copy(sgTemp,inPos+4,Length(sgTemp)-(inPos+4));
inUsesStrt := inPos;
End;
inPos := Pos(';',UpperCase(sgUses));
If (inPos > 0) And (inUsesStrt <> -1) Then
Begin
sgUses := Copy(sgUses,1,inPos-1);
inUsesEnd := inUsesStrt+inPos+4;
End;
If sgUses <> '' Then
Begin
sgUses := StringReplace(sgUses,#13,'',[rfReplaceAll]);
sgUses := StringReplace(sgUses,#10,'',[rfReplaceAll]);
sgUses := StringReplace(sgUses,' ','',[rfReplaceAll]);
sgUses := StringReplace(sgUses,',',','+#13,[rfReplaceAll]);
inPos := Pos('ADS_EXCEPTION',UpperCase(sgUses));
If inPos = 0 Then sgUses := 'ads_Exception,'+#13+sgUses;
inPos := Pos('ADS_GRAPHICSTRINGS',UpperCase(sgUses));
If inPos = 0 Then sgUses := 'ads_GraphicStrings,'+#13+sgUses;
lstTemp.SetText(PChar(sgUses));
For inCounter := 0 To lstTemp.Count -1 Do
Begin
lstTemp[inCounter] := ' '+lstTemp[inCounter];
End;
sgUses := lstTemp.Text;
sgUsesBef := Copy(sgTemp,1,inUsesStrt-1);
sgUsesAft := Copy(sgTemp,inUsesEnd,Length(sgTemp)-inUsesEnd);
sgTemp :=
sgUsesBef +
'Uses'+
#13+
sgUses+
' ;'+
#13+
#13+
'Var'+
#13+
' UnitName : String;'+
#13+
' ProcName : String;'+
#13+
sgUsesAft;
End;
lstTemp.SetText(PChar(sgTemp));
For inCounter := 0 To lstTemp.Count -1 Do
Begin
sgTemp := lstTemp[inCounter];
inPos := Pos('CLASS(',UpperCase(sgTemp));
If inPos <> 0 Then
Begin
lstTemp[inCounter] := Copy(sgTemp,1,inPos-1)+'Class(TScrollingWinControl)';
lstTemp.Insert(inCounter+1,' Public');
lstTemp.Insert(inCounter+2,' Constructor Create(AOwner: TComponent); Override;');
lstTemp.Insert(inCounter+3,' Destructor Destroy; Override;');
lstTemp.Insert(inCounter+4,' Public');
Break;
End;
End;
inUsesStrt := -1;
For inCounter := 0 To lstTemp.Count -1 Do
Begin
sgTemp := UpperCase(lstTemp[inCounter]);
inPos := Pos('IMPLEMENTATION',UpperCase(sgTemp));
If inPos <> 0 Then
Begin
inUsesStrt := inCounter;
Break;
End;
End;
If inUsesStrt <> -1 Then
Begin
inUsesEnd := -1;
For inCounter := inUsesStrt DownTo 0 Do
Begin
sgTemp := UpperCase(lstTemp[inCounter]);
inPos := Pos('END;',UpperCase(sgTemp));
If inPos <> 0 Then
Begin
inUsesEnd := inCounter;
Break;
End;
End;
If inUsesEnd <> -1 Then
Begin
For inCounter := inUsesStrt DownTo inUsesEnd+1 Do
Begin
lstTemp.Delete(inCounter);
End;
End;
End;
sgTemp := lstTemp.Text;
Result := sgTemp;
Finally
lstTemp.Free;
End;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;
//Unit Description UnitIndex Master Index
Function DFMToDlg_GenCreate(
Var DFMObjects : TDFMObjects;
PasFile : String;
NewUnitName : String;
DlgFunctionName : String;
DlgFunctionParams : String;//Complete Dialog function arguments with brackets
DlgFunctionBeforeShow : String;//Complete code to be inserted and run before the dialog is shown
DlgFunctionReturnCode : String //Complete code to be inserted when modal result is mrOK
): String;
Var
inCounter : Integer;
inFormCnt : Integer;
inProp : Integer;
inMax : Integer;
inPos : Integer;
inLen : Integer;
inLineNo : Integer;
inFldLen : Integer;
lst : TStringList;
lstProp : TStringList;
lstForm : TStringList;
inWidth : Integer;
sgTemp : String;
sgIndent : String;
sgFldName : String;
sgFldType : String;
inErr : Integer;
sgSemiColn : String;
sgFormName : String;
sgParent : String;
sgItemIndex: String;
sgStrings : String;
sgUnitName : String;
Begin
Result := ''; inErr := 0;
ProcName := 'DFMToDlg_GenCreate'; Try inErr := 1;
sgIndent := ' ';
sgUnitName := ExtractFileName(NewUnitName);
inPos := Pos('.',sgUnitName);
If inPos > 0 Then sgUnitName := Copy(sgUnitName,1,inPos-1);
sgUnitName := Trim(sgUnitName);
If sgUnitName = '' Then
Begin
sgUnitName := UnitName+'_test';
NewUnitName:= sgUnitName+'.pas';
End;
inMax := StrToInt(DFMObjects[0,0]);
lst := TStringList.Create();
lstProp := TStringList.Create();
lstForm := TStringList.Create();
Try
lstForm.Clear;
sgFormName := DFMObjects[1,1];
DlgFunctionName := Trim(DlgFunctionName);
If DlgFunctionName = '' Then DlgFunctionName := sgFormName+'_Dlg_ads';
lst.Clear;
lst.Add('unit '+sgUnitName+';');
lst.Add('{Copyright(c)'+FormatDateTime('yyyy',Now())+' Advanced Delphi Systems');
lst.Add('');
lst.Add(' Richard Maley');
lst.Add(' Advanced Delphi Systems');
lst.Add(' 12613 Maidens Bower Drive');
lst.Add(' Potomac, MD 20854 USA');
lst.Add(' phone 301-840-1554');
lst.Add(' maley@advdelphisys.com}');
lst.Add('');
lst.Add('(*');
lst.Add('Description: '+NewUnitName+'.pas');
lst.Add('');
lst.Add('This unit contains');
lst.Add('');
lst.Add('*)');
lst.Add('');
lst.Add('interface');
lst.Add('');
lst.Add('{!~'+DlgFunctionName+'');
lst.Add('');
lst.Add('}');
lst.Add('Function '+DlgFunctionName+DlgFunctionParams+': Boolean;');
lst.Add('');
lst.Add('implementation');
lst.SetText(PChar(lst.Text+DFMToDlg_PrepPasFile(PasFile)));;
lst.Add('Constructor T'+sgFormName+'.Create(AOwner: TComponent);'); inErr := 2;
lst.Add(' '+'Function IsControl(Obj: TObject): Boolean;');
lst.Add(' '+'Begin');
lst.Add(' '+' Result := (Obj is TControl);');
lst.Add(' '+'End;');
inWidth := 1;
For inCounter := 1 To inMax Do
Begin
sgTemp := DFMObjects[1,inCounter];
If Length(sgTemp) > inWidth Then inWidth := Length(sgTemp);
End;
lstProp.Clear;
lstProp.Clear;
lst.Add('Begin'); inErr := 4;
lst.Add(sgIndent+'ProcName := ''T'+sgFormName+'.Create'+'''; Try');
lst.Add(sgIndent+'inherited;');
lst.Add(sgIndent+'Self.Parent := TWincontrol(AOwner);');
inFldLen := 1; inErr := 5;
For inCounter := 1 To inMax Do
Begin
sgTemp := DFMObjects[5,inCounter];
lstProp.Clear;
lstProp.SetText(PChar(sgTemp));
For inProp := 0 To lstProp.Count - 1 Do
Begin
sgTemp := lstProp[inProp];
inPos := Pos('=',sgTemp);
If inPos > 0 Then sgTemp := Copy(sgTemp,1,inPos-1);
sgTemp := Trim(sgTemp);
inLen := Length(sgTemp);
If inLen > inFldLen Then inFldLen := inLen;
End;
End;
For inCounter := 1 To inMax Do
Begin
inLineNo := lst.Count - 1;
If inCounter = 1 Then
Begin
lst.Add(
sgIndent+
'Dialog'+
' := '+
'TForm'+
'.Create('+
'nil'+
');');
lst.Add(sgIndent+'Form := T'+sgFormName+'.Create(Dialog);');
lst.Add(sgIndent+'Form.Parent:= Dialog;');
lst.Add(sgIndent+'Form.Align := alClient;');
lst.Add(sgIndent+'With '+'Dialog'+' Do');
End
Else
Begin
lst.Add(
sgIndent+
DFMObjects[1,inCounter]+
' := '+
DFMObjects[2,inCounter]+
'.Create('+
'AOwner'+
');');
lst.Add(sgIndent+'With '+DFMObjects[1,inCounter]+' Do');
End; inErr := 7;
lst.Add(sgIndent+'Begin');
sgTemp := DFMObjects[4,inCounter];
If sgTemp <> 'nil' Then
Begin
If sgTemp = sgFormName Then
Begin
sgParent := 'Self';
End
Else
Begin
sgParent := sgTemp;
If UpperCase(DFMObjects[2,inCounter]) = 'TACTION' Then sgParent := '';
End;
If sgParent <> '' Then
Begin
If sgParent <> 'Self' Then
Begin
If UpperCase(DFMObjects[2,inCounter]) = 'TMENUITEM' Then
Begin
lst.Add(
sgIndent+
sgIndent+
sgParent+
'.Add('+
DFMObjects[1,inCounter]+
');');
End
Else
Begin
lst.Add(
sgIndent+
sgIndent+
StringPad(
'Parent' , //InputStr,
' ' , //FillChar: String;
inFldLen , //StrLen: Integer;
True )+//StrJustify: Boolean): String;
':= '+
sgParent+
';');
End;
End
Else
Begin
If UpperCase(DFMObjects[2,inCounter]) = 'TMENUITEM' Then
Begin
lst.Add(
sgIndent+
sgIndent+
sgParent+
'.Add('+
DFMObjects[1,inCounter]+
');');
End
Else
Begin
lst.Add(
sgIndent+
sgIndent+
'If IsControl('+DFMObjects[1,inCounter]+') Then');
lst.Add(
sgIndent+
sgIndent+
'Begin');
lst.Add(
sgIndent+
sgIndent+
sgIndent+
StringPad(
'Parent' , //InputStr,
' ' , //FillChar: String;
inFldLen-2 , //StrLen: Integer;
True )+//StrJustify: Boolean): String;
':= '+
sgParent+
';');
lst.Add(
sgIndent+
sgIndent+
'End;');
End;
End;
End;
End;
sgTemp := DFMObjects[5,inCounter];
lstProp.Clear;
lstProp.SetText(PChar(sgTemp)); inErr := 8;
sgItemIndex := '';
sgStrings := DFMToDlg_PrepStrings(lstProp);
For inProp := 0 To lstProp.Count - 1 Do
Begin
sgFldName := lstProp[inProp];
sgFldType := lstProp[inProp];
inPos := Pos('=',sgFldName);
If inPos > 0 Then
Begin
sgFldName := Copy(sgFldName,1,inPos-1);
sgFldType := Copy(sgFldType,inPos+1,Length(sgFldType)-inPos+1);
End;
sgFldName := Trim(sgFldName);
sgFldType := Trim(sgFldType);
If sgFldName = 'Font.Charset' Then Continue;
If sgFldName = 'TextHeight' Then Continue;
If sgFldName = 'ItemIndex' Then
Begin
sgItemIndex :=
sgIndent+
sgIndent+
StringPad(
sgFldName, //InputStr,
' ' , //FillChar: String;
inFldLen , //StrLen: Integer;
True )+//StrJustify: Boolean): String;
':= '+
sgFldType+
';';
Continue;
End;
If sgFldName = 'Action' Then
Begin
lst.Add(
sgIndent+
sgIndent+
'If '+
sgFldType+
'.ImageIndex <> -1 Then ImageList.GetBitmap('+sgFldType+'.ImageIndex,Bitmap);');
End;
Try sgTemp := UpperCase(Copy(sgFldName,1,2)); Except sgTemp := '' End;
If inPos = 0 Then
Begin
If (inProp = 0) Then
Begin
sgSemiColn := ';';
End
Else
Begin
If (inProp = (lstProp.Count - 1)) Then
Begin
sgSemiColn := ';';
End
Else
Begin
inPos := Pos(':=',lst[lst.Count-1]);
If inPos > 0 Then
lst[lst.Count-1] := StringReplace(lst[lst.Count-1],';','',[rfReplaceAll]);
sgTemp := lstProp[inProp+1];
inPos := Pos('=',sgTemp);
If inPos > 0 Then
sgSemiColn := ';'
Else
sgSemiColn := '';
End;
End;
lst.Add(
sgIndent+
sgIndent+
StringPad(
'' , //InputStr,
' ' , //FillChar: String;
inFldLen+3, //StrLen: Integer;
True )+//StrJustify: Boolean): String;
Trim(lstProp[inProp])+
sgSemiColn
);
End
Else
Begin
If sgTemp = 'ON' Then
Begin inErr := 81;
If inCounter = 1 Then
Begin
lst.Add(
sgIndent+
sgIndent+
StringPad(
sgFldName, //InputStr,
' ' , //FillChar: String;
inFldLen , //StrLen: Integer;
True )+//StrJustify: Boolean): String;
':= '+
'Form'+
'.'+
sgFldType+
';');
End
Else
Begin
lst.Add(
sgIndent+
sgIndent+
StringPad(
sgFldName, //InputStr,
' ' , //FillChar: String;
inFldLen , //StrLen: Integer;
True )+//StrJustify: Boolean): String;
':= '+
sgFldType+
';');
End;
End
Else
Begin inErr := 82;
lst.Add(
sgIndent+
sgIndent+
StringPad(
sgFldName, //InputStr,
' ' , //FillChar: String;
inFldLen , //StrLen: Integer;
True )+//StrJustify: Boolean): String;
':= '+
sgFldType+
';');
End;
End; inErr := 83;
End;
If sgStrings <> '' Then lst.SetText(PChar(lst.Text+sgStrings));
If sgItemIndex <> '' Then lst.Add(sgItemIndex);
lst.Add(sgIndent+'End;');
If inCounter = 1 Then
Begin
lstForm.Clear;
For inFormCnt := inLineNo+1 To (lst.Count - 1) Do
Begin
lstForm.Add(sgIndent+lst[inFormCnt]);
End;
For inFormCnt := (lst.Count - 1) DownTo (inLineNo+1) Do
Begin
lst.Delete(inFormCnt);
End;
End;
lst.Add('');
End;
lst.Add(sgIndent+'Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;');
lst.Add('End;'); inErr := 10;
ProcessGlyphs(lst);
ProcessImageLists(lst);
lst.Add('');
lst.Add('Destructor T'+sgFormName+'.Destroy;');
lst.Add('Begin');
lst.Add(sgIndent+'ProcName := ''T'+sgFormName+'.Destroy''; Try');
For inCounter := inMax DownTo 2 Do
Begin
lst.Add(sgIndent+StringPad(DFMObjects[1,inCounter],' ',inWidth,True)+'.Free;');
End;
lst.Add(sgIndent+'inherited Destroy;');
lst.Add(sgIndent+'Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;');
lst.Add('End;');
lst.Add('');
lst.Add('{!~'+DlgFunctionName+'');
lst.Add('');
lst.Add('}');
lst.Add('Function '+DlgFunctionName+DlgFunctionParams+': Boolean;');
lst.Add('Var');
lst.Add(sgIndent+'Dialog : TForm;');
lst.Add(sgIndent+'Form : T'+sgFormName+';');
lst.Add('Begin');
lst.Add(sgIndent+'Result := False;');
lst.Add(sgIndent+'Dialog := nil;');
lst.Add(sgIndent+'ProcName := '''+DlgFunctionName+'''; Try');
lst.Add(sgIndent+'Try');
lst.SetText(PChar(lst.Text+lstform.Text));
lst.Add('');
If Pos('FORMCREATE',UpperCase(lstform.Text)) <> 0 Then
lst.Add(sgIndent+sgIndent+'Form.FormCreate(Dialog);');
lst.SetText(PChar(lst.Text+DlgFunctionBeforeShow));
lst.Add(sgIndent+sgIndent+'Dialog.ShowModal;');
lst.Add(sgIndent+sgIndent+'If Dialog.ModalResult = mrOK Then');
lst.Add(sgIndent+sgIndent+'Begin');
lst.Add(sgIndent+sgIndent+sgIndent+'//Do Something here');
lst.Add(sgIndent+sgIndent+sgIndent+'Result := True;');
lst.SetText(PChar(lst.Text+DlgFunctionReturnCode));
lst.Add(sgIndent+sgIndent+'End;');
lst.Add(sgIndent+'Finally');
lst.Add(sgIndent+sgIndent+'Dialog.Free;');
lst.Add(sgIndent+'End;');
lst.Add(sgIndent+'Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;');
lst.Add('End;');
lst.Add('');
lst.Add('Initialization');
lst.Add(sgIndent+'UnitName := '''+sgUnitName+''';');
lst.Add(sgIndent+'ProcName := ''Unknown'';');
lst.Add('End.');
ProcessIcons(lst);
lst.SaveToFile(NewUnitName);
Result := lst.Text;
Finally
lst .Free;
lstProp.Free;
lstForm.Free;
End;
Except On E : Exception Do RaiseError(UnitName,ProcName+'_'+IntToStr(inErr),E); End;
End;
//Unit Description UnitIndex Master Index
Function DFMToDlg(
ConvertExe : String;//The full path and file name of the Delphi Convert utility
DFMFile : String;//The full path and file name of the DFM file
NewUnitName : String;//The name of the unit that will be created
DlgFunctionName : String;//The name of the Dialog function
DlgFunctionParams : String;//Complete Dialog function arguments with brackets
DlgFunctionBeforeShow : String;//Complete code to be inserted and run before the dialog is shown
DlgFunctionReturnCode : String //Complete code to be inserted when modal result is mrOK
): Boolean; //Returns True if modalresult is mrOK, False otherwise
Var
sgData : String;
sgPasFile : String;
sgTextFile : String;
sgRetval : String;
Begin
Result := False;
ProcName := 'DFMToDlg'; Try
sgTextFile := Copy(DFMFile,1,Length(DFMFile)-3)+'txt';
If Not FileExists(DFMFile) Then Exit;
CopyFile(PAnsiChar(DFMFile),PAnsiChar(sgTextFile),False);
sgPasFile := Copy(DFMFile,1,Length(DFMFile)-3)+'pas';
// If DFMToDlg_CreateTxtFile(ConvertExe,DFMFile) Then
// Begin
sgData := DFMToDlg_LoadTxtFile(sgTextFile,nil);
DFMToDlg_Populate('nil','nil',sgData,DFMObjects);
sgRetval :=
DFMToDlg_GenCreate(
DFMObjects ,//Var DFMObjects : TDFMObjects;
sgPasFile ,//PasFile : String;
NewUnitName ,//NewUnitName : String;
DlgFunctionName ,//DlgFunctionName : String;
DlgFunctionParams ,//DlgFunctionParams : String;//Complete Dialog function arguments with brackets
DlgFunctionBeforeShow,//DlgFunctionBeforeShow : String;//Complete code to be inserted and run before the dialog is shown
DlgFunctionReturnCode //DlgFunctionReturnCode : String //Complete code to be inserted when modal result is mrOK
);//): String;
Result := (sgRetval <> '');
// End;
Except On E : Exception Do RaiseError(UnitName,ProcName,E); End;
End;
Initialization
ProcName := 'ads_DFMToDlg';
end.
//