passrc2.pas

BORLAND公司C语言对话框开发程序

{Substitutions and fills in file, skel.dat
  Area Fills
  @ZZ0    Form the dialog in constructor
  @ZZ1    Defined Control Names in Object Def.
  @ZZ2    Data record def
  @ZZ3    Load GetSubViewPtr
  @ZZ4    Store PutSubViewPtr

  Substitutions
  @XX0    Dialog's Pointer  (as  PMyDialog)
  @XX1    Dialog's Symbol   (as  TMyDialog)
  @XX2    Dialog's ancestor (usually TDialog)
  @XX3    Dialog's registration TStreamRec (as RMyDialog)
  @XX4    Unit name
  @XX5    'Control1'
  @XX6    uses clause items

}
{$A-,B-,E+,F-,G-,I+,N-,O-,P-,Q-,R-,S-,T-,V-,X+}
{$M 16384,5000,655360}

Program PasSrc2;

uses Dos, Objects, Drivers, Views, Dialogs,
     Editors, Validate, ReadScpt;

const
  NeedControl1 : boolean = False;
var
  OutF : Text;
  S : String;

PROCEDURE Subst(I : Integer);   {make a substitution for @XXn.  I is the
  location of @XXn in S }
var
  N : Byte;
  St : String;
  Name : NameStr;
  Ext : ExtStr;
begin
N := Ord(S[I+3]) - Ord('0');  {get the substitution number}
Delete(S, I, 4);              {delete the @XXn }
case N of
  0 : Insert(Dialog^.MainBlock.Obj^, S, I);  {like PMyDialog}
  1 : begin
      St := Dialog^.MainBlock.Obj^;
      if St[1] in ['P', 'p'] then Delete(St,1,1);
      Insert('T', St, 1);
      Insert(St, S, I);
      end;
  2 : Insert(Dialog^.MainBlock.BaseObj^, S, I);  {like TDialog}
  3 : begin
      St := Dialog^.MainBlock.Obj^;
      if St[1] in ['P', 'p'] then Delete(St,1,1);
      Insert('R', St, 1);
      Insert(St, S, I);
      end;
  4 : begin   {unit name same as filename}
      FSplit(ParamStr(2), St, Name, Ext);
      Insert(Name, S, I);
      end;
  5 : if NeedControl1 then Insert(', Control1', S, I);
  6 : begin
      St := '';
      if Present[CText] then St := ', ColorTxt';
      if Present[ILong] then St := St+', InpLong';
      if Present[Memo] then St := St+', Editors';
      if ValidatorPresent then St := St+', Validate';
      if St <> '' then Insert(St, S, I);
      end;
  end;
end;

function Positn(Pat, Src : String; I : Integer) : Integer;
{find the position of a substring in a string starting at the Ith char}
var
  N : Integer;
begin
if I < 1 then I := 1;
Delete(Src, 1, I-1);
N := Pos(Pat, Src);
if N = 0 then Positn := 0
  else Positn := N+I-1;
end;

FUNCTION Quoted(S : string) : string;
{If first char is '@' then removes the '@' and otherwise does nothing--
   assumes string is a variable name.
 else
   Puts single quotes around a string and doubles any internal single quotes}
var
  I : Integer;
begin
I := Pos('@', S);
if I = 1 then
  begin
  Quoted := Copy(S, 2, 255);
  Exit;
  end;
I := Pos('''', S);
while I > 0 do
  begin
  Insert('''', S, I);
  I := Positn('''', S, I+2);
  end;
Insert('''', S, 1);
Quoted := S+'''';
end;

procedure RDotAssign(P : PScriptRec);
begin
with P^.MainBlock do
  begin
  WriteLn(Outf, 'R.Assign(', X1, ', ', Y1, ', ', X2,', ', Y2, ');');
  end;
end;

procedure DoOpEvent(P : PScriptRec; const Sym : string);
var
  S : string;
begin
with P^.MainBlock do
  begin
  if DefOptns <> Optns then
    begin
    Write(Outf, Sym, '^.Options := ');
    S := OptionStr(Optns, DefOptns, GetOptionWords);
    if S[1] = '$' then
      WriteLn(OutF, S)
    else WriteLn(OutF, Sym, '^.Options', S);
    end;
  if DefEvMsk <> EvMsk then
    begin
    Write(Outf, Sym, '^.EventMask := ');
    S := OptionStr(EvMsk, DefEvMsk, GetEventWords);
    if S[1] = '$' then
      WriteLn(OutF, S)
    else WriteLn(OutF, Sym, '^.EventMask', S);
    end;
  end;
end;

(*--
procedure DoOpEvent(P : PScriptRec; const Sym : string);
begin
with P^.MainBlock do
  begin
  if DefOptns <> Optns then
    WriteLn(Outf, Sym, '^.Options := ', Sym, '^.Options',
                  OptionStr(Optns, DefOptns, GetOptionWords));
  if DefEvMsk <> EvMsk then
    WriteLn(Outf, Sym, '^.EventMask := ', Sym, '^.EventMask',
                  OptionStr(EvMsk, DefEvMsk, GetEventWords));
  end;
end;   ---*)

PROCEDURE WriteHelpCtx(Rf : PString; H : String; Ctx : word);
Const
  NoContext : String[11] = 'hcNoContext';
begin
if (H = '') and (Ctx > 0) then
   Str(Ctx, H);
if (H <> '') and not SameString(H, NoContext) then
  if Rf <> Nil then
    WriteLn(OutF, Rf^, '^.HelpCtx := ', H, ';' )
  else WriteLn(OutF, 'HelpCtx := ', H, ';' )
end;

procedure WriteButton(P : PScriptRec);
var
  S : string[55];

  function FlagStr : string;
  var
    S : string[55];
  begin
  with P^ do
    begin
    S := '';
    if Flags = 0 then S := 'bfNormal'
    else
      begin
      if Flags and 1 <> 0 then S := 'bfDefault+';
      if Flags and 2 <> 0 then S := S+'bfLeftJust+';
      if Flags and 4 <> 0 then S := S+'bfBroadcast+';
      if Flags and 8 <> 0 then S := S+'bfGrabFocus+';
      Dec(S[0]);  {remove extra '+'}
      end;
    end;
  FlagStr := S;
  end;

begin
with P^, MainBlock do
  begin
  RDotAssign(P);
  if SameString(Obj^, 'POptionButton') then  {a special TOptionButton}
    WriteLn(OutF, VarName^, ' := New(', Obj^, ', Init(R, ', Param[1]^,
         ', '+Param[2]^+'));' )
  else
    begin   {regular button}
    if CommandName^ <> '' then S := CommandName^
      else Str(CommandValue, S);
    Write(OutF, VarName^, ' := New(', Obj^, ', Init(R, ',
         Quoted(ButtonText^), ', '+S+', ' );
    WriteLn(OutF, FlagStr+'));' );
    end;
  WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  DoOpEvent(P, VarName^);
  WriteLn(OutF, 'Insert(', VarName^, ');');
  end;
end;

procedure WriteInputLong(P : PScriptRec);
begin
with P^, MainBlock do
  begin
  RDotAssign(P);
  WriteLn(OutF,
         VarName^, ' := New('+Obj^+', Init(R, ', LongStrLeng,
         ', ', LLim, ', ', ULim,  ', ', ILOptions, '));' );
  WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  DoOpEvent(P, VarName^);
  WriteLn(OutF, 'Insert(', VarName^, ');');
  end;
end;

procedure WriteInputLine(P : PScriptRec);
var
  S : string[15];

  function DoubleInsideQuotes(St : string) : string;
  var
    I : integer;
  begin
  I := Pos('''', St);
  while I > 0 do
    begin
    Insert('''', St, I);
    I := Positn('''', St, I+2);
    end;
  DoubleInsideQuotes := St;
  end;

begin
with P^, MainBlock do
  begin
  RDotAssign(P);
  WriteLn(OutF,
         VarName^, ' := New('+Obj^+', Init(R, ', StringLeng, '));' );
  WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  DoOpEvent(P, VarName^);
  WriteLn(OutF, 'Insert(', VarName^, ');');

  if ValKind in [Picture..StringLookup] then
    begin
    Write(OutF, '  ', Obj^+'('+VarName^+')^.Validator := New(', ValPtrName^,
        ', Init(');
    case ValKind of
      Picture:
         begin
         if AutoFill <> 0 then S := 'True' else S := 'False';
         {Note: PictureString may start with '@'}
         WriteLn(OutF, '''', DoubleInsideQuotes(PictureString^), ''', ', S, '));');
         end;
      Range:
         begin
         WriteLn(OutF, LowLim, ', ', UpLim, '));');
         if Transfer <> 0 then
           WriteLn(OutF, '  ',
               Obj^+'('+VarName^+')^.Validator^.Options := voTransfer;');
         end;
      Filter:
         WriteLn(OutF, CharSet^, '));');
      StringLookup:
         WriteLn(OutF, List^, '));');
      end;
    end;
  end;
end;

procedure WriteMemo(P : PScriptRec);
begin
with P^, MainBlock do
  begin
  RDotAssign(P);
  Write(OutF,
         VarName^, ' := New('+Obj^+', Init(R, ');
  if HScroll^ <> '' then
    Write(OutF, 'PScrollbar(Control1), ')
  else Write(OutF, 'Nil, ' );
  if VScroll^ <> '' then
    Write(OutF, 'PScrollbar(Control), ')
  else Write(OutF, 'Nil, ' );
  WriteLn(OutF, 'Nil, ', BufSize, '));');
  WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  DoOpEvent(P, VarName^);
  WriteLn(OutF, 'Insert(', VarName^, ');');
  end;
end;

procedure WriteListBox(P : PScriptRec);
begin
with P^, MainBlock do
  begin
  RDotAssign(P);
  Write(OutF,
         VarName^, ' := New('+Obj^+', Init(R, ', Columns);
  if Scrollbar^ <> '' then
    WriteLn(OutF, ', PScrollbar('+ScrollBar^+')));')
  else WriteLn(OutF, ', Nil));' );
  WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  DoOpEvent(P, VarName^);
  WriteLn(OutF, 'Insert(', VarName^, ');');
  end;
end;

procedure WriteScrollBar(P : PScriptRec);
begin
with P^, MainBlock do
  begin
  RDotAssign(P);
  WriteLn(OutF,
         VarName^, ' := New('+Obj^+', Init(R));');
  WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  DoOpEvent(P, VarName^);
  WriteLn(OutF, 'Insert(', VarName^, ');');
  end;
end;

procedure WriteCheckRadio(P : PScriptRec);
var
  I : integer;
begin
with P^, MainBlock do
  begin
  RDotAssign(P);
  Write(OutF,
         VarName^, ' := New('+Obj^+', Init(R, ');
  for I := 0 to Items-1 do
    Write(OutF, ^M^J'  NewSItem(', Quoted(PString(LabelColl^.At(I))^), ',');
  Write(OutF, ' Nil)');
  for I := 1 to Items -1 do
    Write(OutF, ')');
  if Kind = MultiCB then
    Write(OutF, ', ', SelRange, ', ', MCBFlags, ', ', Quoted(States^));
  WriteLn(OutF, '));');
  if Mask <> -1 then
    WriteLn(OutF, 'PCluster('+VarName^+')^.SetButtonState($', Hex8(not Mask), ', False);');
  WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  DoOpEvent(P, VarName^);
  WriteLn(OutF, 'Insert(', VarName^, ');');