home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / windows / vbcore / vbsim_.pas < prev    next >
Pascal/Delphi Source File  |  1993-09-25  |  55KB  |  2,001 lines
  1. { VBSIM:   A VBRUNXXX SIMULATION
  2.   version 0.00 FIRST ALPHA
  3.   This Pascal unit is copyright of Juancarlo Anez.  All rights reserved.
  4.  
  5.   There are no garantees given, expressed of implied.
  6.  
  7.  Juancarlo Anez
  8.  CIS      : [73000,1064]
  9.  Internet : 73000.1064@compuserve.com
  10. }
  11. {$K-,S-,R-,L-}
  12. UNIT VBSIM_; {Simulate MS Visual Basic, as to be able to use .VBX controls}
  13. INTERFACE
  14.   USES OBJECTS,
  15.        WINTYPES,
  16.        OWINDOWS,
  17.        VBAPI_;
  18.  
  19.   TYPE
  20.     pTWIPS = ^TWIPS;
  21.     TWIPS  = Longint;
  22.     pColorREf = ^tColorRef;
  23.  
  24.   CONST
  25.     vbs_TwipsPerInch   = 72{points}*20;
  26.     vbs_ClassNameSep   = ':';
  27.  
  28.     vbm_First          = vbm__Base;
  29.     vbm_Last           = vbm_DATA_METHOD;
  30.  
  31.  
  32.  
  33.  
  34.     wmu_QueryVBControl = wm_User+100;
  35.   TYPE
  36.     tvbsErrorProc = procedure(num:Word; msg :pChar);
  37.  
  38.   CONST
  39.     { override this to hqandle VBX error messages }
  40.     vbsErrorMessage :tvbsErrorProc = nil;
  41.  
  42.   TYPE
  43.  
  44.     pVBControlCore = ^tVBControlCore;
  45.     tVBControlProc = function{( control     :pVBControlCore;
  46.                                hwnd        :HWND;
  47.                                message     :Word;
  48.                                wParam      :WORD;
  49.                                lParam      :Longint)} :Longint;
  50.  
  51.        pvbsPropInfo  = ^tvbsPropInfo;
  52.        tvbsPropInfo  = OBJECT(tObject)
  53.           id            :Word;
  54.           pszName       :lpStr;
  55.           fl            :LongInt;      {PF_ flags}
  56.           offsetData    :Byte;          { Offset into static structure}
  57.           infoData      :Byte;          { 0 or _INFO value for bitfield        }
  58.           dataDefault   :LongInt;      { 0 or _INFO value for bitfield}
  59.           pszEnumList   :lpStr;          { For TYPE == DT_ENUM, this is
  60.                                       a far ptr to a string containing
  61.                                       all the values to be displayed
  62.                                       in the popup enumeration listbox.
  63.                                       Each value is an sz, with an
  64.                                       empty sz indicated the end of list. }
  65.           enumMax       :Byte;          {Maximum legal value for enum.}
  66.  
  67.  
  68.           constructor init(vbxDataSeg :Word;  propId :Word);
  69.           constructor copy( var propInfo :tvbsPropInfo);
  70.  
  71.           function    isStandard:Boolean;
  72.  
  73.           function    dataType:Word;
  74.           function    dataSize:Word;
  75.           function    isPropArray:Boolean;
  76.        END;
  77.  
  78.        pvbsEventInfo  = ^tvbsEventInfo;
  79.        tvbsEventInfo = OBJECT(tObject)
  80.           id            :Word;
  81.           pszName       :lpStr;
  82.           cParms        :Word;
  83.           cwParms       :Word;    { # words of parameters  }
  84.           pParmTypes    :pChar;    { list of parameter types}
  85.           pszParmProf   :lpStr;    { event parameter profile string}
  86.           fl            :LongInt;        { EF_ flags}
  87.  
  88.           constructor init(vbxDataSeg :Word;  eventId :Word);
  89.           constructor copy(var eventInfo :tvbsEventInfo);
  90.  
  91.           function    isStandard:Boolean;
  92.        END;
  93.  
  94.     tVBControlCore = OBJECT(tWindow)
  95.         _cursorInx       :Word;
  96.         _cursor          :tHandle;
  97.  
  98.  
  99.        constructor init(AParent: PWindowsObject; AnId: Integer; ATitle: PChar);
  100.        constructor InitResource(AParent: PWindowsObject; ResourceID: Word);
  101.        destructor  done;  virtual;
  102.  
  103.  
  104.        function eventCount :Word; virtual;
  105.        function propCount  :Word; virtual;
  106.  
  107.        function propIndex(name :pChar):Integer;    virtual;
  108.        function propName(inx :Integer):pChar;      virtual;
  109.        function propType(inx :Integer):Word;       virtual;
  110.        function propFlags(inx :Integer):ULONG;     virtual;
  111.        function isPropArray(inx :Integer):Boolean; virtual;
  112.  
  113.        function eventName(inx :Integer):pChar;     virtual;
  114.        function eventIndex(name :pChar):Word;      virtual;
  115.  
  116.        function getProp(inx :Integer) :pvbsPropInfo;   virtual;
  117.        function getEvent(inx :Integer) :pvbsEventInfo; virtual;
  118.  
  119.        function getPropValue(inx, arrI :Word; value :Pointer):Boolean;
  120.        function setPropValue(inx, arrI :Word; value :Longint):Boolean;
  121.  
  122.        function getPropDataDefault(name :pChar; var value :Longint):Boolean;
  123.        function modelFlags :ULONG;
  124.  
  125.  
  126.        procedure loadPreHwndProps; virtual;
  127.        function  eventFired(inx :Word; params :Pointer):Word;
  128.        virtual;
  129.  
  130.        procedure paletteChanged; virtual;
  131.  
  132.        function YTwipsToPixels(Twips: TWIPS):Integer;
  133.        function XTwipsToPixels(Twips: TWIPS):Integer;
  134.        function YPixelsToTwips(Pixels: Integer): TWIPS;
  135.        function XPixelsToTwips(Pixels: Integer): TWIPS;
  136.  
  137.        function visible :Boolean;
  138.        function enabled :Boolean;
  139.  
  140.        function  getClassName :pChar; virtual;
  141.        procedure getWindowClass(var class :TWNDCLASS); virtual;
  142.  
  143.        procedure defWndProc(var msg :tMessage); virtual;
  144.        procedure defVBControlProc(var msg :tMessage); virtual;
  145.        function  forwardMsgToVBX(msg, wParam :Word; lParam :Longint):Longint;
  146.        procedure wmQueryVBControl(var msg :tMessage);
  147.        virtual   wm_First+wmu_QueryVBControl;
  148.  
  149.     PRIVATE
  150.       _controlDataSize :Word;
  151.       _controlData     :pChar;
  152.       _model           :Pointer;
  153.       _flags           :Longint;
  154.  
  155.  
  156.      { call default window procedure without forwarding to VBX }
  157.      procedure overridenWndProc(var msg :tMessage);
  158.  
  159.      function _getPropValue(inx, arrI :Word; pdata :Pointer; messages :Boolean):Boolean;
  160.      function _setPropValue(inx, arrI :Word; value :Longint; messages :Boolean):Boolean;
  161.  
  162.  
  163.     END;
  164.  
  165.  
  166.   function registerVBX(name :pChar):Integer;
  167.   const
  168.     vbserr_OK          =  0;
  169.     vbserr_VBXNotFound = -1;
  170.     vbserr_NotVBX      = -2;
  171.     vbserr_CantInitVBX = -3;
  172.  
  173.  
  174.   function derefHLSTR(hszStr :HLSTR):lpStr;
  175.   function derefHSZ(hszStr :pChar):lpStr;
  176.  
  177.   function isLFlagSet(flags :Longint; test :Longint):Boolean;
  178.  
  179. IMPLEMENTATION
  180.   USES  WIN87EM,
  181.         WINPROCS,
  182.         WIN31,
  183.         STRINGS;
  184.  
  185.  
  186.   CONST
  187.     vbs_MaxStack        = 32000;
  188.     vbs_StackFillByte   = $0C;
  189.     vbs_StackSafetySize = 512;
  190.  
  191.     vbs_CallbackStackPos = $20;
  192.     vbs_StackAllocFlags  = GMEM_FIXED or GMEM_ZEROINIT;
  193.     vbs_StackBase        = vbs_MaxStack - vbs_StackSafetySize;
  194.  
  195.     vbs_JumpTableSize    = 90;
  196.  
  197.     vbs_MaxModels        = 128;
  198.     nModels              : -1..vbs_MaxModels = 0;
  199.  
  200.     vbsPropSize          : array[dt_HSZ..dt_Hlstr] of Byte =
  201.       (
  202.       {dt_HSZ             } sizeOf(HSZ),
  203.       {dt_SHORT           } sizeOf(Integer),
  204.       {dt_LONG         } sizeOf(Longint),
  205.       {dt_BOOL         } sizeOf(WordBool),
  206.       {dt_COLOR        } sizeOf(tColorRef),
  207.       {dt_ENUM         } sizeOf(Byte),
  208.       {dt_REAL         } sizeOf(Single),
  209.       {dt_XPOS         } sizeOf(Longint),
  210.       {dt_XSIZE        } sizeOf(Longint),
  211.       {dt_YPOS         } sizeOf(Longint),
  212.       {dt_YSIZE        } sizeOf(Longint),
  213.       {dt_PICTURE      } sizeOf(tHandle),
  214.       {dt_HLSTR        } sizeOf(HLSTR)
  215.       );
  216.  
  217.   TYPE
  218.     pvbsReplacementStack = ^tvbsReplacementStack;
  219.     tvbsReplacementStack = array[0..vbs_MaxStack] of Byte;
  220.  
  221.     pvbsCallback = ^tvbsCallback;
  222.     tvbsCallBack  = procedure;
  223.     tvbsJumpTable = array[0..vbs_JumpTableSize] of tFarProc;
  224.  
  225.   CONST
  226.  
  227.     vbsStackHandle   :tHandle              = 0;      { handle for GlobalAlloc }
  228.     vbsStack         :pvbsReplacementStack = nil;    { a replacement stack }
  229.     vbsSSegment      :Word                 = 0;      { Stack segment }
  230.     vbsStackChanged  :Boolean              = FALSE;
  231.                                                      { to replacement stack      }
  232.  
  233.   TYPE
  234.        pPropArray = ^tPropArray;
  235.        tPropArray = array[0..$FFFF div sizeOf(pvbsPropInfo)-1] of pvbsPropInfo;
  236.  
  237.        pEventArray = ^tEventArray;
  238.        tEventArray = array[0..$FFFF div sizeOf(pvbsEventInfo)-1] of pvbsEventInfo;
  239.  
  240.        pvbsModel = ^tvbsModel;
  241.        tvbsModel = OBJECT(tObject)
  242.           dllInstance      :tHandle;
  243.           usVersion        :Word;        {VB version used by control}
  244.           fl               :LongInt;    { Bitfield structure}
  245.           ctlproc          :tVBControlProc;
  246.           fsClassStyle     :Word;         { window class style}
  247.           flWndStyle       :LongInt;    {default window style}
  248.           cbCtlExtra       :Word;        { # bytes alloc'd for HCtl structure}
  249.           idBmpPalette     :Word;        { BITMAP id for tool palette}
  250.           DefCtlName       :pChar;        {PSTR;     { default control name prefix}
  251.           ClassName        :pChar;        {PSTR;        { Visual Basic class name}
  252.           ParentClassName  :pChar;        {PSTR;    { Parent window class if subclassed}
  253.           proplist         :pPropArray;    { Property list}
  254.           eventlist        :pEventArray;{ Event list}
  255.           nDefProp         :Byte;        { index of default property}
  256.           nDefEvent        :Byte;        { index of default event}
  257.           nValueProp       :Byte;        { Index of control value property}
  258.           usCtlVersion     :Word;       {    Identifies the current version of
  259.                                            the custom control. The values
  260.                                            1 and 2 are reserved for custom
  261.                                            controls created with VB 1.0 and
  262.                                            VB 2.0.}
  263.           eventCount       :Word;
  264.           propCount        :Word;
  265.  
  266.           constructor init(vbxDataSeg :Word; dll :tHandle; var model :tModel);
  267.           destructor  done; virtual;
  268.  
  269.           function  getClassName :pChar; virtual;
  270.           procedure getWindowClass(var class :TWNDCLASS); virtual;
  271.  
  272.           function propIndex(name :pChar):Integer;
  273.           function eventIndex(name :pChar):Integer;
  274.  
  275.           function getProp(inx :Integer) :pvbsPropInfo;
  276.           function getEvent(inx :Integer) :pvbsEventInfo;
  277.  
  278.           function propType(inx :Integer) :Word;
  279.           function propFlags(inx :Integer):ULONG;
  280.  
  281.           function getPropNamed(name :pChar)  :pvbsPropInfo;
  282.           function getEventNamed(name :pChar) :pvbsEventInfo;
  283.  
  284.           function getPropWithId(id :Word) :pvbsPropInfo;
  285.           function sumPropSize :Word;
  286.  
  287.           function getPropDataDefault(name :pChar; var value :Longint):Boolean;
  288.        END;
  289.  
  290.   VAR
  291.      Models        : array[0..vbs_MaxModels-1] of pvbsModel;
  292.  
  293.  
  294. {$I STDPROP.INC }
  295. {$I STDEVENT.INC}
  296.  
  297.   function isLFlagSet(flags :Longint; test :Longint):Boolean;
  298.   begin
  299.     isLFlagSet := 0 <> (flags and test)
  300.   end;
  301.  
  302.   constructor tvbsModel.init(vbxDataSeg :Word; dll :tHandle;  var model :tModel);
  303.   var pprops  :^Word;
  304.       pevents :^Word;
  305.       p       :^Word;
  306.       i       :Word;
  307.       procInst:tFarProc;
  308.   begin
  309.     inherited init;
  310.     dllInstance        := dll;
  311.     usVersion        := model.usVersion;
  312.     fl               := model.fl;
  313.     procInst         := makeProcInstance(model.ctlProc, hInstance);
  314.     ctlproc          := tVBControlProc(model.ctlProc);
  315.     fsClassStyle     := model.fsClassStyle;
  316.     flWndStyle       := model.flWndStyle;
  317.     cbCtlExtra       := model.cbCtlExtra;
  318.     idBmpPalette     := model.idBmpPalette;
  319.     DefCtlName       := Ptr(vbxDataSeg, model.defCtlName);
  320.     ClassName        := Ptr(vbxDataSeg, model.className);
  321.     ParentClassName  := Ptr(vbxDataSeg, model.parentClassName);
  322.     proplist         := nil;
  323.     eventlist          := nil;
  324.     nDefProp         := model.nDefProp;
  325.     nDefEvent        := model.nDefEvent;
  326.     nValueProp       := model.nValueProp;
  327.     usCtlVersion     := model.usCtlVersion;
  328.  
  329.     if model.proplist <> 0 then begin
  330.       pprops := Ptr(vbxDataSeg, model.proplist);
  331.       p := pprops;
  332.       propCount := 0;
  333.       while (p^ <> 0) and (p^ <> PPROPINFO_STD_LAST) do begin
  334.         inc(propCount);
  335.         inc(p);
  336.       end;
  337.       getMem(proplist, (propCount+1)*sizeOf(pvbsPropInfo));
  338.       fillChar(proplist^, (propCount+1)*sizeOf(pvbsPropInfo), #0);
  339.       p := pprops;
  340.       i := 0;
  341.       while (p^ <> 0) and (p^ <> PPROPINFO_STD_LAST) do begin
  342.         if (not p^ >= 0) and (not p^ <= vbs_MaxStdProp) then
  343.           proplist^[i] := new(pvbsPropInfo, copy(stdPropInfo[not p^]))
  344.         else
  345.           proplist^[i] := new(pvbsPropInfo, init(vbxDataSeg, p^));
  346.         inc(p);
  347.         inc(i);
  348.       end;
  349.     end;
  350.     if model.eventlist <> 0 then begin
  351.       pevents := Ptr(vbxDataSeg, model.eventlist);
  352.       p := pevents;
  353.       eventCount := 0;
  354.       while (p^ <> 0) and (p^ <> PEVENTINFO_STD_LAST) do begin
  355.         inc(eventCount);
  356.         inc(p);
  357.       end;
  358.       getMem(eventlist, (eventCount+1)*sizeOf(pvbsEventInfo));
  359.       fillChar(eventlist^, (eventCount+1)*sizeOf(pvbsEventInfo), #0);
  360.       p := pevents;
  361.       i := 0;
  362.       while (p^ <> 0) and (p^ <> PEVENTINFO_STD_LAST) do begin
  363.         if (not p^ >= 0) and (not p^ <= vbs_MaxStdProp) then
  364.           eventlist^[i] := new(pvbsEventInfo, copy(stdEventInfo[not p^]))
  365.         else
  366.           eventlist^[i] := new(pvbsEventInfo, init(vbxDataSeg, p^));
  367.         inc(p);
  368.         inc(i);
  369.       end;
  370.     end
  371.   end;
  372.  
  373.   destructor tvbsModel.done;
  374.   var
  375.     i :Integer;
  376.   begin
  377.     for i := 0 to propCount-1 do
  378.       dispose(proplist^[i]);
  379.     for i := 0 to eventCount-1 do
  380.       dispose(eventlist^[i]);
  381.     freeMem(proplist, (propCount+1)*sizeOf(pvbsPropInfo));
  382.     freeMem(eventlist, (eventCount+1)*sizeOf(pvbsEventInfo));
  383.     inherited done;
  384.   end;
  385.  
  386.   function    tvbsModel.getClassName :pChar;
  387.   const
  388.      Max = 100;
  389.      fullClassname  :array[0..Max] of Char = '';
  390.   begin
  391.       strLCopy(fullClassName, 'VBSIM:', Max);
  392.       strLCat(fullClassName, className, Max);
  393.       getClassName := fullClassName
  394.   end;
  395.  
  396.   procedure   tvbsModel.getWindowClass(var class :TWNDCLASS);
  397.   var
  398.     value :Longint;
  399.   begin
  400.       if not getClassInfo(hInstance, getClassName, class) then begin
  401.         { get parent's class data, default to BUTTON }
  402.         if   (parentClassName = nil)
  403.         or not getClassInfo(0, parentClassName, class) then begin
  404.           fillChar(class, sizeOf(class),0);
  405.  
  406.           if not getClassInfo(0, 'Button', class) then
  407.             vbsErrorMessage(0,'Control Initialization Failed');
  408.         end;
  409.  
  410.         class.lpszClassName := getClassName;
  411.         class.style         := class.style or fsClassStyle or cs_DblClks;
  412.         class.hInstance     := hInstance;
  413.  
  414.         { these must be set from propertys }
  415.         class.lpszMenuName  := nil;
  416.         class.hIcon         := 0;
  417.         class.hCursor       := 0;
  418.         class.hbrBackGround := 0;
  419.  
  420.         if getPropDataDefault('MousePointer', value) then
  421.           class.hCursor  := loadCursor(0, makeIntResource(value));
  422.  
  423.  
  424.     end
  425.   end;
  426.  
  427.   type pPointer = ^Pointer;
  428.   function countPtrList(p :array of Pointer):Word;
  429.   var count :Word;
  430.   begin
  431.     count := 0;
  432.     while (p[count] <> nil) do
  433.       inc(count);
  434.     countPtrList := count
  435.   end;
  436.  
  437.   function tvbsModel.sumPropSize :Word;
  438.   var
  439.      i    :Integer;
  440.      size :Word;
  441.   begin
  442.     size := 0;
  443.     if proplist <> nil then begin
  444.       i := 0;
  445.       while (proplist^[i] <> nil) do begin
  446.         with propList^[i]^ do
  447.           if not isStandard then
  448.             inc(size, dataSize);
  449.         inc(i)
  450.       end
  451.     end;
  452.     sumPropSize := size;
  453.   end;
  454.  
  455.   function tvbsModel.getProp(inx :Integer):pvbsPropInfo;
  456.   begin
  457.     if (inx < 0) or (inx > propCount) then
  458.       getProp := nil
  459.     else
  460.       getProp := proplist^[inx]
  461.   end;
  462.  
  463.   function tvbsModel.propType(inx :Integer) :Word;
  464.   var
  465.     prop :pvbsPropInfo;
  466.   begin
  467.     propType := 0;
  468.     prop := getProp(inx);
  469.     if prop <> nil then
  470.       propType := prop^.dataType
  471.   end;
  472.  
  473.   function tvbsModel.propFlags(inx :Integer) :ULONG;
  474.   var
  475.     prop :pvbsPropInfo;
  476.   begin
  477.     propFlags := 0;
  478.     prop := getProp(inx);
  479.     if prop <> nil then
  480.       propFlags := prop^.fl
  481.   end;
  482.  
  483.   function tvbsModel.getEvent(inx :Integer):pvbsEventInfo;
  484.   begin
  485.     if (inx < 0) or (inx > eventCount) then
  486.       getEvent := nil
  487.     else
  488.       getEvent := eventlist^[inx]
  489.   end;
  490.  
  491.   function tvbsModel.propIndex(name :pChar):Integer;
  492.   var
  493.      i :Integer;
  494.   begin
  495.     propIndex := -1;
  496.     if proplist <> nil then begin
  497.       i := 0;
  498.       while (proplist^[i] <> nil) do
  499.         if strComp(proplist^[i]^.pszName, name) = 0 then begin
  500.           propIndex := i;
  501.           break
  502.         end
  503.         else
  504.           inc(i)
  505.     end
  506.   end;
  507.  
  508.  
  509.   function tvbsModel.eventIndex(name :pChar):Integer;
  510.   var
  511.      i :Integer;
  512.   begin
  513.     eventIndex := -1;
  514.     if eventList <> nil then begin
  515.       i := 0;
  516.       while (proplist^[i] <> nil) do
  517.         if strComp(eventList^[i]^.pszName, name) = 0 then begin
  518.           eventIndex := i;
  519.           break
  520.         end
  521.         else
  522.           inc(i)
  523.     end
  524.   end;
  525.  
  526.  
  527.   function tvbsModel.getPropNamed(name :pChar)  :pvbsPropInfo;
  528.   begin
  529.     getPropNamed := getProp(propIndex(name))
  530.   end;
  531.  
  532.   function tvbsModel.getPropWithId(id :Word) :pvbsPropInfo;
  533.   var
  534.      i :Integer;
  535.   begin
  536.     getPropWithId := nil;
  537.     if proplist <> nil then begin
  538.       i := 0;
  539.       while (proplist^[i] <> nil) do
  540.         if proplist^[i]^.id = id then begin
  541.           getPropWithId := proplist^[i];
  542.           break
  543.         end
  544.         else
  545.           inc(i)
  546.     end
  547.   end;
  548.  
  549.  
  550.   function tvbsModel.getEventNamed(name :pChar) :pvbsEventInfo;
  551.   begin
  552.     getEventNamed := getEvent(eventIndex(name))
  553.   end;
  554.  
  555.   function tvbsModel.getPropDataDefault(name :pChar; var value :Longint):Boolean;
  556.   var
  557.     prop :pvbsPropInfo;
  558.   begin
  559.     prop := getPropNamed(name);
  560.     if prop <> nil then begin
  561.       value := prop^.dataDefault;
  562.       getPropDataDefault := TRUE
  563.     end
  564.     else begin
  565.       value := 0;
  566.       getPropDataDefault := FALSE
  567.     end
  568.   end;
  569.  
  570.   constructor tvbsPropInfo.init(vbxDataSeg :Word; propId :Word);
  571.   var
  572.     propInfo :pPropInfo;
  573.   begin
  574.      propInfo := Ptr(vbxDataSeg, propId);
  575.      inherited init;
  576.      id            := propId;
  577.      pszName       := Ptr(vbxDataSeg, propInfo^.npszName);
  578.      fl            := propInfo^.fl;
  579.      offsetData    := propInfo^.offsetData;
  580.      infoData      := propInfo^.infoData;
  581.      dataDefault   := propInfo^.dataDefault;
  582.      pszEnumList   := Ptr(vbxDataSeg, propInfo^.npszEnumList);
  583.      enumMax       := propInfo^.enumMax
  584.   end;
  585.  
  586.   constructor tvbsPropInfo.copy(var propInfo :tvbsPropInfo);
  587.   begin
  588.     inherited init;
  589.     Self := propInfo;
  590.   end;
  591.  
  592.   function    tvbsPropInfo.isStandard:Boolean;
  593.   begin
  594.     isStandard := (not id >= 0) and (not id <= vbs_MaxStdProp)
  595.   end;
  596.  
  597.   function tvbsPropInfo.dataType:Word;
  598.   begin
  599.     dataType := fl and pf_DataType
  600.   end;
  601.  
  602.   function tvbsPropInfo.dataSize:Word;
  603.   begin
  604.     dataSize := vbsPropSize[dataType]
  605.   end;
  606.  
  607.  
  608.   function tvbsPropInfo.isPropArray:Boolean;
  609.   begin
  610.     isPropArray := isLFlagSet(fl, pf_fPropArray)
  611.   end;
  612.  
  613.  
  614.   constructor tvbsEventInfo.init(vbxDataSeg :Word; eventId :Word);
  615.   var
  616.     eventInfo :pEventInfo;
  617.   begin
  618.      id           := eventId;
  619.      eventInfo    := Ptr(vbxDataSeg, eventId);
  620.      pszName      := Ptr(vbxDataSeg, eventInfo^.npszName);
  621.      cParms       := eventInfo^.cParms;
  622.      cwParms      := eventInfo^.cwParms;
  623.      pParmTypes   := Ptr(vbxDataSeg, eventInfo^.npParmTypes);
  624.      pszParmProf  := Ptr(vbxDataSeg, eventInfo^.npszParmProf);
  625.      fl           := eventInfo^.fl;
  626.   end;
  627.  
  628.   constructor tvbsEventInfo.copy(var eventInfo :tvbsEventInfo);
  629.   begin
  630.     inherited init;
  631.     Self := eventInfo;
  632.   end;
  633.  
  634.   function tvbsEventInfo.isStandard:Boolean;
  635.   begin
  636.     isStandard := (not id >= 0) and (not id <= vbs_MaxStdEvent)
  637.   end;
  638.  
  639.  
  640.   procedure buildMessage(var m :tMEssage; hwnd :HWND; msg, wParam:Word; lParam :Longint);
  641.   begin
  642.     fillChar(m, sizeOf(m), 0);
  643.     m.receiver := hwnd;
  644.     m.message  := msg;
  645.     m.wParam   := wParam;
  646.     m.lParam   := lParam;
  647.   end;
  648.  
  649.  
  650.   function __RegisterModel(dataseg :Word; dllInstance :tHandle; var model:tModel):Boolean;
  651.   export;
  652.   begin
  653.     if nModels >= vbs_MaxModels then
  654.       __RegisterModel := FALSE
  655.     else begin
  656.       Models[nModels] := new(pvbsModel, init(dataSeg, dllInstance, model) );
  657.       if (Models[nModels] <> nil) then begin
  658.            inc(nModels);
  659.            __RegisterModel := TRUE;
  660.       end
  661.     end
  662.   end;
  663.  
  664.  
  665.   function findModel(className :pChar) :pvbsModel;
  666.   var
  667.     i :Integer;
  668.   begin
  669.     findModel := nil;
  670.     for i := 0 to Integer(nModels)-1 do
  671.       if strComp(className, Models[i]^.className) = 0 then begin
  672.         findModel := Models[i];
  673.         break;
  674.       end
  675.   end;
  676.  
  677.   const
  678.     tempStr :pChar = nil;
  679.   function derefHLSTR(hszStr :HLSTR):lpStr;
  680.   var   pstr    :pChar;
  681.   begin
  682.     pstr := nil;
  683.     if hszStr <> nil then begin
  684.       getMem(pstr, length(pString(hszStr)^)+1);
  685.       if pstr <> nil then begin
  686.         strPCopy(pstr, pString(hszStr)^);
  687.         if tempStr <> nil then
  688.           strDispose(tempStr);
  689.         tempStr := pstr;
  690.       end;
  691.     end;
  692.     derefHLSTR := pstr
  693.   end;
  694.  
  695.   function derefHSZ(hszStr :pChar):lpStr;
  696.   var   pstr    :pChar;
  697.   begin
  698.   pstr := nil;
  699.     if hszStr <> nil then begin
  700.       pstr := strNew(hszStr);
  701.       if pstr <> nil then begin
  702.         if tempStr <> nil then
  703.           strDispose(tempStr);
  704.         tempStr := pstr;
  705.       end;
  706.     end;
  707.     derefHSZ := pstr
  708.   end;
  709.  
  710.   { VISUAL BASIC SIMULATIONS }
  711.  
  712.   function vbsDerefControl(Control: pVBControlCore): Pointer;
  713.   export;
  714.   begin
  715.     vbsDerefControl := control^._controlData;
  716.   end;
  717.  
  718.   function vbsRegisterModel(HMod: THandle ; var Model: TModel ): Bool; far;
  719.   assembler;
  720.     asm
  721.       push ds             { callers DS is first parameter }
  722.       push hmod           { push rest of paramenters}
  723.       les  di, model
  724.       push es
  725.       push di
  726.       { now restore our data segment }
  727.       { standard protocol for export routines,  AX = our DS    }
  728.       mov  ax,  SEG @Data
  729.       call __RegisterModel
  730.     end;
  731.  
  732.   function vbsGetControlHwnd(Control: pVBControlCore): HWnd;
  733.   export;
  734.   begin
  735.     vbsGetControlHwnd := control^.hwindow;
  736.   end;
  737.  
  738.   function vbsGetHInstance: THandle;
  739.   export;
  740.   begin
  741.     vbsGetHInstance := hInstance;
  742.   end;
  743.  
  744.   function vbsGetControlModel(Control: pVBControlCore): LPModel;
  745.   export;
  746.   begin
  747.     vbsGetControlModel := control^._model
  748.   end;
  749.  
  750.   function vbsGetControlName(Control: pVBControlCore; lpszName: LPStr): LPStr;
  751.   export;
  752.   begin
  753.     vbsGetControlName := control^.attr.title
  754.   end;
  755.  
  756.   function vbsGetHwndControl(Wnd: HWnd): pVBControlCore;
  757.   export;
  758.   begin
  759.     vbsGetHwndControl := Pointer(sendMessage(wnd, wmu_QueryVBControl, 0, 0))
  760.   end;
  761.  
  762.   function vbsSendControlMsg(Control: pVBControlCore; Msg, WParam: Word; LParam: LongInt): LongInt;
  763.   export;
  764.   begin
  765.     vbsSendControlMsg := sendMessage(control^.hwindow, msg, wParam, lParam);
  766.   end;
  767.  
  768.   function vbsSuperControlProc(Control: pVBControlCore; Msg, WParam: Word; LParam: LongInt): LongInt;
  769.   export;
  770.   var m :tMessage;
  771.   begin
  772.     buildMessage(m, control^.hwindow, msg, wParam, lParam);
  773.     control^.overridenWndProc(m);
  774.     vbsSuperControlProc := m.result
  775.   end;
  776.  
  777.   function vbsGetMode: Word;
  778.   export;
  779.   begin
  780.     vbsGetMode := MODE_RUN
  781.   end;
  782.  
  783.   function vbsRecreateControlHwnd(Control: pVBControlCore):Word;
  784.   export;
  785.   begin
  786.      control^.destroy;
  787.      if control^.create then
  788.        vbsRecreateControlHwnd := 0
  789.      else
  790.        vbsRecreateControlHwnd := 1
  791.   end;
  792.  
  793.   procedure vbsDirtyForm(Control: pVBControlCore);
  794.   export;
  795.   begin
  796.   end;
  797.  
  798.   function vbsSetErrorMessage(error: Word; Str: LPStr): Word;
  799.   export;
  800.   begin
  801.     vbsErrorMessage(error, str)
  802.   end;
  803.  
  804.   procedure vbsGetAppTitle(Str: LPStr; cbMax: Word);
  805.   export;
  806.   begin
  807.     strLCopy(str, application^.name, cbMax);
  808.   end;
  809.  
  810.   function vbsDialogBoxParam(Instance: THandle; TemplateName: LPStr;
  811.                                       DialogFunc: TFARPROC; lp: LongInt):Integer;
  812.   export;
  813.   begin
  814.     vbsDialogBoxParam := dialogBoxParam(instance, templateName, getFocus, dialogFunc, lp)
  815.   end;
  816.  
  817. {// Management of dynamically allocated strings}
  818.  
  819.   function vbsCreateHsz(Control: pVBControlCore; Str: LPStr): HSZ;
  820.   export;
  821.   begin
  822.     vbsCreateHsz := HSZ(strNew(str))
  823.   end;
  824.  
  825.   procedure vbsDestroyHsz(HSZStr: HSZ);
  826.   export;
  827.   begin
  828.     strDispose(pChar(hszStr));
  829.     if pChar(hszstr) = tempStr then
  830.       tempStr := nil;
  831.   end;
  832.  
  833.   function vbsDerefHsz(HSZStr: HSZ): LPStr;
  834.   export;
  835.   begin
  836.     vbsDerefHsz := lpStr(hszStr)
  837.   end;
  838.  
  839.   function vbsLockHsz(HSZStr: HSZ): LPStr;
  840.   export;
  841.   begin
  842.     vbsLockHsz := lpStr(hszStr)
  843.   end;
  844.  
  845.   procedure vbsUnlockHsz(HSZStr: HSZ);
  846.   export;
  847.   begin
  848.   end;
  849.  
  850. {// Management of language strings}
  851.  
  852.   function vbsCreateHlstr(pb: Pointer; cbLen: Word): HLStr;
  853.   export;
  854.   var  ps :pString;
  855.   begin
  856.     if cblen > 255 then
  857.       cbLen := 255;
  858.     getMem(ps, cbLen+1);
  859.     ps^[0] := Char(cbLen);
  860.     move(pb^, ps^[1], cbLen);
  861.     vbsCreateHlstr := hlStr(ps)
  862.   end;
  863.  
  864.   procedure vbsDestroyHlstr(HStr: HLStr);
  865.   export;
  866.   begin
  867.     disposeStr(pString(hstr))
  868.   end;
  869.  
  870.   function vbsDerefHlstr(HStr: HLStr): LPStr;
  871.   export;
  872.   begin
  873.     vbsDerefHlstr := derefHLSTR(hstr);
  874.   end;
  875.  
  876.   function vbsGetHlstrLen(HStr: HLStr): Word;
  877.   export;
  878.   begin
  879.      if hstr = nil then
  880.        vbsGetHlstrLen := 0
  881.      else
  882.        vbsGetHlstrLen := length(pString(hStr)^)
  883.   end;
  884.  
  885.   function vbsSetHlstr(var PHStr:hlStr; pb: Pointer; cbLen: Word): Word;
  886.   export;
  887.   var ps :pString;
  888.   begin
  889.       disposeStr(pString(phstr));
  890.       phstr := HLSTR(newStr(strPas(pChar(pb))));
  891.       if phstr <> nil then
  892.         vbsSetHlstr := 0
  893.       else
  894.         vbsSetHlstr := 1
  895.   end;
  896.  
  897.   {// Firing Basic event procedures}
  898.  
  899.   function vbsFireEvent(Control: pVBControlCore; IdEvent: Word; LPParams: Pointer): Word;
  900.   export;
  901.   var msg :Word;
  902.   begin
  903.     vbsFireEvent := control^.eventFired(idEvent, lpParams)
  904.   end;
  905.  
  906. {// Control property access}
  907.  
  908.   function vbsGetControlProperty(Control: pVBControlCore; IdProp: Word; pData :Pointer): Word;
  909.   export;
  910.   begin
  911.     control^._getPropValue(idProp, 0, pData, TRUE)
  912.   end;
  913.  
  914.   function vbsSetControlProperty(Control: pVBControlCore; IdProp: Word; data :Longint): Err;
  915.   export;
  916.   begin
  917.     control^._setPropValue(idProp, 0, data, TRUE)
  918.   end;
  919. {// Picture management functions}
  920.  
  921.   function vbsAllocPic(PntPic: PPIC): HPic; export;
  922.   begin
  923.     vbsAllocPic := 0
  924.   end;
  925.  
  926.   procedure vbsFreePic(Pic: HPic); export;
  927.   begin
  928.   end;
  929.  
  930.   function vbsGetPic(Pic: HPic; PntPic: PPic): HPic; export;
  931.   begin
  932.     vbsGetPic := 0
  933.   end;
  934.  
  935.   function vbsPicFromCF(PntHPic: Pointer; HData: THandle; WFormat: Word): Word;export;
  936.   begin
  937.     pWord(pntHpic)^ := 0;
  938.     vbsPicFromCF := 1
  939.   end;
  940.  
  941.   function vbsRefPic(Pic: HPic): HPic; export;
  942.   begin
  943.     vbsRefPic := 0
  944.   end;
  945.  
  946.   {// File IO functions}
  947.  
  948.   function vbsReadFormFile(FormFile: HFormFile; pb: Pointer; cb: Word):Word;
  949.   export;
  950.   begin
  951.   end;
  952.  
  953.   function vbsWriteFormFile(FormFile: HFormFile; pb: Pointer; cb: Word):Word;
  954.   export;
  955.   begin
  956.   end;
  957.  
  958.   function vbsSeekFormFile(FormFile: HFormFile; OffSet: LongInt): LongInt;
  959.   export;
  960.   begin
  961.   end;
  962.  
  963.   function vbsRelSeekFormFile(FormFile: HFormFile; OffSet: LongInt):LongInt;
  964.   export;
  965.   begin
  966.   end;
  967.  
  968.   function vbsReadBasicFile(UsFileNo: Word; pb: Pointer; cb: Word):Word;
  969.   export;
  970.   begin
  971.   end;
  972.  
  973.   function vbsWriteBasicFile(UsFileNo: Word; pb: Pointer; cb: Word):Word;
  974.   export;
  975.   begin
  976.   end;
  977.  
  978.   {// Conversion functions}
  979.  
  980.   procedure getLogPixels(hwnd :tHandle; var x, y :Longint);
  981.   var hdc  :tHandle;
  982.   begin
  983.     hdc  := getDC(hwnd);
  984.  
  985.     x := getDeviceCaps(hdc, LOGPIXELSX);
  986.     y := getDeviceCaps(hdc, LOGPIXELSY);
  987.  
  988.     releaseDC(hwnd, hdc);
  989.   end;
  990.  
  991.   function vbsYPixelsToTwips(Pixels: Integer): TWIPS;
  992.   export;
  993.   var xPixelsPerInch :Longint;
  994.       yPixelsPerInch :Longint;
  995.   begin
  996.     getLogPixels(getFocus, xPixelsPerInch, yPixelsPerInch);
  997.     vbsYPixelsToTwips := (Longint(pixels)*vbs_TwipsPerInch) div yPixelsPerInch;
  998.   end;
  999.  
  1000.   function vbsXPixelsToTwips(Pixels: Integer): TWIPS;
  1001.   export;
  1002.   var xPixelsPerInch :Longint;
  1003.       yPixelsPerInch :Longint;
  1004.   begin
  1005.     getLogPixels(getFocus, xPixelsPerInch, yPixelsPerInch);
  1006.     vbsXPixelsToTwips := (Longint(pixels)*vbs_TwipsPerInch) div xPixelsPerInch;
  1007.   end;
  1008.  
  1009.   function vbsYTwipsToPixels(Twips: TWIPS):Integer;
  1010.   export;
  1011.   var xPixelsPerInch :Longint;
  1012.       yPixelsPerInch :Longint;
  1013.   begin
  1014.     getLogPixels(getFocus, xPixelsPerInch, yPixelsPerInch);
  1015.     vbsYTwipsToPixels := Integer((twips*yPixelsPerInch) div vbs_TwipsPerInch);
  1016.   end;
  1017.  
  1018.   function vbsXTwipsToPixels(Twips: TWIPS):Integer;
  1019.   export;
  1020.   var xPixelsPerInch :Longint;
  1021.       yPixelsPerInch :Longint;
  1022.   begin
  1023.     getLogPixels(getFocus, xPixelsPerInch, yPixelsPerInch);
  1024.     vbsXTwipsToPixels := Integer((twips*xPixelsPerInch) div vbs_TwipsPerInch);
  1025.   end;
  1026.  
  1027.  
  1028. {// Ver 2.0 Functions}
  1029.  
  1030.   function vbsGetVersion: Word;
  1031.   export;
  1032.   begin
  1033.     vbsGetVersion := VB200_VERSION
  1034.   end;
  1035.  
  1036.   procedure vbsPaletteChanged(Control: pVBControlCore );
  1037.   export;
  1038.   begin
  1039.     control^.paletteChanged
  1040.   end;
  1041.  
  1042.   function vbsSetControlFlags(Control: pVBControlCore; mask: LongInt; value: LongInt ): LongInt;
  1043.   export;
  1044.   var
  1045.     oldFlags :Longint;
  1046.     hasPal   :Boolean;
  1047.   begin
  1048.     with control^ do begin
  1049.       oldFlags := _flags;
  1050.       _flags := (_flags and not mask) or (mask and value);
  1051.     end;
  1052.     vbsSetControlFlags := control^._flags;
  1053.     hasPal := isLFlagSet(mask and value, ctlflg_HasPalette);
  1054.     if hasPal or (hasPal <> isLFlagSet(mask and oldFlags, ctlflg_HasPalette)) then
  1055.       control^.paletteChanged
  1056.   end;
  1057.  
  1058.   function __vbsGetCapture: pVBControlCore;
  1059.   begin
  1060.     __vbsGetCapture := pVBControlCore(sendMessage(getCapture, wmu_QueryVBControl, 0, 0));
  1061.   end;
  1062.  
  1063.   function vbsGetCapture: pVBControlCore;
  1064.   export;
  1065.   begin
  1066.     vbsGetCapture := __vbsGetCapture
  1067.   end;
  1068.  
  1069.   procedure vbsSetCapture(Control: pVBControlCore );
  1070.   export;
  1071.   begin
  1072.     setCapture(control^.hwindow);
  1073.   end;
  1074.  
  1075.   procedure vbsReleaseCapture;
  1076.   export;
  1077.   begin
  1078.     if __vbsGetCapture <> nil then
  1079.       releaseCapture;
  1080.   end;
  1081.  
  1082.   procedure vbsMoveControl(Control: pVBControlCore; var Rect: TRect ; fRepaint: BOOL );
  1083.   export;
  1084.   begin
  1085.     moveWindow( control^.hwindow,
  1086.                 rect.left, rect.top,
  1087.                 rect.right-rect.left, rect.bottom-rect.top,
  1088.                 fRepaint);
  1089.   end;
  1090.  
  1091.   procedure vbsGetControlRect(Control: pVBControlCore ;var Rect: TRect );
  1092.   export;
  1093.   begin
  1094.     getWindowRect(control^.hwindow, rect)
  1095.   end;
  1096.  
  1097.   procedure vbsGetRectInContainer(Control: pVBControlCore ;var Rect: TRect );
  1098.   export;
  1099.   var
  1100.     hdc :tHandle;
  1101.   begin
  1102.     getWindowRect(control^.hwindow, rect);
  1103.     if control^.parent <> nil then begin
  1104.       mapWindowPoints(0, control^.parent^.hwindow, rect, 2);
  1105.       hdc := getDC(control^.parent^.hwindow);
  1106.       dpToLp(hdc, rect, 2);
  1107.       releaseDC(control^.parent^.hwindow, hdc);
  1108.     end
  1109.   end;
  1110.  
  1111.   procedure vbsGetClientRect(Control: pVBControlCore ;var Rect: TRect );
  1112.   export;
  1113.   begin
  1114.     getClientRect(control^.hwindow, rect)
  1115.   end;
  1116.  
  1117.   procedure vbsClientToScreen(Control: pVBControlCore ;var Point: TPoint );
  1118.   export;
  1119.   begin
  1120.     clientToScreen(control^.hwindow, point)
  1121.   end;
  1122.  
  1123.   procedure vbsScreenToClient(Control: pVBControlCore;var Point: TPoint );
  1124.   export;
  1125.   begin
  1126.     screenToClient(control^.hwindow, point)
  1127.   end;
  1128.  
  1129.   function vbsIsControlVisible(Control: pVBControlCore ): BOOL;
  1130.   export;
  1131.   begin
  1132.     vbsIsControlVisible := control^.visible
  1133.   end;
  1134.  
  1135.   function vbsIsControlEnabled(Control: pVBControlCore ): BOOL;
  1136.   export;
  1137.   begin
  1138.     vbsIsControlEnabled := control^.enabled
  1139.   end;
  1140.  
  1141.   procedure vbsInvalidateRect(Control: pVBControlCore ;Rect: pRect ; fEraseBkGnd: BOOL );
  1142.   export;
  1143.   begin
  1144.       invalidateRect(control^.hwindow, rect, fEraseBkGnd)
  1145.   end;
  1146.  
  1147.   procedure vbsUpdateControl(Control: pVBControlCore );
  1148.   export;
  1149.   begin
  1150.     updateWindow(control^.hwindow)
  1151.   end;
  1152.  
  1153.   function vbsGetControl(Control: pVBControlCore ; gc: WORD ): pVBControlCore;
  1154.   export;
  1155.   begin
  1156.   end;
  1157.  
  1158.   procedure vbsZOrder(Control: pVBControlCore ; zorder: WORD );
  1159.   export;
  1160.   begin
  1161.     if zorder = ZORDER_FRONT then
  1162.       setWindowPos(control^.hwindow, HWND_TOP, 0, 0, 0,0, SWP_NOMOVE or SWP_NOSIZE)
  1163.     else if zorder = ZORDER_BACK then
  1164.       setWindowPos(control^.hwindow, HWND_BOTTOM, 0, 0, 0,0, SWP_NOMOVE or SWP_NOSIZE);
  1165.   end;
  1166.  
  1167.   function vbsCreateTempHlstr(pb: Pointer ; cbLen: Word ): HLStr;
  1168.   export;
  1169.   const s :String = '';
  1170.   begin
  1171.     s := strPas(pb);
  1172.     vbsCreateTempHlstr := hlStr(@s)
  1173.   end;
  1174.  
  1175.   function vbsDerefHlstrLen(HStr: HLStr ;var pCbLen: Word ): PChar;
  1176.   export;
  1177.   begin
  1178.      vbsDerefHlstrLen := derefHLSTR(hstr);
  1179.      pCBLen := 0;
  1180.      if hstr <> nil then
  1181.        pCbLen  := length(pString(hstr)^);
  1182.   end;
  1183.  
  1184.   function vbsDerefZeroTermHlstr(HStr: HLStr ): PChar;
  1185.   export;
  1186.   begin
  1187.     vbsDerefZeroTermHlstr := vbsDerefHLStr(hstr)
  1188.   end;
  1189.  
  1190.   function vbsGetHlstr(HStr: HLStr ; pb: Pointer ; cbLen: Word ): Word;
  1191.   export;
  1192.   begin
  1193.     strLCopy(pb, derefHLStr(hstr), cbLen);
  1194.     vbsGetHlstr := strLen(pb)
  1195.   end;
  1196.  
  1197.   function vbsResizeHlstr(HStr: HLStr ; newCbLen: Word ): Word;
  1198.   export;
  1199.   begin
  1200.     vbsResizeHlstr := 1
  1201.   end;
  1202.  
  1203. {// Management of language Variant data TYPE}
  1204.  
  1205. function vbsCoerceVariant(Variant: PVariant ; vtype: Integer ; lpData: Pointer ): Word;
  1206. export;
  1207. begin
  1208.   vbsCoerceVariant := 1
  1209. end;
  1210.  
  1211. function vbsGetVariantType(Variant: PVariant ): Integer;
  1212. export;
  1213. begin
  1214.   vbsGetVariantType := 0
  1215. end;
  1216.  
  1217. function vbsGetVariantValue(Variant: PVariant ; Value: PValue ): Integer;
  1218. export;
  1219. begin
  1220.   vbsGetVariantValue := 1
  1221. end;
  1222.  
  1223. function vbsSetVariantValue(Variant: PVariant ; vtype: Integer ; lpData: Pointer ): Word;
  1224. export;
  1225. begin
  1226.   vbsSetVariantValue := 1
  1227. end;
  1228.  
  1229. {// Management of language arrays}
  1230.  
  1231. function vbsArrayElement(VBArray: HAD ; cIndex: Integer ;var lpi: Integer ): Pointer;
  1232. export;
  1233. begin
  1234.   vbsArrayElement := nil
  1235. end;
  1236.  
  1237. function vbsArrayBounds(VBArray: HAD ; index: Integer ): LongInt;
  1238. export;
  1239. begin
  1240.   vbsArrayBounds := 0
  1241. end;
  1242.  
  1243. function vbsArrayElemSize(VBArray: HAD ): Word;
  1244. export;
  1245. begin
  1246.   vbsArrayElemSize := 0
  1247. end;
  1248.  
  1249. function vbsArrayFirstElem(VBArray: HAD ): Pointer;
  1250. export;
  1251. begin
  1252.   vbsArrayFirstElem := nil
  1253. end;
  1254.  
  1255. function vbsArrayIndexCount(VBArray: HAD ): Integer;
  1256. export;
  1257. begin
  1258.   vbsArrayIndexCount := 0
  1259. end;
  1260.  
  1261.   {// VB Error routines}
  1262.  
  1263.   procedure vbsRuntimeError(err: Word );
  1264.   export;
  1265.   begin
  1266.     vbsErrorMessage(err, '')
  1267.   end;
  1268.  
  1269.   var  FPSaveArea : Win87EmSaveArea;
  1270.  
  1271.   {// Floating-point stack save/restore utilities}
  1272.   function vbsCbSaveFPState(pb: Pointer ; cb: Word ): Word;
  1273.   export;
  1274.   begin
  1275.      __Win87EmSave(@FPSaveArea, sizeOf(FPSaveArea))
  1276.   end;
  1277.  
  1278.   procedure vbsRestoreFPState(pb: Pointer );
  1279.   export;
  1280.   begin
  1281.      __Win87EmRestore(@FPSaveArea, sizeOf(FPSaveArea))
  1282.   end;
  1283.  
  1284. {// Picture functions}
  1285. function vbsAllocPicEx(PntPic: PPIC ; usVersion: Word ): HPic;
  1286. export;
  1287. begin
  1288. end;
  1289. function vbsGetPicEx(Pic: HPic ; PntPic: PPIC ; usVersion: Word ): HPic;
  1290. export;
  1291. begin
  1292. end;
  1293. function vbsTranslateColor(Control: pVBControlCore ; Color: LongInt ): LongInt;
  1294. export;
  1295. begin
  1296.   vbsTranslateColor := RGBColor(color)
  1297. end;
  1298.  
  1299. {// Link Interface functions}
  1300.  
  1301. function vbsLinkPostAdvise(Control: pVBControlCore ): Word;
  1302. export;
  1303. begin
  1304. end;
  1305. function vbsPasteLinkOk(var phTriplet: THANDLE ; Control: pVBControlCore ): BOOL;
  1306. export;
  1307. begin
  1308. end;
  1309.  
  1310. {// Misc functions}
  1311. function vbsFormat(vtype: Integer ; lpData: Pointer ; lpszFmt: PChar ;
  1312.                     pb: Pointer ; cb: Word ): Integer;
  1313. export;
  1314. begin
  1315.   pb := nil
  1316. end;
  1317.  
  1318. { VB 3.0 }
  1319. procedure vbsLinkMakeItemName(Control:pVBControlCore; lpszBuf: PChar);
  1320. export;
  1321. begin
  1322.   lpszBuf[0] := #0;
  1323. end;
  1324.  
  1325. function vbsGetDataSourceControl(Control: pVBControlCore; blsRegistered: Bool):pVBControlCore;
  1326. export;
  1327. begin
  1328.   vbsGetDataSourceControl := nil
  1329. end;
  1330.  
  1331. function vbsSeekBasicFile(usFileNo: Word; offset: LongInt): LongInt;
  1332. export;
  1333. begin
  1334.   vbsSeekBasicFile := 0
  1335. end;
  1336.  
  1337. function vbsRelSeekBasicFile(usFileNo: Word; offset: LongInt): LongInt;
  1338. export;
  1339. begin
  1340.   vbsRelSeekBasicFile := 0
  1341. end;
  1342.  
  1343.   function vbsDefControlProc(Control: pVBControlCore;Wnd: HWnd;
  1344.           Msg: Word; WParam: Word; LParam: LongInt): LongInt;
  1345.   export;
  1346.   var m :tMessage;
  1347.   begin
  1348.     buildMessage(m, control^.hwindow, msg, wParam, lParam);
  1349.     control^.defVBControlProc(m);
  1350.     vbsDefControlProc := m.result;
  1351.   end;
  1352.  
  1353.   constructor tVBControlCore.Init(AParent: PWindowsObject; AnId: Integer; ATitle: PChar);
  1354.   var
  1355.     className :pChar;
  1356.     wndName   :pChar;
  1357.     allOK     :Boolean;
  1358.     model     :pvbsModel;
  1359.     value     :Longint;
  1360.   begin
  1361.     _controlData := nil;
  1362.     allOk := TRUE;
  1363.     { parse ATitle into ClassName:WindowName, where : is vbs_ClassNameSep }
  1364.     className := strNew(aTitle);
  1365.     if className = nil then
  1366.       fail;
  1367.  
  1368.     wndName   := strScan(className, vbs_ClassNameSep);
  1369.  
  1370.     if (wndName <> nil) then begin
  1371.       wndName^ := #0;
  1372.       inc(wndName);
  1373.     end;
  1374.  
  1375.     _model := findModel(className);
  1376.     model  := _model;
  1377.     allOk := _model <> nil;
  1378.  
  1379.     if allOk then
  1380.       allOk := inherited init(aParent, {anId,} wndName);{, x, y, w, h);}
  1381.  
  1382.     if allOk then begin
  1383.       getMem(_controlData, model^.cbCtlExtra);
  1384.       allOk := _controlData <> nil;
  1385.       if allOk then
  1386.          fillChar(_controlData^, model^.cbCtlExtra, #0);
  1387.     end;
  1388.     if wndName <> nil then begin
  1389.       dec(wndName);
  1390.       wndName^ := vbs_ClassNameSep
  1391.     end;
  1392.     if not allOk then begin
  1393.       strDispose(className);
  1394.       fail;
  1395.     end;
  1396.  
  1397.     { start sending messages to the newly created control }
  1398.     if isLFlagSet(model^.fl, model_fInitMsg) then
  1399.       forwardMsgToVBX(vbm_Initialize, 0, 0);
  1400.     with attr do begin
  1401.       style := (model^.flWndStyle or ws_Child or ws_ClipSiblings or ws_Border or ws_Visible)
  1402.                and not (ws_Caption or ws_Disabled{or ws_Visible});
  1403.     end;
  1404.  
  1405.     _flags := 0;
  1406.  
  1407.     _cursor := 0;
  1408.     strDispose(className);
  1409.   end;
  1410.  
  1411.   constructor tVBControlCore.InitResource(AParent: PWindowsObject; ResourceID: Word);
  1412.   begin
  1413.     fail
  1414.   end;
  1415.  
  1416.  
  1417.   destructor tVBControlCore.done;
  1418.   begin
  1419.     freeMem(_controlData, pvbsModel(_model)^.cbCtlExtra);
  1420.     inherited done;
  1421.   end;
  1422.  
  1423.  
  1424.   function tVBControlCore.visible :Boolean;
  1425.   begin
  1426.     visible := isWindowVisible(hwindow)
  1427.   end;
  1428.  
  1429.   function tVBControlCore.enabled :Boolean;
  1430.   begin
  1431.     enabled := isWindowEnabled(hwindow)
  1432.   end;
  1433.  
  1434.   procedure tVBControlCore.defWndProc(var msg :tMessage);
  1435.   begin
  1436.     with msg do
  1437.       result := forwardMsgToVBX(message, wParam, lParam)
  1438.   end;
  1439.  
  1440.   procedure tVBControlCore.overridenWndProc(var msg :tMessage);
  1441.   begin
  1442.     inherited defWndProc(msg);
  1443.   end;
  1444.  
  1445.   procedure tVBControlCore.wmQueryVBControl(var msg :tMessage);
  1446.   begin
  1447.     msg.result := Longint(@self)
  1448.   end;
  1449.  
  1450.   procedure tVBControlCore.loadPreHwndProps;
  1451.   var
  1452.     i    :Integer;
  1453.   begin
  1454.     {
  1455.     for i := 0 to propCount do
  1456.         if isLFlagSet(propFlags(i), pf_fLoadMsg) then
  1457.           forwardMsgToVBX(vbm_LoadLoadProperty
  1458.     }
  1459.   end;
  1460.  
  1461.  
  1462.   function  tVBControlCore.getClassName :pChar;
  1463.   begin
  1464.     getClassName := pvbsModel(_model)^.getClassName
  1465.   end;
  1466.  
  1467.   function tVBControlCore.eventFired(inx :Word; params :Pointer):Word;
  1468.   begin
  1469.   end;
  1470.  
  1471.   procedure tVBControlCore.getWindowClass(var class :TWNDCLASS);
  1472.   var  vbxClass :tWNDCLASS;
  1473.   begin
  1474.     inherited getWindowClass(class);
  1475.     pvbsModel(_model)^.getWindowClass(vbxClass);
  1476.  
  1477.     {defaultProc      := vbxClass.lpfnWndProc;}
  1478.  
  1479.     class.style      := class.style or vbxClass.style;
  1480.     class.cbClsExtra := class.cbClsExtra + vbxClass.cbClsExtra;
  1481.     class.cbWndExtra := class.cbWndExtra + vbxClass.cbWndExtra;
  1482.  
  1483.     {class.hInstance  := vbxClass.hinstance;}
  1484.  
  1485.     { these should be set from properties }
  1486.  
  1487.     {
  1488.     class.hIcon          := vbxClass.hIcon;
  1489.     class.hCursor        := vbxClass.hCursor;
  1490.     }
  1491.     { class.hbrBackGround  := vbxClass.hBrbackground};
  1492.   end;
  1493.  
  1494.   function tVBControlCore.eventCount :Word;
  1495.   begin
  1496.     eventCount := pvbsModel(_model)^.eventCount
  1497.   end;
  1498.  
  1499.   function tVBControlCore.propCount  :Word;
  1500.   begin
  1501.     propCount := pvbsModel(_model)^.propCount
  1502.   end;
  1503.  
  1504.  
  1505.   function tVBControlCore.propIndex(name :pChar):Integer;
  1506.   begin
  1507.     propIndex := pvbsModel(_model)^.propIndex(name)
  1508.   end;
  1509.  
  1510.   function tVBControlCore.propName(inx :Integer):pChar;
  1511.   var
  1512.     prop :pvbsPropInfo;
  1513.   begin
  1514.      prop := pvbsModel(_model)^.getProp(inx);
  1515.      if prop <> nil then
  1516.        propName := prop^.pszName
  1517.      else
  1518.        propName := nil
  1519.   end;
  1520.  
  1521.   function tVBControlCore.propType(inx :Integer):Word;
  1522.   begin
  1523.     propType := pvbsModel(_model)^.propType(inx)
  1524.   end;
  1525.  
  1526.   function tVBControlCore.propFlags(inx :Integer):ULONG;
  1527.   begin
  1528.     propFlags := pvbsModel(_model)^.propFlags(inx)
  1529.   end;
  1530.  
  1531.   function tVBControlCore.isPropArray(inx :Integer):Boolean;
  1532.   var
  1533.     prop :pvbsPropInfo;
  1534.   begin
  1535.      prop := pvbsModel(_model)^.getProp(inx);
  1536.      if prop <> nil then
  1537.        isPropArray := prop^.isPropArray
  1538.      else
  1539.        isPropArray := FALSE
  1540.   end;
  1541.  
  1542.   function tVBControlCore.eventName(inx :Integer):pChar;
  1543.   var
  1544.     event : pvbsEventInfo;
  1545.   begin
  1546.      event := pvbsModel(_model)^.getEvent(inx);
  1547.      if event <> nil then
  1548.        eventName := event^.pszName
  1549.      else
  1550.        eventName := nil
  1551.   end;
  1552.  
  1553.   function tVBControlCore.eventIndex(name :pChar):Word;
  1554.   begin
  1555.      eventIndex := pvbsModel(_model)^.eventIndex(name);
  1556.   end;
  1557.  
  1558.   function tVBControlCore.getProp(inx :Integer) :pvbsPropInfo;
  1559.   begin
  1560.      getProp := pvbsModel(_model)^.getProp(inx);
  1561.   end;
  1562.  
  1563.   function tVBControlCore.getEvent(inx :Integer) :pvbsEventInfo;
  1564.   begin
  1565.      getEvent:= pvbsModel(_model)^.getEvent(inx);
  1566.   end;
  1567.  
  1568.   function tVBControlCore.getPropValue(inx, arrI :Word; value :Pointer):Boolean;
  1569.   begin
  1570.     getPropValue := _getPropValue(inx, arrI, value, TRUE)
  1571.   end;
  1572.  
  1573.   function tVBControlCore.setPropValue(inx, arrI :Word; value :Longint):Boolean;
  1574.   begin
  1575.     setPropValue := _setPropValue(inx, arrI, value, TRUE)
  1576.   end;
  1577.  
  1578.   procedure tVBControlCore.paletteChanged;
  1579.   begin
  1580.   end;
  1581.  
  1582.   function tVBControlCore.YTwipsToPixels(Twips: TWIPS):Integer;
  1583.   var xPixelsPerInch :Longint;
  1584.       yPixelsPerInch :Longint;
  1585.   begin
  1586.     getLogPixels(getFocus, xPixelsPerInch, yPixelsPerInch);
  1587.     YTwipsToPixels := Integer((twips*yPixelsPerInch) div vbs_TwipsPerInch);
  1588.   end;
  1589.  
  1590.   function tVBControlCore.XTwipsToPixels(Twips: TWIPS):Integer;
  1591.   var xPixelsPerInch :Longint;
  1592.       yPixelsPerInch :Longint;
  1593.   begin
  1594.     getLogPixels(getFocus, xPixelsPerInch, yPixelsPerInch);
  1595.     XTwipsToPixels := Integer((twips*xPixelsPerInch) div vbs_TwipsPerInch);
  1596.   end;
  1597.  
  1598.   function tVBControlCore.YPixelsToTwips(Pixels: Integer): TWIPS;
  1599.   var xPixelsPerInch :Longint;
  1600.       yPixelsPerInch :Longint;
  1601.   begin
  1602.     getLogPixels(getFocus, xPixelsPerInch, yPixelsPerInch);
  1603.     YPixelsToTwips := (Longint(pixels)*vbs_TwipsPerInch) div yPixelsPerInch;
  1604.   end;
  1605.  
  1606.   function tVBControlCore.XPixelsToTwips(Pixels: Integer): TWIPS;
  1607.   var xPixelsPerInch :Longint;
  1608.       yPixelsPerInch :Longint;
  1609.   begin
  1610.     getLogPixels(getFocus, xPixelsPerInch, yPixelsPerInch);
  1611.     XPixelsToTwips := (Longint(pixels)*vbs_TwipsPerInch) div xPixelsPerInch;
  1612.   end;
  1613.  
  1614.  
  1615.  
  1616.   function tVBControlCore._getPropValue(inx, arrI :Word; pdata :Pointer; messages :Boolean):Boolean;
  1617.   var
  1618.     prop    :pvbsPropInfo;
  1619.     arrData :tDataStruct;
  1620.     hdc     :THandle;
  1621.   begin
  1622.     _getPropValue := TRUE;
  1623.     prop := pvbsModel(_model)^.getProp(inx);
  1624.     if prop = nil then
  1625.       exit;
  1626.     _getPropValue := FALSE;
  1627.      if not prop^.isStandard then begin
  1628.         if isLFlagSet(prop^.fl, pf_fGetData)
  1629.         and not prop^.isPropArray then
  1630.            System.move(_controlData[prop^.offsetData], pdata^, prop^.dataSize)
  1631.      end
  1632.      else
  1633.        case prop^.id of
  1634.          ppropinfo_std_Caption,
  1635.          ppropinfo_std_Text:
  1636.            pLongint(pdata)^ := Longint(vbsCreateTempHlstr(attr.title, strLen(attr.title)));
  1637.          ppropinfo_std_Left:
  1638.            pTWIPS(pdata)^ := vbsXPixelsToTwips(attr.x);
  1639.          ppropinfo_std_Top:
  1640.            pTWIPS(pdata)^ := vbsYPixelsToTwips(attr.y);
  1641.          ppropinfo_std_Width:
  1642.            pTWIPS(pdata)^ := vbsXPixelsToTwips(attr.w);
  1643.          ppropinfo_std_Height:
  1644.            pTWIPS(pdata)^ := vbsYPixelsToTwips(attr.h);
  1645.          ppropinfo_std_ForeColor: begin
  1646.            hdc := getDC(hwindow);
  1647.            pColorRef(pdata)^ := getTextColor(hdc);
  1648.            releaseDC(hwindow, hdc);
  1649.          end;
  1650.          ppropinfo_std_BackColor:begin
  1651.            hdc := getDC(hwindow);
  1652.            pColorRef(pdata)^ := getBkColor(hdc);
  1653.            releaseDC(hwindow, hdc);
  1654.          end;
  1655.          ppropinfo_std_MousePointer:
  1656.            pLongint(pdata)^ := _cursorInx;
  1657.          ppropinfo_std_Enabled:
  1658.            pBool(pdata)^ := isWindowEnabled(hwindow);
  1659.          ppropinfo_std_Visible:
  1660.            pBool(pdata)^ := isWindowVisible(hwindow);
  1661.          ppropinfo_std_Parent:
  1662.            pWord(pdata)^ := getParent(hwindow);
  1663.        else
  1664.          _getPropValue := FALSE
  1665.        end;
  1666.     if messages and isLFlagSet(prop^.fl, pf_fGetMsg) then begin
  1667.       if not prop^.isPropArray then
  1668.          forwardMsgToVBX(vbm_GetProperty, inx, Longint(pdata))
  1669.       else begin
  1670.          with arrData do begin
  1671.            data   := 0;
  1672.            cindex := 1;
  1673.            index[0].data     := arrI;
  1674.            index[0].dataType := dt_Short;
  1675.          end;
  1676.          forwardMsgToVBX(vbm_GetProperty, inx, Longint(@arrData));
  1677.          System.move(arrData.data, pdata^, prop^.dataSize)
  1678.       end
  1679.     end
  1680.   end;
  1681.  
  1682.   function tVBControlCore._setPropValue(inx, arrI:Word; value :Longint; messages :Boolean):Boolean;
  1683.   type
  1684.     pHLSTR = ^pString ;
  1685.   var
  1686.     prop    :pvbsPropInfo;
  1687.     arrData :tDataStruct;
  1688.     hdc     :THandle;
  1689.   begin
  1690.     _setPropValue := FALSE;
  1691.     prop := pvbsModel(_model)^.getProp(inx);
  1692.     if prop = nil then
  1693.       exit;
  1694.  
  1695.     if messages and isLFlagSet(prop^.fl, pf_fSetCheck)
  1696.     and (0 <> forwardMsgToVBX(vbm_CheckProperty, inx, value)) then
  1697.       exit;
  1698.  
  1699.     _setPropValue := TRUE;
  1700.     if not prop^.isStandard then begin
  1701.          if isLFlagSet(prop^.fl, pf_fSetData) and not prop^.isPropArray then begin
  1702.             case prop^.dataType of
  1703.               dt_HLSTR:
  1704.                 vbsDestroyHLSTR(HLSTR(_controlData[prop^.offsetData]));
  1705.               dt_HSZ:
  1706.                 vbsDestroyHSZ(HSZ(_controlData[prop^.offsetData]));
  1707.             end;
  1708.             System.move(value, _controlData[prop^.offsetData], prop^.dataSize)
  1709.          end
  1710.  
  1711.       end
  1712.       else
  1713.         case prop^.id of
  1714.           ppropinfo_std_Caption:
  1715.             setCaption(derefHLSTR(HLSTR(value)));
  1716.           ppropinfo_std_Left:
  1717.             attr.x := vbsXTwipsToPixels(value);
  1718.           ppropinfo_std_Top:
  1719.             attr.y := vbsYTwipsToPixels(value);
  1720.           ppropinfo_std_Width:
  1721.             attr.w := vbsXTwipsToPixels(value);
  1722.           ppropinfo_std_Height:
  1723.             attr.h := vbsYTwipsToPixels(value);
  1724.           ppropinfo_std_ForeColor: begin
  1725.             hdc := getDC(hwindow);
  1726.             setTextColor(hdc, value);
  1727.             releaseDC(hwindow, hdc);
  1728.             invalidateRect(hwindow, nil, TRUE)
  1729.           end;
  1730.           ppropinfo_std_BackColor: begin
  1731.             hdc := getDC(hwindow);
  1732.             setBkColor(hdc, value);
  1733.             releaseDC(hwindow, hdc);
  1734.             invalidateRect(hwindow, nil, TRUE)
  1735.           end;
  1736.           ppropinfo_std_MousePointer: begin
  1737.             _cursorInx := Word(value);
  1738.             _cursor := loadCursor(0, makeIntResource(_cursorInx));
  1739.           end;
  1740.           ppropinfo_std_Enabled:
  1741.             enableWindow(hwindow, value <> 0);
  1742.          ppropinfo_std_Visible:
  1743.            if Bool(value) then
  1744.              show(sw_Show)
  1745.            else
  1746.              show(sw_Hide);
  1747.         else
  1748.           _setPropValue := FALSE
  1749.         end;
  1750.  
  1751.       if messages {and isLFlagSet(prop^.fl, pf_fSetMsg)} then begin
  1752.         if not prop^.isPropArray then
  1753.           forwardMsgToVBX(vbm_SetProperty, inx, value)
  1754.         else begin
  1755.            with arrData do begin
  1756.              if prop^.dataType = dt_HLSTR then
  1757.                data := Longint(derefHLSTR(HLSTR(value)) )
  1758.              else
  1759.                data   := value;
  1760.              cindex := 1;
  1761.              index[0].data     := arrI;
  1762.              index[0].dataType := dt_Short;
  1763.            end;
  1764.            forwardMsgToVBX(vbm_SetProperty, inx, Longint(@arrData))
  1765.         end
  1766.       end
  1767.   end;
  1768.  
  1769.   function tVBControlCore.getPropDataDefault(name :pChar; var value :Longint):Boolean;
  1770.   begin
  1771.     getPropDataDefault := pvbsModel(_model)^.getPropDataDefault(name, value)
  1772.   end;
  1773.  
  1774.   function tVBControlCore.modelFlags :ULONG;
  1775.   begin
  1776.     modelFlags := pvbsModel(_model)^.fl
  1777.   end;
  1778.  
  1779.  
  1780.   procedure tVBControlCore.defVBControlProc(var msg :tMessage);
  1781.   var
  1782.      model :pvbsModel;
  1783.      ps    :tPaintStruct;
  1784.      hdc   :tHandle;
  1785.      hbr   :tHandle;
  1786.      rct   :tRect;
  1787.      inx   :Integer;
  1788.      color :tColorRef;
  1789.   begin
  1790.     model := _model;
  1791.     case msg.message of
  1792.       wm_NCCreate: begin
  1793.         overridenWndProc(msg);
  1794.       end;
  1795.       vbm_Created:
  1796.         if not isLFlagSet(model^.fl, model_fInvisAtRun) then
  1797.           show(sw_Show);
  1798.       vbm_CheckProperty:
  1799.          msg.result := 0;
  1800.       vbm_GetProperty:
  1801.          if _getPropValue(msg.wParam, 0, Pointer(msg.lParam), FALSE) then
  1802.            msg.result := 0;
  1803.       vbm_SetProperty:
  1804.          if _setPropValue(msg.wParam, 0, msg.lParam, FALSE) then
  1805.            msg.result := 0;
  1806.       vbm_First..vbm_Last:
  1807.          msg.result := 0;
  1808.     else
  1809.         overridenWndProc(msg);
  1810.     end
  1811.   end;
  1812.  
  1813.   procedure __performVBCallback; assembler;
  1814.    {$I VBJMPTBL.INC }
  1815.   asm
  1816.     or   bx, bx
  1817.     jnz  @@otherFuncs
  1818.     jmp   vbsRegisterModel
  1819.  @@otherFuncs:
  1820.     cmp  bx, vbs_JumpTableSize*4
  1821.     jbe  @@doJump
  1822.     jmp  vbsRuntimeError
  1823.   @@doJump:
  1824.     { standard protocol for calling exported functions }
  1825.     mov  ax, SEG @Data                    { put our data segment on AX         }
  1826.     mov  es, ax
  1827.     jmp  [dword ptr es:jumpTable+bx]      { jump to address of call back       }
  1828.   end;
  1829.  
  1830.  
  1831.   function testChangeStack(var change:Boolean) :Boolean;
  1832.   var
  1833.       pdataseg  :pWord;
  1834.       pcallback :pLongint;
  1835.   begin
  1836.     if vbsStackChanged then
  1837.       change := FALSE
  1838.     else begin
  1839.       change := TRUE;
  1840.       vbsStackChanged := TRUE;
  1841.  
  1842.      { place a verifiable value in the replacement stack, for overruns }
  1843.       fillChar(vbsStack^, sizeOf(vbsStack^), vbs_StackFillByte);
  1844.       {save address of our data segment here }
  1845.       pdataSeg  := pWord(@vbsStack^[vbs_CallbackStackPos-2]);
  1846.       pdataseg^ := DSEG;
  1847.  
  1848.      { place address of VBX callbak in specific stack offset just like VB does }
  1849.       pcallback  := pLongint(@vbsStack^[vbs_CallbackStackPos]);
  1850.       pcallback^ := Longint(@__performVBCallback);
  1851.     end;
  1852.     testChangeStack := change
  1853.   end;
  1854.  
  1855.   function testRestoreStack(var changed:Boolean) :Boolean;
  1856.   begin
  1857.     if not changed then
  1858.       testRestoreStack := FALSE
  1859.     else begin
  1860.       testRestoreStack := TRUE;
  1861.       vbsStackChanged := FALSE
  1862.     end;
  1863.     changed := FALSE
  1864.   end;
  1865.  
  1866.  
  1867.   function registerVBX(name :pChar):Integer;
  1868.   type
  1869.        tInitCC = procedure;
  1870.   var
  1871.        procAddr    :tFarProc;
  1872.        initcc      :tInitCC;
  1873.        dllInstance :tHandle;
  1874.        changeStk    :Boolean;
  1875.   begin
  1876.     dllInstance := loadLibrary(name);
  1877.     if dllInstance = 0 then begin
  1878.       registerVBX := vbserr_VBXNotFound;
  1879.       exit;
  1880.     end;
  1881.  
  1882.     procAddr := getProcAddress(dllInstance, 'VBINITCC');
  1883.     if procAddr = nil then begin
  1884.        registerVBX := vbserr_NotVBX;
  1885.        exit
  1886.     end;
  1887.  
  1888.  
  1889.     procaddr := makeProcInstance(procAddr, hInstance);
  1890.     if procaddr = nil then begin
  1891.       registerVBX := vbserr_CantInitVBX;
  1892.       exit;
  1893.     end;
  1894.  
  1895.     initcc   := tInitCC(procAddr);
  1896.     asm push ds end;
  1897.     if testChangeStack(changeStk) then
  1898.        switchStackTo(vbsSSegment, vbs_StackBase, vbs_StackSafetySize);
  1899.  
  1900.     initcc;
  1901.  
  1902.     if testRestoreStack(changeStk) then
  1903.        switchStackBack;
  1904.     asm pop ds end;
  1905.  
  1906.     freeProcInstance(procAddr);
  1907.     registerVBX := vbserr_OK;
  1908.   end;
  1909.  
  1910.   function tVBControlCore.forwardMsgToVBX(msg, wParam :Word; lParam :Longint):Longint;
  1911.   const
  1912.      ctlProc :tVBControlProc = nil;
  1913.      result  :Longint        =   0;
  1914.   var
  1915.      changeStk :Boolean; { this call replaced the stack }
  1916.      model     :pvbsModel;
  1917.      control   :pVBControlCore;
  1918.   begin
  1919.       control  := @Self;
  1920.       result   := 0;
  1921.       asm
  1922.         les  di, [dword ptr control]
  1923.         push es
  1924.         push di
  1925.         push [es:di].tVBControlCore.hWindow
  1926.         push [msg]
  1927.         push [wparam]
  1928.         push [word ptr lparam+2]
  1929.         push [word ptr lparam]
  1930.       end;
  1931.       model := control^._model;
  1932.       ctlProc := model^.ctlProc;
  1933.       if testChangeStack(changeStk) then begin
  1934.         switchStackTo(vbsSSegment, vbs_StackBase, vbs_StackSafetySize);
  1935.         result := ctlProc{(control, hwindow, msg, wParam, lParam)};
  1936.         switchStackBack;
  1937.         testRestoreStack(changeStk)
  1938.       end
  1939.       else
  1940.         result := model^.ctlProc{(control, hwindow, msg, wParam, lParam)};
  1941.       forwardMsgToVBX := result;
  1942.   end;
  1943.  
  1944.  
  1945.   CONST
  1946.      exitSave :Pointer = nil;
  1947.  
  1948.   procedure endvbsim; far;
  1949.   var
  1950.     i :Integer;
  1951.   begin
  1952.     for i := 0 to nModels-1 do
  1953.       freeLibrary(Models[i]^.dllInstance);
  1954.     globalUnlock(vbsStackHandle);
  1955.     globalFree(vbsStackHandle);
  1956.  
  1957.     exitProc := exitSave;
  1958.   end;
  1959.  
  1960.   procedure defaultError(num :Word; msg :pChar); far;
  1961.   begin
  1962.     runError(num)
  1963.   end;
  1964.  
  1965.  
  1966.   procedure initvbsim;
  1967.   var
  1968.     n :Integer;
  1969.   begin
  1970.      vbsErrorMessage := defaultError;
  1971.      { allocate a new replacement stack and initialize it  }
  1972.      vbsStackHandle := globalAlloc(vbs_StackAllocFlags, sizeOf(tvbsReplacementStack));
  1973.      if vbsStackHandle = 0 then begin
  1974.        vbsErrorMessage(0, 'Initialization Failed')
  1975.      end;
  1976.      vbsStack := pvbsReplacementStack(globalLock(vbsStackHAndle));
  1977.      if vbsStack = nil then begin
  1978.        globalFree(vbsStackHandle);
  1979.        vbsErrorMessage(0, 'Initialization Failed')
  1980.      end;
  1981.  
  1982.      if ofs(vbsStack^) <> 0 then begin
  1983.        { won't work, so abort }
  1984.        globalUnlock(vbsStackHandle);
  1985.        globalFree(vbsStackHandle);
  1986.        vbsErrorMessage(0, 'Initialization Failed')
  1987.      end;
  1988.  
  1989.  
  1990.  
  1991.      { record its segment and simulatad stack pointer position }
  1992.      vbsSSegment := seg(vbsStack^);
  1993.  
  1994.  
  1995.      exitSave := exitProc;
  1996.      exitProc := @endVBSim;
  1997.   end;
  1998.  
  1999. BEGIN
  2000.   initvbsim;
  2001. END.