home *** CD-ROM | disk | FTP | other *** search
/ Prima Shareware 3 / DuCom_Prima-Shareware-3_cd1.bin / PROGRAMO / PASCAL / JANUSW / VBXINFO.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1994-05-15  |  23.7 KB  |  806 lines
  1. { Program:   VbxInfo
  2.   Version:   1.00
  3.   Purpose:   program to extract information from VBX files
  4.   Uses:      BIVBX10.DLL from the BC4 package
  5.  
  6.   Developer: Peter Sawatzki (ps)
  7.              Buchenhof 3, D58091 Hagen, Germany
  8.  CompuServe: 100031,3002
  9.  
  10.   Date:     Author:
  11.   02/26/94  ps       written
  12.  
  13.   Copyright (c) 1994 Peter Sawatzki. All Rights Reserved.
  14. }
  15. Program VbxInfo;
  16. Uses
  17.   WinTypes,
  18.   WinProcs,
  19.   Strings,
  20.   Objects,
  21.   oWindows,
  22.   oDialogs,
  23.   oMemory,
  24.   CommDlg,
  25. {$IfDef Debug} Debug, {$EndIf}
  26.   Vbx;
  27. Const
  28.   VBXvalidation: tVbxValidation = cVbxValidation;
  29.  
  30. {-the collection part}
  31. Type
  32.   pPrefixEntry = ^tPrefixEntry;
  33.   tPrefixEntry = Record
  34.     ThePrefix,
  35.     TheSource: pChar
  36.   End;
  37.   pPrefixCollection = ^tPrefixCollection;
  38.   tPrefixCollection = Object(tSortedCollection)
  39.     Function KeyOf(Item: Pointer): Pointer; Virtual;
  40.     Function Compare(Key1, Key2: Pointer): Integer; Virtual;
  41.     Procedure FreeItem(Item: Pointer); Virtual;
  42.     Function GenerateNewPrefix (SrcName: pChar): pChar;
  43.     Function MakePrefix (NewPrefix: pChar; SrcName: pChar): Boolean;
  44.   End;
  45. Var
  46.   Prefix: pPrefixCollection;
  47.  
  48. Function tPrefixCollection.KeyOf(Item: Pointer): Pointer;
  49. Begin
  50.   KeyOf:= pPrefixEntry(Item)^.TheSource
  51. End;
  52.  
  53. Function tPrefixCollection.Compare(Key1, Key2: Pointer): Integer;
  54. Begin
  55.   Compare:= StrIComp(Key1, Key2)
  56. End;
  57.  
  58. Procedure tPrefixCollection.FreeItem(Item: Pointer);
  59. Begin
  60.   StrDispose(pPrefixEntry(Item)^.ThePrefix);
  61.   StrDispose(pPrefixEntry(Item)^.TheSource);
  62.   Dispose(pPrefixEntry(Item))
  63. End;
  64.  
  65. Function tPrefixCollection.GenerateNewPrefix (SrcName: pChar): pChar;
  66. Var
  67.   np: Array[0..100] Of Char;
  68.   p,dp: pChar;
  69.  
  70.   Function HasThisPrefix (Item: pPrefixEntry): Boolean; Far;
  71.   Begin
  72.     HasThisPrefix:= StrIComp(Item^.ThePrefix, np)=0
  73.   End;
  74. Begin
  75.   np[0]:= #0;
  76.   p:= SrcName; dp:= np;
  77.   While p[0]<>#0 Do Begin
  78.     If p[0] In ['A'..'Z'] Then Begin
  79.       dp[0]:= Char(Ord(p[0])+Ord('a')-Ord('A'));
  80.       Inc(dp); dp[0]:= #0;
  81.     End;
  82.     Inc(p)
  83.   End;
  84.   If StrLen(np)=0 Then
  85.     StrCopy(np, 'enum');
  86.   If FirstThat(@HasThisPrefix)<>Nil Then Begin
  87.     dp[0]:= '1'; dp[1]:= #0;
  88.     While FirstThat(@HasThisPrefix)<>Nil Do
  89.       Inc(dp[0])
  90.   End;
  91.   GenerateNewPrefix:= StrNew(np)
  92. End;
  93.  
  94. Function tPrefixCollection.MakePrefix (NewPrefix: pChar; SrcName: pChar): Boolean;
  95. Var
  96.   Index: Integer;
  97.   anEntry: pPrefixEntry;
  98. Begin
  99.   MakePrefix:= False;
  100.   If Search(SrcName, Index) Then {old prefix}
  101.     With pPrefixEntry(At(Index))^ Do
  102.       StrCopy(NewPrefix, ThePrefix)
  103.   Else Begin
  104.     anEntry:= New(pPrefixEntry);
  105.     anEntry^.TheSource:= StrNew(SrcName);
  106.     anEntry^.ThePrefix:= GenerateNewPrefix(SrcName);
  107.     Insert(anEntry);
  108.     StrCopy(NewPrefix, anEntry^.ThePrefix);
  109.     MakePrefix:= True
  110.   End
  111. End;
  112.  
  113. Const
  114.   cm_ConvertOne     = $100;
  115.   cm_ConvertSpecial = $101;
  116. Type
  117.   pInfoWindow = ^tInfoWindow;
  118.   tInfoWindow = Object(tWindow)
  119.     Constructor Init (aParent: pWindowsObject; aTitle: pChar);
  120.     Procedure SetupWindow; Virtual;
  121.     Function  GetFileName (aFn: pChar): pChar;
  122.     Function  GetPascalFileName (aFn: pChar): pChar;
  123.     Procedure cmConvertOne (Var Msg: tMessage); Virtual cm_First+cm_ConvertOne;
  124.     Procedure cmConvertSpecial (Var Msg: tMessage); Virtual cm_First+cm_ConvertSpecial;
  125.     Function GenerateInfo (aVBXName, aPascalname: pChar): Boolean;
  126.   End;
  127.  
  128. Constructor tInfoWindow.Init (aParent: pWindowsObject; aTitle: pChar);
  129. Begin
  130.   Inherited Init(aParent, aTitle);
  131.   Attr.Menu:= CreateMenu;
  132.   AppendMenu(Attr.Menu, mf_String, cm_ConvertOne, 'Convert!');
  133.   AppendMenu(Attr.Menu, mf_String, cm_ConvertSpecial, '(special)');
  134. End;
  135.  
  136. Procedure tInfoWindow.SetupWindow;
  137. Begin
  138.   Inherited SetupWindow;
  139.   {PostMessage(hWindow, wm_Command, cm_ConvertOne, 0)}
  140. End;
  141.  
  142. Function tInfoWindow.GetFileName (aFn: pChar): pChar;
  143. Var
  144.   OpenFN      : tOpenFileName;
  145.   Filter      : Array[0..100] Of Char;
  146.   StartDir,
  147.   FName,
  148.   FullFileName: Array[0..100] Of Char;
  149. Begin
  150.   GetFileName:= aFn;
  151.   StrCopy(FullFileName, '');
  152.  
  153.   GetWindowsDirectory(StartDir, SizeOf(StartDir));
  154.   StrCat(StartDir, '\system');
  155.  
  156.   FillChar(Filter, SizeOf(Filter), #0);  { Set up for double null at end }
  157.   StrCopy(Filter, 'VBX files (*.VBX)');
  158.   StrCopy(@Filter[StrLen(Filter)+1], '*.VBX');
  159.  
  160.   FillChar(OpenFN, SizeOf(TOpenFileName), #0);
  161.   With OpenFN Do Begin
  162.     hInstance     := System.hInstance;
  163.     hwndOwner     := hWindow;
  164.     lpstrDefExt   := 'VBX';
  165.     lpstrTitle    := 'Load VBX file';
  166.  
  167.     lpstrFile     := FullFileName;
  168.     lpstrFilter   := Filter;
  169.     lpstrFileTitle:= FName;
  170.     lpstrInitialDir:= StartDir;
  171.     flags         := ofn_FileMustExist Or ofn_HideReadOnly;
  172.     lStructSize   := SizeOf(tOpenFileName);
  173.     nFilterIndex  := 1;       {Index into Filter String in lpstrFilter}
  174.     nMaxFile      := SizeOf(FullFileName);
  175.   End;
  176.   If GetOpenFileName(OpenFN) Then
  177.     StrCopy(aFn, FullFileName)
  178.   Else
  179.     StrCopy(aFn, '')
  180. End;
  181.  
  182. Function tInfoWindow.GetPascalFileName (aFn: pChar): pChar;
  183. Var
  184.   OpenFN      : tOpenFileName;
  185.   Filter      : array[0..100] of Char;
  186.   FName,
  187.   FullFileName: array[0..100] Of Char;
  188. Begin
  189.   GetPascalFileName:= aFn;
  190.   StrCopy(FullFileName, aFn);
  191.  
  192.   FillChar(Filter, SizeOf(Filter), #0);  { Set up for double null at end }
  193.   StrCopy(Filter, 'Pascal units (*.PAS)');
  194.   StrCopy(@Filter[StrLen(Filter)+1], '*.PAS');
  195.  
  196.   FillChar(OpenFN, SizeOf(TOpenFileName), #0);
  197.   With OpenFN Do Begin
  198.     hInstance     := System.hInstance;
  199.     hwndOwner     := hWindow;
  200.     lpstrDefExt   := 'PAS';
  201.     lpstrTitle    := 'Save as Pascal unit';
  202.  
  203.     lpstrFile     := FullFileName;
  204.     lpstrFilter   := Filter;
  205.     lpstrFileTitle:= FName;
  206.     flags         := ofn_HideReadOnly;
  207.     lStructSize   := SizeOf(tOpenFileName);
  208.     nFilterIndex  := 1;       {Index into Filter String in lpstrFilter}
  209.     nMaxFile      := SizeOf(FullFileName);
  210.   End;
  211.   If GetSaveFileName(OpenFN) Then
  212.     StrCopy(aFn, FullFileName)
  213.   Else
  214.     StrCopy(aFn, '')
  215. End;
  216.  
  217. Function StrForceExtension (Dst, Src, Ext: pChar): pChar;
  218. Var
  219.   p: pChar;
  220. Begin
  221.   StrForceExtension:= StrCopy(Dst,Src);
  222.   p:= StrRScan(Dst, '.');
  223.   If Assigned(p) Then
  224.     p^:= #0;
  225.   StrCat(Dst,'.');
  226.   StrCat(Dst,Ext)
  227. End;
  228.  
  229. Procedure tInfoWindow.cmConvertOne (Var Msg: tMessage);
  230. Var
  231.   SrcName, DstName: Array[0..67] Of Char;
  232. Begin
  233.   If (StrLen(GetFileName(SrcName))>0)
  234.   And (StrLen(GetPascalFileName(StrForceExtension(DstName,SrcName,'Pas')))>0)
  235.   And GenerateInfo(SrcName, DstName) Then
  236.     MessageBox(hWindow,'Pascal unit generated successfully.','Information', mb_Ok)
  237. End;
  238.  
  239. Procedure tInfoWindow.cmConvertSpecial (Var Msg: tMessage);
  240. Var
  241.   Error: Boolean;
  242. Begin
  243.   If  GenerateInfo('D:\Win\System\ThreeD.Vbx', 'C:\Wrk\ThreeD.Pas')
  244.   And GenerateInfo('D:\Win\System\Spin.Vbx',   'C:\Wrk\Spin.Pas')
  245.   And GenerateInfo('D:\Win\System\Grid.Vbx',   'C:\Wrk\Grid.Pas')
  246.   And GenerateInfo('D:\Win\System\Gauge.Vbx',  'C:\Wrk\Gauge.Pas')
  247.   And GenerateInfo('D:\Win\System\MHTR200.Vbx',  'C:\Wrk\MHTr200.Pas')
  248.   And GenerateInfo('D:\Win\System\MListPP.Vbx',  'C:\Wrk\MListPP.Pas')
  249.   Then
  250.     MessageBox(hWindow,'all units generated successfully.','Information', mb_Ok)
  251. End;
  252.  
  253. Procedure Error (aMsg: pChar);
  254. Begin
  255.   MessageBox(0, aMsg, 'Error', mb_IconExclamation+mb_Ok)
  256. End;
  257.  
  258. Var
  259.   aBuf, BufPtr: pChar;
  260.   DstFile: File;
  261.  
  262. Procedure WriteBuf;
  263. Var
  264.   Wr, ToWr: Word;
  265. Begin
  266.   ToWr:= StrLen(aBuf);
  267.   BlockWrite(DstFile, aBuf[0], ToWr, Wr);
  268.   If Wr<ToWr Then Begin
  269.     MessageBox(0,'Can''t write to file.'#10'Disk full?','Fatal Error', mb_IconExclamation Or mb_Ok);
  270.     Halt(1)
  271.   End;
  272.   aBuf[0]:= #0;
  273.   BufPtr:= aBuf
  274. End;
  275.  
  276. Procedure CheckBuf;
  277. Begin
  278.   If Word(BufPtr)>40000 Then
  279.     WriteBuf
  280. End;
  281.  
  282. Type
  283.   pModelInfo = ^tModelInfo;
  284.   tModelInfo = Record
  285.     usVersion: Word;                { VB version used by control                    }
  286.     fl: LongInt;                    { Bitfield structure                            }
  287.     pctlproc: pointer;              { the control proc.                             }
  288.     fsClassStyle: Word;             { window class style                            }
  289.     flWndStyle: LongInt;            { default window style                          }
  290.     cbCtlExtra: Word;               { # bytes alloc'd for HCTL structure            }
  291.     idBmpPalette: Word;             { BITMAP id for tool palette                    }
  292.     npszDefCtlName: Word;           { offset of default control name prefix         }
  293.     npszClassName: Word;            { offset of Visual Basic class name             }
  294.     npszParentClassName: Word;      { offset of Parent window class if subclassed   }
  295.     npproplist: Word;               { offset of Property list                       }
  296.     npeventlist: Word;              { offset of Event list                          }
  297.     nDefProp: Byte;                 { index of default property                     }
  298.     nDefEvent: Byte;                { index of default event                        }
  299.     nValueProp: byte;
  300.     usControlVersion: word
  301.   End;
  302.  
  303.   pVbxClass = ^tVbxClass;
  304.   tVbxClass = Record
  305.     dummy: Array[0..5] Of Byte;
  306.     ModelInfo: pModelInfo
  307.   End;
  308.  
  309.   pPropInfo = ^tPropInfo;
  310.   tPropInfo = Record
  311.     npszName       : Word;
  312.     fl             : LongInt;
  313.     OffsetData     : Byte;
  314.     InfoData       : Byte;
  315.     DataDefault    : LongInt;
  316.     npszEnumList   : Word;
  317.     EnumMax        : Byte
  318.   End;
  319.  
  320.   pDumpControl = ^tDumpControl;
  321.   tDumpControl = Object(tVbxControl)
  322.     Model: pModelInfo;
  323.     VbxBaseName: Array[0..67] Of Char;
  324.     Constructor Init (aParent: pInfoWindow; aVbxName, aVbxClass: pChar;
  325.                       aModel: pModelInfo);
  326.     Function GetEventId (Dst: pChar; Index: Integer): pChar;
  327.     Function IsValidProp (Index: Integer): Boolean;
  328.     Procedure DumpEnums;
  329.     Procedure DumpDefaultData;
  330.     Procedure DumpPropProc (Definition: Boolean);
  331.     Procedure DumpObjectDefinition;
  332.     Procedure DumpObjectImplementation;
  333.   End;
  334.  
  335.   NumStr = Array[0..30] Of Char;
  336.  
  337.   Function L2Str (Dst: pChar; aLong: LongInt): pChar;
  338.   Begin
  339.     L2Str:= Dst;
  340.     Str(aLong, NumStr(Pointer(Dst)^))
  341.   End;
  342.  
  343.   Function HexStr (Dst: pChar; aByte: Byte): pChar;
  344.   Const
  345.     HC: Array[0..$F] Of Char = '0123456789ABCDEF';
  346.   Begin
  347.     HexStr:= Dst;
  348.     Dst[0]:= HC[aByte Shr 4];
  349.     Dst[1]:= HC[aByte And $F];
  350.     Dst[2]:= #0
  351.   End;
  352.  
  353.   Function Str2Id (Dst, Src: pChar): pChar;
  354.   Begin
  355.     Str2Id:= Dst;
  356.     While Src[0]<>#0 Do Begin
  357.       Dst[0]:= Src[0];
  358.       Case Src[0] Of
  359.         'a'..'z',
  360.         'A'..'Z',
  361.         '0'..'9',
  362.         '_':      Inc(Dst)
  363.       End;
  364.       Inc(Src)
  365.     End;
  366.     Dst[0]:= #0
  367.   End;
  368.  
  369. Function StrJustName (Dst, Src: pChar): pChar;
  370. Var
  371.   p: pChar;
  372. Begin
  373.   p:= StrRScan(Src,'\');
  374.   If Not Assigned(p) Then
  375.     p:= StrRScan(Src,':');
  376.   If Not Assigned(p) Then
  377.     p:= Src
  378.   Else
  379.     Inc(p);
  380.   StrJustName:= StrCopy(Dst, p)
  381. End;
  382.  
  383. Function StrPropType(Dst: pChar; aType: Integer): pChar;
  384. Begin
  385.   StrPropType:= Dst;
  386.   Case aType Of
  387.     PType_Long,
  388.     PType_XPos, PType_XSize,
  389.     PType_YPos, PType_YSize: StrCopy(Dst, 'LongInt');
  390.     PType_Color:   StrCopy(Dst, 'tColorRef');
  391.     PType_CString: StrCopy(Dst, 'hSz');
  392.     PType_BString: StrCopy(Dst, 'hLStr');
  393.     PType_Picture: StrCopy(Dst, 'hPic');
  394.     PType_Short:   StrCopy(Dst, 'Integer');
  395.     PType_Bool:    StrCopy(Dst, 'Bool');
  396.     PType_Real:    StrCopy(Dst, 'Single');
  397.     PType_Enum:    StrCopy(Dst, 'Byte');
  398.   Else
  399.     StrCopy(Dst, '<unknown>')
  400.   End;
  401. End;
  402.  
  403. Function StrPropTypeCast(Dst: pChar; aType: Integer): pChar;
  404. Begin
  405.   StrPropTypeCast:= Dst;
  406.   Case aType Of
  407.     PType_Long,
  408.     PType_XPos, PType_XSize,
  409.     PType_YPos, PType_YSize: StrCopy(Dst, '');
  410.     PType_Color:   StrCopy(Dst, 'LongInt');
  411.     PType_CString: StrCopy(Dst, '');
  412.     PType_BString: StrCopy(Dst, '');
  413.     PType_Picture: StrCopy(Dst, 'Integer');
  414.     PType_Short:   StrCopy(Dst, '');
  415.     PType_Bool:    StrCopy(Dst, 'Integer');
  416.     PType_Real:    StrCopy(Dst, '');
  417.     PType_Enum:    StrCopy(Dst, 'Byte');
  418.   Else
  419.     StrCopy(Dst, '')
  420.   End;
  421. End;
  422.  
  423. Function StrPropProcName(Dst: pChar; aType: Integer): pChar;
  424. Begin
  425.   StrPropProcName:= Dst;
  426.   Case aType Of
  427.     PType_Long,
  428.     PType_XPos, PType_XSize,
  429.     PType_YPos, PType_YSize: StrCopy(Dst, '');
  430.     PType_Color:   StrCopy(Dst, '');
  431.     PType_CString: StrCopy(Dst, 'Str');
  432.     PType_BString: StrCopy(Dst, 'BStr');
  433.     PType_Picture: StrCopy(Dst, 'Int');
  434.     PType_Short:   StrCopy(Dst, 'Int');
  435.     PType_Bool:    StrCopy(Dst, 'Int');
  436.     PType_Real:    StrCopy(Dst, 'Single');
  437.     PType_Enum:    StrCopy(Dst, 'Byte');
  438.   Else
  439.     StrCopy(Dst, '<unknown>')
  440.   End;
  441. End;
  442.  
  443. Function StrEventArgType (Dst: pChar; aType: Integer): pChar;
  444. Begin
  445.   StrEventArgType:= Dst;
  446.   Case aType Of
  447.     1: StrCopy(Dst,'Integer');
  448.     2: StrCopy(Dst,'LongInt');
  449.     3: StrCopy(Dst,'Single');
  450.     4: StrCopy(Dst,'Double');
  451.     5: StrCopy(Dst,'Double{Curr}');
  452.     6: StrCopy(Dst,'hLStr');
  453.     7: StrCopy(Dst,'hSz');
  454.   Else
  455.     StrCopy(Dst, '<unknown>')
  456.   End
  457. End;
  458.  
  459. Function MakeLp (aPointer: Pointer; Index: Word): Pointer;
  460. Inline($58/$5B/$5A); {Pop Ax Bx Dx}
  461.  
  462. Function VBReadFormFile (hForm: tHandle; Data: Pointer; cb: Word): Word;
  463. Inline($BB/$3C/$00/ $36/$FF/$1E/$20/$00); {Mov Bx,$3C; Call [SS:20]}
  464.  
  465. Function VBSeekFormFile (hForm: tHandle; Offset: LongInt): LongInt;
  466. Inline($BB/$A0/$00/ $36/$FF/$1E/$20/$00); {Mov Bx,$A0; Call [SS:20]}
  467.  
  468. Constructor tDumpControl.Init (aParent: pInfoWindow; aVbxName, aVbxClass: pChar;
  469.                                aModel: pModelInfo);
  470. Begin
  471.   Inherited Init (aParent, 0, aVbxName, aVbxClass, Nil, 0, 0, 0, 0, 0, Nil);
  472.   Model:= aModel;
  473.   StrJustName(VbxBaseName, aVbxName)
  474. End;
  475.  
  476. Function tDumpControl.GetEventId (Dst: pChar; Index: Integer): pChar;
  477. Begin
  478.   GetEventId:= Str2Id(Dst, GetEventName(Index))
  479. End;
  480.  
  481. Function tDumpControl.IsValidProp (Index: Integer): Boolean;
  482. Var
  483.   p: pPropInfo;
  484. Begin
  485.   p:= dVbx.VbxGetModelPropInfo(Model, Index);
  486.   IsValidProp:= Assigned(p) And (p^.npszName<>0) And (Word(MakeLp(p,p^.npszName)^)<>$0020)
  487. End;
  488.  
  489. Function StripJunk (Dst, Src: pChar): pChar;
  490. Begin
  491.   StripJunk:= Dst;
  492.   While Src[0]<>#0 Do Begin
  493.     Dst[0]:= Src[0];
  494.     Case Src[0] Of
  495.       'a'..'z',
  496.       'A'..'Z',
  497.       '_':      Inc(Dst)
  498.     End;
  499.     Inc(Src)
  500.   End;
  501.   Dst[0]:= #0
  502. End;
  503.  
  504. Procedure tDumpControl.DumpEnums;
  505. Var
  506.   pType: Integer;
  507.   p: pPropInfo;
  508.   el: pChar;
  509.   i,en: Integer;
  510.   aLine: Array[0..200] Of Char;
  511.   pref, ty, tmp: array[0..67] Of Char;
  512. Begin
  513.   For i:= 0 To GetNumProps-1 Do If IsValidProp(i) Then Begin
  514.     p:= dVbx.VbxGetModelPropInfo(Model, i);
  515.     pType:= GetPropType(i);
  516.     If pType=PType_Enum Then Begin
  517.       Str2Id(Ty, GetPropName(i));
  518.       If Prefix^.MakePrefix(pref, Ty) Then Begin
  519.         StrCat(StrCat(StrCopy(aLine,'  en'), Ty),' = (');
  520.         el:= MakeLp(p, p^.npszEnumList);
  521.         While el[0]<>#0 Do Begin
  522.           StrCat(StrCat(aLine, pref), StripJunk(Tmp, el));
  523.           el:= StrEnd(el)+1;
  524.           If el[0]<>#0 Then StrCat(aLine, ', ');
  525.           If (StrLen(aLine)>80) And (el[0]<>#0) Then Begin
  526.             BufPtr:= StrEnd(StrCat(StrCat(BufPtr, aLine),#13#10));
  527.             FillChar(aLine, StrLen(ty)+8,' ');
  528.             aLine[StrLen(ty)+8]:= #0
  529.           End;
  530.         End;
  531.         StrCat(aLine,');'#13#10);
  532.         BufPtr:= StrEnd(StrCat(BufPtr, aLine))
  533.       End
  534.     End
  535.   End
  536. End;
  537.  
  538. Procedure tDumpControl.DumpPropProc (Definition: Boolean);
  539. Const
  540.   PropFn: Array[Boolean] Of pChar = ('SetProp','GetProp');
  541.   PropArrayFn: Array[Boolean] Of pChar = ('SetArrayProp','GetArrayProp');
  542. Var
  543.   i: Integer;
  544.   pType: Integer;
  545.   Get: Boolean;
  546.   Ty,Tc,Pr: Array[0..67] Of Char;
  547. Begin
  548.   If Definition Then StrCat(BufPtr,'    ');
  549.   StrCat(BufPtr, '{-Properties}'#13#10);
  550.   For i:= 0 To GetNumProps-1 Do If IsValidProp(i) Then Begin
  551.     pType:= GetPropType(i);
  552.     If pType In [PType_CString..PType_BString] Then Begin
  553.       If pType=PType_Enum Then
  554.         Str2Id(StrEnd(StrCopy(Ty,'en')), GetPropName(i))
  555.       Else
  556.         StrPropType(Ty, pType);
  557.       StrPropTypeCast(Tc, pType);
  558.       StrPropProcName(Pr, pType);
  559.       For Get:= False To True Do Begin
  560.         If Definition Then
  561.           StrCat(StrCat(BufPtr,'    Function '), PropFn[Get])
  562.         Else
  563.           StrCat(StrCat(StrCat(StrCat(BufPtr,'Function t'),VbxClass),'.'),PropFn[Get]);
  564.         StrCat(Str2Id(StrEnd(BufPtr), GetPropName(i)), ' (');
  565.         If IsArrayProp(i) Then StrCat(BufPtr, 'Index: Integer; ');
  566.         If Get Then StrCat(BufPtr,'Var ');
  567.         StrCat(StrCat(StrCat(BufPtr, 'aValue: '),Ty),'): Bool;'#13#10);
  568.         If Not Definition Then Begin
  569.           StrCat(StrCat(BufPtr,'Begin'#13#10'  '),PropFn[Get]);
  570.           Str2Id(StrEnd(BufPtr), GetPropName(i));
  571.           StrCat(BufPtr,':= ');
  572.           If IsArrayProp(i) Then
  573.             StrCat(BufPtr, PropArrayFn[Get])
  574.           Else
  575.             StrCat(BufPtr,PropFn[Get]);
  576.           StrCat(BufPtr, Pr);
  577.           L2Str(StrEnd(StrCat(BufPtr,'(')), i);
  578.           If IsArrayProp(i) Then
  579.             StrCat(BufPtr,', Index, ')
  580.           Else
  581.             StrCat(BufPtr,', ');
  582.           If StrLen(Tc)>0 Then
  583.             StrCat(StrCat(BufPtr,Tc),'(aValue)')
  584.           Else
  585.             StrCat(BufPtr, 'aValue');
  586.           StrCat(BufPtr, ')'#13#10'End;'#13#10#13#10)
  587.         End;
  588.         BufPtr:= StrEnd(BufPtr)
  589.       End
  590.     End;
  591.     CheckBuf
  592.   End
  593. End;
  594.  
  595. Procedure tDumpControl.DumpDefaultData;
  596. Var
  597.   aFormFile: tHandle;
  598.   cl, l: LongInt;
  599.   aByte: Byte;
  600.   aLine: Array[0..150] Of Char;
  601. Begin
  602.   aFormFile:= dVbx.VBXSaveProperties(Ctl);
  603.   If aFormFile=0 Then Exit;
  604.   l:= dVbx.VBXGetFormFileLength(aFormFile);
  605.   If l<1 Then Exit;
  606.   VBSeekFormFile(aFormFile, 0);
  607.   BufPtr:= StrEnd(StrCat(StrCat(StrCat(BufPtr,'Const'#13#10+
  608.                '  Data'), VbxClass), ': Array[0..'));
  609.   L2Str(BufPtr, l-1);
  610.   StrCat(BufPtr,'] Of Byte = ('#13#10);
  611.   StrCopy(aLine,'    ');
  612.   For cl:= 0 To l-1 Do Begin
  613.     VBReadFormFile(aFormFile, @aByte, 1);
  614.     StrCat(aLine,'$');
  615.     HexStr(StrEnd(aLine), aByte);
  616.     If cl<l-1 Then StrCat(aLine,',');
  617.     If StrLen(aLine)>68 Then Begin
  618.       BufPtr:= StrEnd(StrCat(StrCat(BufPtr, aLine),#13#10));
  619.       StrCopy(aLine, '    ');
  620.     End;
  621.   End;
  622.   BufPtr:= StrEnd(StrCat(StrCat(BufPtr, aLine),');'#13#10));
  623.   CheckBuf;
  624.   dVbx.VbxDeleteFormFile(aFormFile)
  625. End;
  626.  
  627. Procedure tDumpControl.DumpObjectDefinition;
  628. Var
  629.   i: Integer;
  630.   Tmp: Array[0..67] Of Char;
  631. Begin
  632.   StrCat(StrCat(StrCat(BufPtr,'Type'#13#10+
  633.                 '{-t'), VbxClass), ' }'#13#10);
  634.   DumpEnums;
  635.   BufPtr:= StrEnd(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(BufPtr,
  636.     #13#10+
  637.     '  p'), VbxClass), ' = ^t'), VbxClass), ';'#13#10'  t'), VbxClass),
  638.     ' = Object(tVbxControl)'#13#10+
  639.     '    Constructor Init (aParent: pWindowsObject; anId: Integer; Title: pChar;'#13#10+
  640.     '                      x,y,w,h: Integer; Len: LongInt; Data: Pointer);'#13#10));
  641.   StrCat(BufPtr, '    {-Events}'#13#10);
  642.   For i:= 0 To GetNumEvents-1 Do Begin
  643.     BufPtr:= StrEnd(StrCat(StrCat(StrCat(StrCat(StrCat(BufPtr,
  644.       '    Procedure ev'), GetEventId(Tmp, i)),
  645.       ' (Var Event: tVbxEvent); Virtual ev_First+'), L2Str(Tmp, i)), ';'#13#10));
  646.     CheckBuf
  647.   End;
  648.   DumpPropProc(True);
  649.   BufPtr:= StrEnd(StrCat(BufPtr, '  End;'#13#10));
  650.   DumpDefaultData
  651. End;
  652.  
  653. Procedure tDumpControl.DumpObjectImplementation;
  654. Type
  655.   pEventInfo = ^tEventInfo;
  656.   tEventInfo = Record
  657.     npszName: Word;
  658.     cParms,
  659.     cwParms: Word;
  660.     npParamTypes: Word;
  661.     npszParmProf: Word;
  662.     fl: LongInt
  663.   End;
  664. Var
  665.   i: Integer;
  666.   Tmp: Array[0..67] Of Char;
  667.   p: pEventInfo;
  668.   el: pChar;
  669.   en: Integer;
  670.   pw: ^Word;
  671. Begin
  672.   BufPtr:= StrEnd(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(BufPtr,
  673.     '{- '), VbxClass), ' }'#13#10+
  674.     'Constructor t'), VbxClass), '.Init (aParent: pWindowsObject; anId: Integer; Title: pChar;'#13#10+
  675.     '                      x,y,w,h: Integer; Len: LongInt; Data: Pointer);'#13#10+
  676.     'Begin'#13#10+
  677.     '  Inherited Init(aParent, anId, '''), VbxBaseName), ''', '''), VbxClass),
  678.        ''', Title, x, y, w, h, '#13#10+
  679.     '                 SizeOf(Data'), VbxClass),'), @Data'), VbxClass),');'#13#10+
  680.     'End;'#13#10+
  681.           #13#10));
  682.   For i:= 0 To GetNumEvents-1 Do Begin
  683.     BufPtr:= StrEnd(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(StrCat(BufPtr,
  684.       'Procedure t'), VbxClass), '.ev'), GetEventId(Tmp, i)), ' (Var Event: tVbxEvent);'#13#10+
  685.       'Begin'#13#10+
  686.       '  {$IfDef Debug} WriteLn(''[t'), VbxClass), '.ev'), GetEventId(Tmp, i)), ']''); {$EndIf}'#13#10));
  687.  
  688.     p:= dVbx.VbxGetModelEventInfo(Model, i);
  689.     If Assigned(p) And (p^.cParms<>0) Then Begin
  690.       StrCat(BufPtr,'{'); l2str(StrEnd(BufPtr),p^.cParms);
  691.       StrCat(BufPtr,' params: ');
  692.       pw:= MakeLp(p,p^.npParamTypes);
  693.       For en:= 1 To p^.cParms Do Begin
  694.         StrEventArgType(StrEnd(BufPtr), pw^);
  695.         Inc(pw);
  696.         StrCat(BufPtr,' ')
  697.       End;
  698.       StrCat(BufPtr,#13#10' descr= ');
  699.       StrCat(BufPtr, MakeLp(p, p^.npszParmProf));
  700.       BufPtr:= StrEnd(StrCat(BufPtr,'}'#13#10))
  701.     End;
  702.  
  703.     BufPtr:= StrEnd(StrCat(BufPtr, 'End;'#13#10#13#10));
  704.     CheckBuf
  705.   End;
  706.   DumpPropProc(False)
  707. End;
  708.  
  709. Function tInfoWindow.GenerateInfo (aVBXName, aPascalName: pChar): Boolean;
  710. Var
  711.   ci: pVbxClass;
  712.   p: pChar;
  713.   Ctl: pDumpControl;
  714.   ModName: Array[0..67] Of Char;
  715. Begin
  716.   GenerateInfo:= False;
  717.   aBuf:= MemAlloc(64000);
  718.   If Not Assigned(aBuf) Then Begin Error('Can''t allocate buffer'); Exit End;
  719.   dVbx.Done; {we need this because dVbx is already initialized!}
  720.   dVbx.Init(True);
  721.   If Not dVbx.LibLink Or Not dVbx.VbxLoadVbx(aVBXName) Then Begin
  722.     Error('Can''t load VBX file');
  723.     Exit
  724.   End;
  725.  
  726.   Prefix:= New(pPrefixCollection, Init(100, 5));
  727.  
  728.   aBuf[0]:= #0; BufPtr:= aBuf;
  729.   {$i-}
  730.   Assign(DstFile, aPascalName); ReWrite(DstFile, 1);
  731.   If IoResult<>0 Then Begin Error('Can''t create Pascal file'); Exit End;
  732.  
  733.   StrJustName(ModName, aPascalName);
  734.   p:= StrScan(ModName, '.'); If Assigned(p) Then p^:= #0;
  735.  
  736.   StrCat(StrCat(StrCat(aBuf, 'Unit '), ModName),';'#13#10+
  737.          '{this file was automatically generated by VbxInfo.'#13#10+
  738.          ' VbxInfo is (c) 1994 Peter Sawatzki}'#13#10+
  739.          'Interface'#13#10+
  740.          'Uses'#13#10+
  741.          '  WinTypes,'#13#10+
  742.          '  oWindows,'#13#10+
  743.          '  Vbx;'#13#10);
  744.  
  745.   ci:= dVBX.VbxGetFirstClass;
  746.   While Assigned(ci) Do With ci^, ModelInfo^ Do Begin
  747.     Ctl:= New(pDumpControl, Init(@Self, aVbxName, MakeLp(ModelInfo, npszClassName), ModelInfo));
  748.     If Assigned(Ctl) Then Begin
  749.       With Ctl^ Do If Create Then Begin
  750.         DumpObjectDefinition;
  751.         Destroy
  752.       End;
  753.       Dispose(Ctl, Done)
  754.     End;
  755.     ci:= dVbx.VbxGetNextClass(ci);
  756.     CheckBuf
  757.   End;
  758.  
  759.   StrCat(aBuf, #13#10'Implementation'#13#10);
  760.   ci:= dVBX.VbxGetFirstClass;
  761.   While Assigned(ci) Do With ci^, ModelInfo^ Do Begin
  762.     Ctl:= New(pDumpControl, Init(@Self, aVbxName, MakeLp(ModelInfo, npszClassName), ModelInfo));
  763.     If Assigned(Ctl) Then Begin
  764.       With Ctl^ Do If Create Then Begin
  765.         DumpObjectImplementation;
  766.         Destroy
  767.       End;
  768.       Dispose(Ctl, Done)
  769.     End;
  770.     ci:= dVbx.VbxGetNextClass(ci);
  771.     CheckBuf
  772.   End;
  773.   StrCat(aBuf, 'End.');
  774.   WriteBuf;
  775.   Close(DstFile); If IoResult<>0 Then Begin Error('Can''t close file'); Exit End;
  776.  
  777.   Dispose(Prefix, Done);
  778.   FreeMem(aBuf, 64000);
  779.   GenerateInfo:= True
  780. End;
  781.  
  782. {-------------------- the Application part }
  783. Const
  784.   ProgName = 'VbxInfo';
  785. Type
  786.   tProgApp = Object(tApplication)
  787.     Procedure InitMainWindow; Virtual;
  788.   End;
  789.  
  790. Procedure tProgApp.InitMainWindow;
  791. Begin
  792.   MainWindow:= New(pInfoWindow, Init(Nil, ProgName))
  793. End;
  794.  
  795. Var
  796.   App: tProgApp;
  797. Begin
  798.   RegisterVBX(VBXvalidation);
  799.   With App Do Begin
  800.     Init(ProgName);
  801.     Run;
  802.     Done
  803.   End
  804. End.
  805.  
  806.