Power-Programmierung/CD1.mdf/pascal/library/windows/vbcore/vbsim_.pas

Pascal/Delphi Source File | 1993-09-25 | 53.6 KB | 2,001 lines

{ VBSIM:   A VBRUNXXX SIMULATION
  version 0.00 FIRST ALPHA
  This Pascal unit is copyright of Juancarlo Anez.  All rights reserved.

  There are no garantees given, expressed of implied.

 Juancarlo Anez
 CIS      : [73000,1064]
 Internet : [e-mail]
}
{$K-,S-,R-,L-}
UNIT VBSIM_; {Simulate MS Visual Basic, as to be able to use .VBX controls}
INTERFACE
  USES OBJECTS,
       WINTYPES,
       OWINDOWS,
       VBAPI_;

  TYPE
    pTWIPS = ^TWIPS;
    TWIPS  = Longint;
    pColorREf = ^tColorRef;

  CONST
    vbs_TwipsPerInch   = 72{points}*20;
    vbs_ClassNameSep   = ':';

    vbm_First          = vbm__Base;
    vbm_Last           = vbm_DATA_METHOD;




    wmu_QueryVBControl = wm_User+100;
  TYPE
    tvbsErrorProc = procedure(num:Word; msg :pChar);

  CONST
    { override this to hqandle VBX error messages }
    vbsErrorMessage :tvbsErrorProc = nil;

  TYPE

    pVBControlCore = ^tVBControlCore;
    tVBControlProc = function{( control     :pVBControlCore;
                               hwnd        :HWND;
                               message     :Word;
                               wParam      :WORD;
                               lParam      :Longint)} :Longint;

       pvbsPropInfo  = ^tvbsPropInfo;
       tvbsPropInfo  = OBJECT(tObject)
          id            :Word;
          pszName       :lpStr;
          fl            :LongInt;      {PF_ flags}
          offsetData    :Byte;          { Offset into static structure}
          infoData      :Byte;          { 0 or _INFO value for bitfield        }
          dataDefault   :LongInt;      { 0 or _INFO value for bitfield}
          pszEnumList   :lpStr;          { For TYPE == DT_ENUM, this is
                                      a far ptr to a string containing
                                      all the values to be displayed
                                      in the popup enumeration listbox.
                                      Each value is an sz, with an
                                      empty sz indicated the end of list. }
          enumMax       :Byte;          {Maximum legal value for enum.}


          constructor init(vbxDataSeg :Word;  propId :Word);
          constructor copy( var propInfo :tvbsPropInfo);

          function    isStandard:Boolean;

          function    dataType:Word;
          function    dataSize:Word;
          function    isPropArray:Boolean;
       END;

       pvbsEventInfo  = ^tvbsEventInfo;
       tvbsEventInfo = OBJECT(tObject)
          id            :Word;
          pszName       :lpStr;
          cParms        :Word;
          cwParms       :Word;    { # words of parameters  }
          pParmTypes    :pChar;    { list of parameter types}
          pszParmProf   :lpStr;    { event parameter profile string}
          fl            :LongInt;        { EF_ flags}

          constructor init(vbxDataSeg :Word;  eventId :Word);
          constructor copy(var eventInfo :tvbsEventInfo);

          function    isStandard:Boolean;
       END;

    tVBControlCore = OBJECT(tWindow)
        _cursorInx       :Word;
        _cursor          :tHandle;


       constructor init(AParent: PWindowsObject; AnId: Integer; ATitle: PChar);
       constructor InitResource(AParent: PWindowsObject; ResourceID: Word);
       destructor  done;  virtual;


       function eventCount :Word; virtual;
       function propCount  :Word; virtual;

       function propIndex(name :pChar):Integer;    virtual;
       function propName(inx :Integer):pChar;      virtual;
       function propType(inx :Integer):Word;       virtual;
       function propFlags(inx :Integer):ULONG;     virtual;
       function isPropArray(inx :Integer):Boolean; virtual;

       function eventName(inx :Integer):pChar;     virtual;
       function eventIndex(name :pChar):Word;      virtual;

       function getProp(inx :Integer) :pvbsPropInfo;   virtual;
       function getEvent(inx :Integer) :pvbsEventInfo; virtual;

       function getPropValue(inx, arrI :Word; value :Pointer):Boolean;
       function setPropValue(inx, arrI :Word; value :Longint):Boolean;

       function getPropDataDefault(name :pChar; var value :Longint):Boolean;
       function modelFlags :ULONG;


       procedure loadPreHwndProps; virtual;
       function  eventFired(inx :Word; params :Pointer):Word;
       virtual;

       procedure paletteChanged; virtual;

       function YTwipsToPixels(Twips: TWIPS):Integer;
       function XTwipsToPixels(Twips: TWIPS):Integer;
       function YPixelsToTwips(Pixels: Integer): TWIPS;
       function XPixelsToTwips(Pixels: Integer): TWIPS;

       function visible :Boolean;
       function enabled :Boolean;

       function  getClassName :pChar; virtual;
       procedure getWindowClass(var class :TWNDCLASS); virtual;

       procedure defWndProc(var msg :tMessage); virtual;
       procedure defVBControlProc(var msg :tMessage); virtual;
       function  forwardMsgToVBX(msg, wParam :Word; lParam :Longint):Longint;
       procedure wmQueryVBControl(var msg :tMessage);
       virtual   wm_First+wmu_QueryVBControl;

    PRIVATE
      _controlDataSize :Word;
      _controlData     :pChar;
      _model           :Pointer;
      _flags           :Longint;


     { call default window procedure without forwarding to VBX }
     procedure overridenWndProc(var msg :tMessage);

     function _getPropValue(inx, arrI :Word; pdata :Pointer; messages :Boolean):Boolean;
     function _setPropValue(inx, arrI :Word; value :Longint; messages :Boolean):Boolean;


    END;


  function registerVBX(name :pChar):Integer;
  const
    vbserr_OK          =  0;
    vbserr_VBXNotFound = -1;
    vbserr_NotVBX      = -2;
    vbserr_CantInitVBX = -3;


  function derefHLSTR(hszStr :HLSTR):lpStr;
  function derefHSZ(hszStr :pChar):lpStr;

  function isLFlagSet(flags :Longint; test :Longint):Boolean;

IMPLEMENTATION
  USES  WIN87EM,
        WINPROCS,
        WIN31,
        STRINGS;


  CONST
    vbs_MaxStack        = 32000;
    vbs_StackFillByte   = $0C;
    vbs_StackSafetySize = 512;

    vbs_CallbackStackPos = $20;
    vbs_StackAllocFlags  = GMEM_FIXED or GMEM_ZEROINIT;
    vbs_StackBase        = vbs_MaxStack - vbs_StackSafetySize;

    vbs_JumpTableSize    = 90;

    vbs_MaxModels        = 128;
    nModels              : -1..vbs_MaxModels = 0;

    vbsPropSize          : array[dt_HSZ..dt_Hlstr] of Byte =
      (
      {dt_HSZ             } sizeOf(HSZ),
      {dt_SHORT           } sizeOf(Integer),
      {dt_LONG         } sizeOf(Longint),
      {dt_BOOL         } sizeOf(WordBool),
      {dt_COLOR        } sizeOf(tColorRef),
      {dt_ENUM         } sizeOf(Byte),
      {dt_REAL         } sizeOf(Single),
      {dt_XPOS         } sizeOf(Longint),
      {dt_XSIZE        } sizeOf(Longint),
      {dt_YPOS         } sizeOf(Longint),
      {dt_YSIZE        } sizeOf(Longint),
      {dt_PICTURE      } sizeOf(tHandle),
      {dt_HLSTR        } sizeOf(HLSTR)
      );

  TYPE
    pvbsReplacementStack = ^tvbsReplacementStack;
    tvbsReplacementStack = array[0..vbs_MaxStack] of Byte;

    pvbsCallback = ^tvbsCallback;
    tvbsCallBack  = procedure;
    tvbsJumpTable = array[0..vbs_JumpTableSize] of tFarProc;

  CONST

    vbsStackHandle   :tHandle              = 0;      { handle for GlobalAlloc }
    vbsStack         :pvbsReplacementStack = nil;    { a replacement stack }
    vbsSSegment      :Word                 = 0;      { Stack segment }
    vbsStackChanged  :Boolean              = FALSE;
                                                     { to replacement stack      }

  TYPE
       pPropArray = ^tPropArray;
       tPropArray = array[0..$FFFF div sizeOf(pvbsPropInfo)-1] of pvbsPropInfo;

       pEventArray = ^tEventArray;
       tEventArray = array[0..$FFFF div sizeOf(pvbsEventInfo)-1] of pvbsEventInfo;

       pvbsModel = ^tvbsModel;
       tvbsModel = OBJECT(tObject)
          dllInstance      :tHandle;
          usVersion        :Word;        {VB version used by control}
          fl               :LongInt;    { Bitfield structure}
          ctlproc          :tVBControlProc;
          fsClassStyle     :Word;         { window class style}
          flWndStyle       :LongInt;    {default window style}
          cbCtlExtra       :Word;        { # bytes alloc'd for HCtl structure}
          idBmpPalette     :Word;        { BITMAP id for tool palette}
          DefCtlName       :pChar;        {PSTR;     { default control name prefix}
          ClassName        :pChar;        {PSTR;        { Visual Basic class name}
          ParentClassName  :pChar;        {PSTR;    { Parent window class if subclassed}
          proplist         :pPropArray;    { Property list}
          eventlist        :pEventArray;{ Event list}
          nDefProp         :Byte;        { index of default property}
          nDefEvent        :Byte;        { index of default event}
          nValueProp       :Byte;        { Index of control value property}
          usCtlVersion     :Word;       {    Identifies the current version of
                                           the custom control. The values
                                           1 and 2 are reserved for custom
                                           controls created with VB 1.0 and
                                           VB 2.0.}
          eventCount       :Word;
          propCount        :Word;

          constructor init(vbxDataSeg :Word; dll :tHandle; var model :tModel);
          destructor  done; virtual;

          function  getClassName :pChar; virtual;
          procedure getWindowClass(var class :TWNDCLASS); virtual;

          function propIndex(name :pChar):Integer;
          function eventIndex(name :pChar):Integer;

          function getProp(inx :Integer) :pvbsPropInfo;
          function getEvent(inx :Integer) :pvbsEventInfo;

          function propType(inx :Integer) :Word;
          function propFlags(inx :Integer):ULONG;

          function getPropNamed(name :pChar)  :pvbsPropInfo;
          function getEventNamed(name :pChar) :pvbsEventInfo;

          function getPropWithId(id :Word) :pvbsPropInfo;
          function sumPropSize :Word;

          function getPropDataDefault(name :pChar; var value :Longint):Boolean;
       END;

  VAR
     Models        : array[0..vbs_MaxModels-1] of pvbsModel;


{$I STDPROP.INC }
{$I STDEVENT.INC}

  function isLFlagSet(flags :Longint; test :Longint):Boolean;
  begin
    isLFlagSet := 0 <> (flags and test)
  end;

  constructor tvbsModel.init(vbxDataSeg :Word; dll :tHandle;  var model :tModel);
  var pprops  :^Word;
      pevents :^Word;
      p       :^Word;
      i       :Word;
      procInst:tFarProc;
  begin
    inherited init;
    dllInstance        := dll;
    usVersion        := model.usVersion;
    fl               := model.fl;
    procInst         := makeProcInstance(model.ctlProc, hInstance);
    ctlproc          := tVBControlProc(model.ctlProc);
    fsClassStyle     := model.fsClassStyle;
    flWndStyle       := model.flWndStyle;
    cbCtlExtra       := model.cbCtlExtra;
    idBmpPalette     := model.idBmpPalette;
    DefCtlName       := Ptr(vbxDataSeg, model.defCtlName);
    ClassName        := Ptr(vbxDataSeg, model.className);
    ParentClassName  := Ptr(vbxDataSeg, model.parentClassName);
    proplist         := nil;
    eventlist          := nil;
    nDefProp         := model.nDefProp;
    nDefEvent        := model.nDefEvent;
    nValueProp       := model.nValueProp;
    usCtlVersion     := model.usCtlVersion;

    if model.proplist <> 0 then begin
      pprops := Ptr(vbxDataSeg, model.proplist);
      p := pprops;
      propCount := 0;
      while (p^ <> 0) and (p^ <> PPROPINFO_STD_LAST) do begin
        inc(propCount);
        inc(p);
      end;
      getMem(proplist, (propCount+1)*sizeOf(pvbsPropInfo));
      fillChar(proplist^, (propCount+1)*sizeOf(pvbsPropInfo), #0);
      p := pprops;
      i := 0;
      while (p^ <> 0) and (p^ <> PPROPINFO_STD_LAST) do begin
        if (not p^ >= 0) and (not p^ <= vbs_MaxStdProp) then
          proplist^[i] := new(pvbsPropInfo, copy(stdPropInfo[not p^]))
        else
          proplist^[i] := new(pvbsPropInfo, init(vbxDataSeg, p^));
        inc(p);
        inc(i);
      end;
    end;
    if model.eventlist <> 0 then begin
      pevents := Ptr(vbxDataSeg, model.eventlist);
      p := pevents;
      eventCount := 0;
      while (p^ <> 0) and (p^ <> PEVENTINFO_STD_LAST) do begin
        inc(eventCount);
        inc(p);
      end;
      getMem(eventlist, (eventCount+1)*sizeOf(pvbsEventInfo));
      fillChar(eventlist^, (eventCount+1)*sizeOf(pvbsEventInfo), #0);
      p := pevents;
      i := 0;
      while (p^ <> 0) and (p^ <> PEVENTINFO_STD_LAST) do begin
        if (not p^ >= 0) and (not p^ <= vbs_MaxStdProp) then
          eventlist^[i] := new(pvbsEventInfo, copy(stdEventInfo[not p^]))
        else
          eventlist^[i] := new(pvbsEventInfo, init(vbxDataSeg, p^));
        inc(p);
        inc(i);
      end;
    end
  end;

  destructor tvbsModel.done;
  var
    i :Integer;
  begin
    for i := 0 to propCount-1 do
      dispose(proplist^[i]);
    for i := 0 to eventCount-1 do
      dispose(eventlist^[i]);
    freeMem(proplist, (propCount+1)*sizeOf(pvbsPropInfo));
    freeMem(eventlist, (eventCount+1)*sizeOf(pvbsEventInfo));
    inherited done;
  end;

  function    tvbsModel.getClassName :pChar;
  const
     Max = 100;
     fullClassname  :array[0..Max] of Char = '';
  begin
      strLCopy(fullClassName, 'VBSIM:', Max);
      strLCat(fullClassName, className, Max);
      getClassName := fullClassName
  end;

  procedure   tvbsModel.getWindowClass(var class :TWNDCLASS);
  var
    value :Longint;
  begin
      if not getClassInfo(hInstance, getClassName, class) then begin
        { get parent's class data, default to BUTTON }
        if   (parentClassName = nil)
        or not getClassInfo(0, parentClassName, class) then begin
          fillChar(class, sizeOf(class),0);

          if not getClassInfo(0, 'Button', class) then
            vbsErrorMessage(0,'Control Initialization Failed');
        end;

        class.lpszClassName := getClassName;
        class.style         := class.style or fsClassStyle or cs_DblClks;
        class.hInstance     := hInstance;

        { these must be set from propertys }
        class.lpszMenuName  := nil;
        class.hIcon         := 0;
        class.hCursor       := 0;
        class.hbrBackGround := 0;

        if getPropDataDefault('MousePointer', value) then
          class.hCursor  := loadCursor(0, makeIntResource(value));


    end
  end;

  type pPointer = ^Pointer;
  function countPtrList(p :array of Pointer):Word;
  var count :Word;
  begin
    count := 0;
    while (p[count] <> nil) do
      inc(count);
    countPtrList := count
  end;

  function tvbsModel.sumPropSize :Word;
  var
     i    :Integer;
     size :Word;
  begin
    size := 0;
    if proplist <> nil then begin
      i := 0;
      while (proplist^[i] <> nil) do begin
        with propList^[i]^ do
          if not isStandard then
            inc(size, dataSize);
        inc(i)
      end
    end;
    sumPropSize := size;
  end;

  function tvbsModel.getProp(inx :Integer):pvbsPropInfo;
  begin
    if (inx < 0) or (inx > propCount) then
      getProp := nil
    else
      getProp := proplist^[inx]
  end;

  function tvbsModel.propType(inx :Integer) :Word;
  var
    prop :pvbsPropInfo;
  begin
    propType := 0;
    prop := getProp(inx);
    if prop <> nil then
      propType := prop^.dataType
  end;

  function tvbsModel.propFlags(inx :Integer) :ULONG;
  var
    prop :pvbsPropInfo;
  begin
    propFlags := 0;
    prop := getProp(inx);
    if prop <> nil then
      propFlags := prop^.fl
  end;

  function tvbsModel.getEvent(inx :Integer):pvbsEventInfo;
  begin
    if (inx < 0) or (inx > eventCount) then
      getEvent := nil
    else
      getEvent := eventlist^[inx]
  end;

  function tvbsModel.propIndex(name :pChar):Integer;
  var
     i :Integer;
  begin
    propIndex := -1;
    if proplist <> nil then begin
      i := 0;
      while (proplist^[i] <> nil) do
        if strComp(proplist^[i]^.pszName, name) = 0 then begin
          propIndex := i;
          break
        end
        else
          inc(i)
    end
  end;


  function tvbsModel.eventIndex(name :pChar):Integer;
  var
     i :Integer;
  begin
    eventIndex := -1;
    if eventList <> nil then begin
      i := 0;
      while (proplist^[i] <> nil) do
        if strComp(eventList^[i]^.pszName, name) = 0 then begin
          eventIndex := i;
          break
        end
        else
          inc(i)
    end
  end;


  function tvbsModel.getPropNamed(name :pChar)  :pvbsPropInfo;
  begin
    getPropNamed := getProp(propIndex(name))
  end;

  function tvbsModel.getPropWithId(id :Word) :pvbsPropInfo;
  var
     i :Integer;
  begin
    getPropWithId := nil;
    if proplist <> nil then begin
      i := 0;
      while (proplist^[i] <> nil) do
        if proplist^[i]^.id = id then begin
          getPropWithId := proplist^[i];
          break
        end
        else
          inc(i)
    end
  end;


  function tvbsModel.getEventNamed(name :pChar) :pvbsEventInfo;
  begin
    getEventNamed := getEvent(eventIndex(name))
  end;

  function tvbsModel.getPropDataDefault(name :pChar; var value :Longint):Boolean;
  var
    prop :pvbsPropInfo;
  begin
    prop := getPropNamed(name);
    if prop <> nil then begin
      value := prop^.dataDefault;
      getPropDataDefault := TRUE
    end
    else begin
      value := 0;
      getPropDataDefault := FALSE
    end
  end;

  constructor tvbsPropInfo.init(vbxDataSeg :Word; propId :Word);
  var
    propInfo :pPropInfo;
  begin
     propInfo := Ptr(vbxDataSeg, propId);
     inherited init;
     id            := propId;
     pszName       := Ptr(vbxDataSeg, propInfo^.npszName);
     fl            := propInfo^.fl;
     offsetData    := propInfo^.offsetData;
     infoData      := propInfo^.infoData;
     dataDefault   := propInfo^.dataDefault;
     pszEnumList   := Ptr(vbxDataSeg, propInfo^.npszEnumList);
     enumMax       := propInfo^.enumMax
  end;

  constructor tvbsPropInfo.copy(var propInfo :tvbsPropInfo);
  begin
    inherited init;
    Self := propInfo;
  end;

  function    tvbsPropInfo.isStandard:Boolean;
  begin
    isStandard := (not id >= 0) and (not id <= vbs_MaxStdProp)
  end;

  function tvbsPropInfo.dataType:Word;
  begin
    dataType := fl and pf_DataType
  end;

  function tvbsPropInfo.dataSize:Word;
  begin
    dataSize := vbsPropSize[dataType]
  end;


  function tvbsPropInfo.isPropArray:Boolean;
  begin
    isPropArray := isLFlagSet(fl, pf_fPropArray)
  end;


  constructor tvbsEventInfo.init(vbxDataSeg :Word; eventId :Word);
  var
    eventInfo :pEventInfo;
  begin
     id           := eventId;
     eventInfo    := Ptr(vbxDataSeg, eventId);
     pszName      := Ptr(vbxDataSeg, eventInfo^.npszName);
     cParms       := eventInfo^.cParms;
     cwParms      := eventInfo^.cwParms;
     pParmTypes   := Ptr(vbxDataSeg, eventInfo^.npParmTypes);
     pszParmProf  := Ptr(vbxDataSeg, eventInfo^.npszParmProf);
     fl           := eventInfo^.fl;
  end;

  constructor tvbsEventInfo.copy(var eventInfo :tvbsEventInfo);
  begin
    inherited init;
    Self := eventInfo;
  end;

  function tvbsEventInfo.isStandard:Boolean;
  begin
    isStandard := (not id >= 0) and (not id <= vbs_MaxStdEvent)
  end;


  procedure buildMessage(var m :tMEssage; hwnd :HWND; msg, wParam:Word; lParam :Longint);
  begin
    fillChar(m, sizeOf(m), 0);
    m.receiver := hwnd;
    m.message  := msg;
    m.wParam   := wParam;
    m.lParam   := lParam;
  end;


  function __RegisterModel(dataseg :Word; dllInstance :tHandle; var model:tModel):Boolean;
  export;
  begin
    if nModels >= vbs_MaxModels then
      __RegisterModel := FALSE
    else begin
      Models[nModels] := new(pvbsModel, init(dataSeg, dllInstance, model) );
      if (Models[nModels] <> nil) then begin
           inc(nModels);
           __RegisterModel := TRUE;
      end
    end
  end;


  function findModel(className :pChar) :pvbsModel;
  var
    i :Integer;
  begin
    findModel := nil;
    for i := 0 to Integer(nModels)-1 do
      if strComp(className, Models[i]^.className) = 0 then begin
        findModel := Models[i];
        break;
      end
  end;

  const
    tempStr :pChar = nil;
  function derefHLSTR(hszStr :HLSTR):lpStr;
  var   pstr    :pChar;
  begin
    pstr := nil;
    if hszStr <> nil then begin
      getMem(pstr, length(pString(hszStr)^)+1);
      if pstr <> nil then begin
        strPCopy(pstr, pString(hszStr)^);
        if tempStr <> nil then
          strDispose(tempStr);
        tempStr := pstr;
      end;
    end;
    derefHLSTR := pstr
  end;

  function derefHSZ(hszStr :pChar):lpStr;
  var   pstr    :pChar;
  begin
  pstr := nil;
    if hszStr <> nil then begin
      pstr := strNew(hszStr);
      if pstr <> nil then begin
        if tempStr <> nil then
          strDispose(tempStr);
        tempStr := pstr;
      end;
    end;
    derefHSZ := pstr
  end;

  { VISUAL BASIC SIMULATIONS }

  function vbsDerefControl(Control: pVBControlCore): Pointer;
  export;
  begin
    vbsDerefControl := control^._controlData;
  end;

  function vbsRegisterModel(HMod: THandle ; var Model: TModel ): Bool; far;
  assembler;
    asm
      push ds             { callers DS is first parameter }
      push hmod           { push rest of paramenters}
      les  di, model
      push es
      push di
      { now restore our data segment }
      { standard protocol for export routines,  AX = our DS    }
      mov  ax,  SEG @Data
      call __RegisterModel
    end;

  function vbsGetControlHwnd(Control: pVBControlCore): HWnd;
  export;
  begin
    vbsGetControlHwnd := control^.hwindow;
  end;

  function vbsGetHInstance: THandle;
  export;
  begin
    vbsGetHInstance := hInstance;
  end;

  function vbsGetControlModel(Control: pVBControlCore): LPModel;
  export;
  begin
    vbsGetControlModel := control^._model
  end;

  function vbsGetControlName(Control: pVBControlCore; lpszName: LPStr): LPStr;
  export;
  begin
    vbsGetControlName := control^.attr.title
  end;

  function vbsGetHwndControl(Wnd: HWnd): pVBControlCore;
  export;
  begin
    vbsGetHwndControl := Pointer(sendMessage(wnd, wmu_QueryVBControl, 0, 0))
  end;

  function vbsSendControlMsg(Control: pVBControlCore; Msg, WParam: Word; LParam: LongInt): LongInt;
  export;
  begin
    vbsSendControlMsg := sendMessage(control^.hwindow, msg, wParam, lParam);
  end;

  function vbsSuperControlProc(Control: pVBControlCore; Msg, WParam: Word; LParam: LongInt): LongInt;
  export;
  var m :tMessage;
  begin
    buildMessage(m, control^.hwindow, msg, wParam, lParam);
    control^.overridenWndProc(m);
    vbsSuperControlProc := m.result
  end;

  function vbsGetMode: Word;
  export;
  begin
    vbsGetMode := MODE_RUN
  end;

  function vbsRecreateControlHwnd(Control: pVBControlCore):Word;
  export;
  begin
     control^.destroy;
     if control^.create then
       vbsRecreateControlHwnd := 0
     else
       vbsRecreateControlHwnd := 1
  end;

  procedure vbsDirtyForm(Control: pVBControlCore);
  export;
  begin
  end;

  function vbsSetErrorMessage(error: Word; Str: LPStr): Word;
  export;
  begin
    vbsErrorMessage(error, str)
  end;

  procedure vbsGetAppTitle(Str: LPStr; cbMax: Word);
  export;
  begin
    strLCopy(str, application^.name, cbMax);
  end;

  function vbsDialogBoxParam(Instance: THandle; TemplateName: LPStr;
                                      DialogFunc: TFARPROC; lp: LongInt):Integer;
  export;
  begin
    vbsDialogBoxParam := dialogBoxParam(instance, templateName, getFocus, dialogFunc, lp)
  end;

{// Management of dynamically allocated strings}

  function vbsCreateHsz(Control: pVBControlCore; Str: LPStr): HSZ;
  export;
  begin
    vbsCreateHsz := HSZ(strNew(str))
  end;

  procedure vbsDestroyHsz(HSZStr: HSZ);
  export;
  begin
    strDispose(pChar(hszStr));
    if pChar(hszstr) = tempStr then
      tempStr := nil;
  end;

  function vbsDerefHsz(HSZStr: HSZ): LPStr;
  export;
  begin
    vbsDerefHsz := lpStr(hszStr)
  end;

  function vbsLockHsz(HSZStr: HSZ): LPStr;
  export;
  begin
    vbsLockHsz := lpStr(hszStr)
  end;

  procedure vbsUnlockHsz(HSZStr: HSZ);
  export;
  begin
  end;

{// Management of language strings}

  function vbsCreateHlstr(pb: Pointer; cbLen: Word): HLStr;
  export;
  var  ps :pString;
  begin
    if cblen > 255 then
      cbLen := 255;
    getMem(ps, cbLen+1);
    ps^[0] := Char(cbLen);
    move(pb^, ps^[1], cbLen);
    vbsCreateHlstr := hlStr(ps)
  end;

  procedure vbsDestroyHlstr(HStr: HLStr);
  export;
  begin
    disposeStr(pString(hstr))
  end;

  function vbsDerefHlstr(HStr: HLStr): LPStr;
  export;
  begin
    vbsDerefHlstr := derefHLSTR(hstr);
  end;

  function vbsGetHlstrLen(HStr: HLStr): Word;
  export;
  begin
     if hstr = nil then
       vbsGetHlstrLen := 0
     else
       vbsGetHlstrLen := length(pString(hStr)^)
  end;

  function vbsSetHlstr(var PHStr:hlStr; pb: Pointer; cbLen: Word): Word;
  export;
  var ps :pString;
  begin
      disposeStr(pString(phstr));
      phstr := HLSTR(newStr(strPas(pChar(pb))));
      if phstr <> nil then
        vbsSetHlstr := 0
      else
        vbsSetHlstr := 1
  end;

  {// Firing Basic event procedures}

  function vbsFireEvent(Control: pVBControlCore; IdEvent: Word; LPParams: Pointer): Word;
  export;
  var msg :Word;
  begin
    vbsFireEvent := control^.eventFired(idEvent, lpParams)
  end;

{// Control property access}

  function vbsGetControlProperty(Control: pVBControlCore; IdProp: Word; pData :Pointer): Word;
  export;
  begin
    control^._getPropValue(idProp, 0, pData, TRUE)
  end;

  function vbsSetControlProperty(Control: pVBControlCore; IdProp: Word; data :Longint): Err;
  export;
  begin
    control^._setPropValue(idProp, 0, data, TRUE)
  end;
{// Picture management functions}

  function vbsAllocPic(PntPic: PPIC): HPic; export;
  begin
    vbsAllocPic := 0
  end;

  procedure vbsFreePic(Pic: HPic); export;
  begin
  end;

  function vbsGetPic(Pic: HPic; PntPic: PPic): HPic; export;
  begin
    vbsGetPic := 0
  end;

  function vbsPicFromCF(PntHPic: Pointer; HData: THandle; WFormat: Word): Word;export;
  begin
    pWord(pntHpic)^ := 0;
    vbsPicFromCF := 1
  end;

  function vbsRefPic(Pic: HPic): HPic; export;
  begin
    vbsRefPic := 0
  end;

  {// File IO functions}

  function vbsReadFormFile(FormFile: HFormFile; pb: Pointer; cb: Word):Word;
  export;
  begin
  end;

  function vbsWriteFormFile(FormFile: HFormFile; pb: Pointer; cb: Word):Word;
  export;
  begin
  end;

  function vbsSeekFormFile(FormFile: HFormFile; OffSet: LongInt): LongInt;
  export;
  begin
  end;

  function vbsRelSeekFormFile(FormFile: HFormFile; OffSet: LongInt):LongInt;
  export;
  begin
  end;

  function vbsReadBasicFile(UsFileNo: Word; pb: Pointer; cb: Word):Word;
  export;
  begin
  end;

  function vbsWriteBasicFile(UsFileNo: Word; pb: Pointer; cb: Word):Word;
  export;
  begin
  end;

  {// Conversion functions}

  procedure getLogPixels(hwnd :tHandle; var x, y :Longint);
  var hdc  :tHandle;
  begin
    hdc  := getDC(hwnd);

    x := getDeviceCaps(hdc, LOGPIXELSX);
    y := getDeviceCaps(hdc, LOGPIXELSY);

    releaseDC(hwnd, hdc);
  end;

  function vbsYPixelsToTwips(Pixels: Integer): TWIPS;
  export;
  var xPixelsPerInch :Longint;
      yPixelsPerInch :Longint;
  begin
    getLogPixels(getFocus, xPixelsPerInch, yPixelsPerInch);
    vbsYPixelsToTwips := (Longint(pixels)*vbs_TwipsPerInch) div yPixelsPerInch;
  end;

  function vbsXPixelsToTwips(Pixels: Integer): TWIPS;
  export;
  var xPixelsPerInch :Longint;
      yPixelsPerInch :Longint;
  begin
    getLogPixels(getFocus, xPixelsPerInch, yPixelsPerInch);
    vbsXPixelsToTwips := (Longint(pixels)*vbs_TwipsPerInch) div xPixelsPerInch;
  end;

  function vbsYTwipsToPixels(Twips: TWIPS):Integer;
  export;
  var xPixelsPerInch :Longint;
      yPixelsPerInch :Longint;
  begin
    getLogPixels(getFocus, xPixelsPerInch, yPixelsPerInch);
    vbsYTwipsToPixels := Integer((twips*yPixelsPerInch) div vbs_TwipsPerInch);
  end;

  function vbsXTwipsToPixels(Twips: TWIPS):Integer;
  export;
  var xPixelsPerInch :Longint;
      yPixelsPerInch :Longint;
  begin
    getLogPixels(getFocus, xPixelsPerInch, yPixelsPerInch);
    vbsXTwipsToPixels := Integer((twips*xPixelsPerInch) div vbs_TwipsPerInch);
  end;


{// Ver 2.0 Functions}

  function vbsGetVersion: Word;
  export;
  begin
    vbsGetVersion := VB200_VERSION
  end;

  procedure vbsPaletteChanged(Control: pVBControlCore );
  export;
  begin
    control^.paletteChanged
  end;

  function vbsSetControlFlags(Control: pVBControlCore; mask: LongInt; value: LongInt ): LongInt;
  export;
  var
    oldFlags :Longint;
    hasPal   :Boolean;
  begin
    with control^ do begin
      oldFlags := _flags;
      _flags := (_flags and not mask) or (mask and value);
    end;
    vbsSetControlFlags := control^._flags;
    hasPal := isLFlagSet(mask and value, ctlflg_HasPalette);
    if hasPal or (hasPal <> isLFlagSet(mask and oldFlags, ctlflg_HasPalette)) then
      control^.paletteChanged
  end;

  function __vbsGetCapture: pVBControlCore;
  begin
    __vbsGetCapture := pVBControlCore(sendMessage(getCapture, wmu_QueryVBControl, 0, 0));
  end;

  function vbsGetCapture: pVBControlCore;
  export;
  begin
    vbsGetCapture := __vbsGetCapture
  end;

  procedure vbsSetCapture(Control: pVBControlCore );
  export;
  begin
    setCapture(control^.hwindow);
  end;

  procedure vbsReleaseCapture;
  export;
  begin
    if __vbsGetCapture <> nil then
      releaseCapture;
  end;

  procedure vbsMoveControl(Control: pVBControlCore; var Rect: TRect ; fRepaint: BOOL );
  export;
  begin
    moveWindow( control^.hwindow,
                rect.left, rect.top,
                rect.right-rect.left, rect.bottom-rect.top,
                fRepaint);
  end;

  procedure vbsGetControlRect(Control: pVBControlCore ;var Rect: TRect );
  export;
  begin
    getWindowRect(control^.hwindow, rect)
  end;

  procedure vbsGetRectInContainer(Control: pVBControlCore ;var Rect: TRect );
  export;
  var
    hdc :tHandle;
  begin
    getWindowRect(control^.hwindow, rect);
    if control^.parent <> nil then begin
      mapWindowPoints(0, control^.parent^.hwindow, rect, 2);
      hdc := getDC(control^.parent^.hwindow);
      dpToLp(hdc, rect, 2);
      releaseDC(control^.parent^.hwindow, hdc);
    end
  end;

  procedure vbsGetClientRect(Control: pVBControlCore ;var Rect: TRect );
  export;
  begin
    getClientRect(control^.hwindow, rect)
  end;

  procedure vbsClientToScreen(Control: pVBControlCore ;var Point: TPoint );
  export;
  begin
    clientToScreen(control^.hwindow, point)
  end;

  procedure vbsScreenToClient(Control: pVBControlCore;var Point: TPoint );
  export;
  begin
    screenToClient(control^.hwindow, point)
  end;

  function vbsIsControlVisible(Control: pVBControlCore ): BOOL;
  export;
  begin
    vbsIsControlVisible := control^.visible
  end;

  function vbsIsControlEnabled(Control: pVBControlCore ): BOOL;
  export;
  begin
    vbsIsControlEnabled := control^.enabled
  end;

  procedure vbsInvalidateRect(Control: pVBControlCore ;Rect: pRect ; fEraseBkGnd: BOOL );
  export;
  begin
      invalidateRect(control^.hwindow, rect, fEraseBkGnd)
  end;

  procedure vbsUpdateControl(Control: pVBControlCore );
  export;
  begin
    updateWindow(control^.hwindow)
  end;

  function vbsGetControl(Control: pVBControlCore ; gc: WORD ): pVBControlCore;
  export;
  begin
  end;

  procedure vbsZOrder(Control: pVBControlCore ; zorder: WORD );
  export;
  begin
    if zorder = ZORDER_FRONT then
      setWindowPos(control^.hwindow, HWND_TOP, 0, 0, 0,0, SWP_NOMOVE or SWP_NOSIZE)
    else if zorder = ZORDER_BACK then
      setWindowPos(control^.hwindow, HWND_BOTTOM, 0, 0, 0,0, SWP_NOMOVE or SWP_NOSIZE);
  end;

  function vbsCreateTempHlstr(pb: Pointer ; cbLen: Word ): HLStr;
  export;
  const s :String = '';
  begin
    s := strPas(pb);
    vbsCreateTempHlstr := hlStr(@s)
  end;

  function vbsDerefHlstrLen(HStr: HLStr ;var pCbLen: Word ): PChar;
  export;
  begin
     vbsDerefHlstrLen := derefHLSTR(hstr);
     pCBLen := 0;
     if hstr <> nil then
       pCbLen  := length(pString(hstr)^);
  end;

  function vbsDerefZeroTermHlstr(HStr: HLStr ): PChar;
  export;
  begin
    vbsDerefZeroTermHlstr := vbsDerefHLStr(hstr)
  end;

  function vbsGetHlstr(HStr: HLStr ; pb: Pointer ; cbLen: Word ): Word;
  export;
  begin
    strLCopy(pb, derefHLStr(hstr), cbLen);
    vbsGetHlstr := strLen(pb)
  end;

  function vbsResizeHlstr(HStr: HLStr ; newCbLen: Word ): Word;
  export;
  begin
    vbsResizeHlstr := 1
  end;

{// Management of language Variant data TYPE}

function vbsCoerceVariant(Variant: PVariant ; vtype: Integer ; lpData: Pointer ): Word;
export;
begin
  vbsCoerceVariant := 1
end;

function vbsGetVariantType(Variant: PVariant ): Integer;
export;
begin
  vbsGetVariantType := 0
end;

function vbsGetVariantValue(Variant: PVariant ; Value: PValue ): Integer;
export;
begin
  vbsGetVariantValue := 1
end;

function vbsSetVariantValue(Variant: PVariant ; vtype: Integer ; lpData: Pointer ): Word;
export;
begin
  vbsSetVariantValue := 1
end;

{// Management of language arrays}

function vbsArrayElement(VBArray: HAD ; cIndex: Integer ;var lpi: Integer ): Pointer;
export;
begin
  vbsArrayElement := nil
end;

function vbsArrayBounds(VBArray: HAD ; index: Integer ): LongInt;
export;
begin
  vbsArrayBounds := 0
end;

function vbsArrayElemSize(VBArray: HAD ): Word;
export;
begin
  vbsArrayElemSize := 0
end;

function vbsArrayFirstElem(VBArray: HAD ): Pointer;
export;
begin
  vbsArrayFirstElem := nil
end;

function vbsArrayIndexCount(VBArray: HAD ): Integer;
export;
begin
  vbsArrayIndexCount := 0
end;

  {// VB Error routines}

  procedure vbsRuntimeError(err: Word );
  export;
  begin
    vbsErrorMessage(err, '')
  end;

  var  FPSaveArea : Win87EmSaveArea;

  {// Floating-point stack save/restore utilities}
  function vbsCbSaveFPState(pb: Pointer ; cb: Word ): Word;
  export;
  begin
     __Win87EmSave(@FPSaveArea, sizeOf(FPSaveArea))
  end;

  procedure vbsRestoreFPState(pb: Pointer );
  export;
  begin
     __Win87EmRestore(@FPSaveArea, sizeOf(FPSaveArea))
  end;

{// Picture functions}
function vbsAllocPicEx(PntPic: PPIC ; usVersion: Word ): HPic;
export;
begin
end;
function vbsGetPicEx(Pic: HPic ; PntPic: PPIC ; usVersion: Word ): HPic;
export;
begin
end;
function vbsTranslateColor(Control: pVBControlCore ; Color: LongInt ): LongInt;
export;
begin
  vbsTranslateColor := RGBColor(color)
end;

{// Link Interface functions}

function vbsLinkPostAdvise(Control: pVBControlCore ): Word;
export;
begin
end;
function vbsPasteLinkOk(var phTriplet: THANDLE ; Control: pVBControlCore ): BOOL;
export;
begin
end;

{// Misc functions}
function vbsFormat(vtype: Integer ; lpData: Pointer ; lpszFmt: PChar ;
                    pb: Pointer ; cb: Word ): Integer;
export;
begin
  pb := nil
end;

{ VB 3.0 }
procedure vbsLinkMakeItemName(Control:pVBControlCore; lpszBuf: PChar);
export;
begin
  lpszBuf[0] := #0;
end;

function vbsGetDataSourceControl(Control: pVBControlCore; blsRegistered: Bool):pVBControlCore;
export;
begin
  vbsGetDataSourceControl := nil
end;

function vbsSeekBasicFile(usFileNo: Word; offset: LongInt): LongInt;
export;
begin
  vbsSeekBasicFile := 0
end;

function vbsRelSeekBasicFile(usFileNo: Word; offset: LongInt): LongInt;
export;
begin
  vbsRelSeekBasicFile := 0
end;

  function vbsDefControlProc(Control: pVBControlCore;Wnd: HWnd;
          Msg: Word; WParam: Word; LParam: LongInt): LongInt;
  export;
  var m :tMessage;
  begin
    buildMessage(m, control^.hwindow, msg, wParam, lParam);
    control^.defVBControlProc(m);
    vbsDefControlProc := m.result;
  end;

  constructor tVBControlCore.Init(AParent: PWindowsObject; AnId: Integer; ATitle: PChar);
  var
    className :pChar;
    wndName   :pChar;
    allOK     :Boolean;
    model     :pvbsModel;
    value     :Longint;
  begin
    _controlData := nil;
    allOk := TRUE;
    { parse ATitle into ClassName:WindowName, where : is vbs_ClassNameSep }
    className := strNew(aTitle);
    if className = nil then
      fail;

    wndName   := strScan(className, vbs_ClassNameSep);

    if (wndName <> nil) then begin
      wndName^ := #0;
      inc(wndName);
    end;

    _model := findModel(className);
    model  := _model;
    allOk := _model <> nil;

    if allOk then
      allOk := inherited init(aParent, {anId,} wndName);{, x, y, w, h);}

    if allOk then begin
      getMem(_controlData, model^.cbCtlExtra);
      allOk := _controlData <> nil;
      if allOk then
         fillChar(_controlData^, model^.cbCtlExtra, #0);
    end;
    if wndName <> nil then begin
      dec(wndName);
      wndName^ := vbs_ClassNameSep
    end;
    if not allOk then begin
      strDispose(className);
      fail;
    end;

    { start sending messages to the newly created control }
    if isLFlagSet(model^.fl, model_fInitMsg) then
      forwardMsgToVBX(vbm_Initialize, 0, 0);
    with attr do begin
      style := (model^.flWndStyle or ws_Child or ws_ClipSiblings or ws_Border or ws_Visible)
               and not (ws_Caption or ws_Disabled{or ws_Visible});
    end;

    _flags := 0;

    _cursor := 0;
    strDispose(className);
  end;

  constructor tVBControlCore.InitResource(AParent: PWindowsObject; ResourceID: Word);
  begin
    fail
  end;


  destructor tVBControlCore.done;
  begin
    freeMem(_controlData, pvbsModel(_model)^.cbCtlExtra);
    inherited done;
  end;


  function tVBControlCore.visible :Boolean;
  begin
    visible := isWindowVisible(hwindow)
  end;

  function tVBControlCore.enabled :Boolean;
  begin
    enabled := isWindowEnabled(hwindow)
  end;

  procedure tVBControlCore.defWndProc(var msg :tMessage);
  begin
    with msg do
      result := forwardMsgToVBX(message, wParam, lParam)
  end;

  procedure tVBControlCore.overridenWndProc(var msg :tMessage);
  begin
    inherited defWndProc(msg);
  end;

  procedure tVBControlCore.wmQueryVBControl(var msg :tMessage);
  begin
    msg.result := Longint(@self)
  end;

  procedure tVBControlCore.loadPreHwndProps;
  var
    i    :Integer;
  begin
    {
    for i := 0 to propCount do
        if isLFlagSet(propFlags(i), pf_fLoadMsg) then
          forwardMsgToVBX(vbm_LoadLoadProperty
    }
  end;


  function  tVBControlCore.getClassName :pChar;
  begin
    getClassName := pvbsModel(_model)^.getClassName
  end;

  function tVBControlCore.eventFired(inx :Word; params :Pointer):Word;
  begin
  end;

  procedure tVBControlCore.getWindowClass(var class :TWNDCLASS);
  var  vbxClass :tWNDCLASS;
  begin
    inherited getWindowClass(class);
    pvbsModel(_model)^.getWindowClass(vbxClass);

    {defaultProc      := vbxClass.lpfnWndProc;}

    class.style      := class.style or vbxClass.style;
    class.cbClsExtra := class.cbClsExtra + vbxClass.cbClsExtra;
    class.cbWndExtra := class.cbWndExtra + vbxClass.cbWndExtra;

    {class.hInstance  := vbxClass.hinstance;}

    { these should be set from properties }

    {
    class.hIcon          := vbxClass.hIcon;
    class.hCursor        := vbxClass.hCursor;
    }
    { class.hbrBackGround  := vbxClass.hBrbackground};
  end;

  function tVBControlCore.eventCount :Word;
  begin
    eventCount := pvbsModel(_model)^.eventCount
  end;

  function tVBControlCore.propCount  :Word;
  begin
    propCount := pvbsModel(_model)^.propCount
  end;


  function tVBControlCore.propIndex(name :pChar):Integer;
  begin
    propIndex := pvbsModel(_model)^.propIndex(name)
  end;

  function tVBControlCore.propName(inx :Integer):pChar;
  var
    prop :pvbsPropInfo;
  begin
     prop := pvbsModel(_model)^.getProp(inx);
     if prop <> nil then
       propName := prop^.pszName
     else
       propName := nil
  end;

  function tVBControlCore.propType(inx :Integer):Word;
  begin
    propType := pvbsModel(_model)^.propType(inx)
  end;

  function tVBControlCore.propFlags(inx :Integer):ULONG;
  begin
    propFlags := pvbsModel(_model)^.propFlags(inx)
  end;

  function tVBControlCore.isPropArray(inx :Integer):Boolean;
  var
    prop :pvbsPropInfo;
  begin
     prop := pvbsModel(_model)^.getProp(inx);
     if prop <> nil then
       isPropArray := prop^.isPropArray
     else
       isPropArray := FALSE
  end;

  function tVBControlCore.eventName(inx :Integer):pChar;
  var
    event : pvbsEventInfo;
  begin
     event := pvbsModel(_model)^.getEvent(inx);
     if event <> nil then
       eventName := event^.pszName
     else
       eventName := nil
  end;

  function tVBControlCore.eventIndex(name :pChar):Word;
  begin
     eventIndex := pvbsModel(_model)^.eventIndex(name);
  end;

  function tVBControlCore.getProp(inx :Integer) :pvbsPropInfo;
  begin
     getProp := pvbsModel(_model)^.getProp(inx);
  end;

  function tVBControlCore.getEvent(inx :Integer) :pvbsEventInfo;
  begin
     getEvent:= pvbsModel(_model)^.getEvent(inx);
  end;

  function tVBControlCore.getPropValue(inx, arrI :Word; value :Pointer):Boolean;
  begin
    getPropValue := _getPropValue(inx, arrI, value, TRUE)
  end;

  function tVBControlCore.setPropValue(inx, arrI :Word; value :Longint):Boolean;
  begin
    setPropValue := _setPropValue(inx, arrI, value, TRUE)
  end;

  procedure tVBControlCore.paletteChanged;
  begin
  end;

  function tVBControlCore.YTwipsToPixels(Twips: TWIPS):Integer;
  var xPixelsPerInch :Longint;
      yPixelsPerInch :Longint;
  begin
    getLogPixels(getFocus, xPixelsPerInch, yPixelsPerInch);
    YTwipsToPixels := Integer((twips*yPixelsPerInch) div vbs_TwipsPerInch);
  end;

  function tVBControlCore.XTwipsToPixels(Twips: TWIPS):Integer;
  var xPixelsPerInch :Longint;
      yPixelsPerInch :Longint;
  begin
    getLogPixels(getFocus, xPixelsPerInch, yPixelsPerInch);
    XTwipsToPixels := Integer((twips*xPixelsPerInch) div vbs_TwipsPerInch);
  end;

  function tVBControlCore.YPixelsToTwips(Pixels: Integer): TWIPS;
  var xPixelsPerInch :Longint;
      yPixelsPerInch :Longint;
  begin
    getLogPixels(getFocus, xPixelsPerInch, yPixelsPerInch);
    YPixelsToTwips := (Longint(pixels)*vbs_TwipsPerInch) div yPixelsPerInch;
  end;

  function tVBControlCore.XPixelsToTwips(Pixels: Integer): TWIPS;
  var xPixelsPerInch :Longint;
      yPixelsPerInch :Longint;
  begin
    getLogPixels(getFocus, xPixelsPerInch, yPixelsPerInch);
    XPixelsToTwips := (Longint(pixels)*vbs_TwipsPerInch) div xPixelsPerInch;
  end;



  function tVBControlCore._getPropValue(inx, arrI :Word; pdata :Pointer; messages :Boolean):Boolean;
  var
    prop    :pvbsPropInfo;
    arrData :tDataStruct;
    hdc     :THandle;
  begin
    _getPropValue := TRUE;
    prop := pvbsModel(_model)^.getProp(inx);
    if prop = nil then
      exit;
    _getPropValue := FALSE;
     if not prop^.isStandard then begin
        if isLFlagSet(prop^.fl, pf_fGetData)
        and not prop^.isPropArray then
           System.move(_controlData[prop^.offsetData], pdata^, prop^.dataSize)
     end
     else
       case prop^.id of
         ppropinfo_std_Caption,
         ppropinfo_std_Text:
           pLongint(pdata)^ := Longint(vbsCreateTempHlstr(attr.title, strLen(attr.title)));
         ppropinfo_std_Left:
           pTWIPS(pdata)^ := vbsXPixelsToTwips(attr.x);
         ppropinfo_std_Top:
           pTWIPS(pdata)^ := vbsYPixelsToTwips(attr.y);
         ppropinfo_std_Width:
           pTWIPS(pdata)^ := vbsXPixelsToTwips(attr.w);
         ppropinfo_std_Height:
           pTWIPS(pdata)^ := vbsYPixelsToTwips(attr.h);
         ppropinfo_std_ForeColor: begin
           hdc := getDC(hwindow);
           pColorRef(pdata)^ := getTextColor(hdc);
           releaseDC(hwindow, hdc);
         end;
         ppropinfo_std_BackColor:begin
           hdc := getDC(hwindow);
           pColorRef(pdata)^ := getBkColor(hdc);
           releaseDC(hwindow, hdc);
         end;
         ppropinfo_std_MousePointer:
           pLongint(pdata)^ := _cursorInx;
         ppropinfo_std_Enabled:
           pBool(pdata)^ := isWindowEnabled(hwindow);
         ppropinfo_std_Visible:
           pBool(pdata)^ := isWindowVisible(hwindow);
         ppropinfo_std_Parent:
           pWord(pdata)^ := getParent(hwindow);
       else
         _getPropValue := FALSE
       end;
    if messages and isLFlagSet(prop^.fl, pf_fGetMsg) then begin
      if not prop^.isPropArray then
         forwardMsgToVBX(vbm_GetProperty, inx, Longint(pdata))
      else begin
         with arrData do begin
           data   := 0;
           cindex := 1;
           index[0].data     := arrI;
           index[0].dataType := dt_Short;
         end;
         forwardMsgToVBX(vbm_GetProperty, inx, Longint(@arrData));
         System.move(arrData.data, pdata^, prop^.dataSize)
      end
    end
  end;

  function tVBControlCore._setPropValue(inx, arrI:Word; value :Longint; messages :Boolean):Boolean;
  type
    pHLSTR = ^pString ;
  var
    prop    :pvbsPropInfo;
    arrData :tDataStruct;
    hdc     :THandle;
  begin
    _setPropValue := FALSE;
    prop := pvbsModel(_model)^.getProp(inx);
    if prop = nil then
      exit;

    if messages and isLFlagSet(prop^.fl, pf_fSetCheck)
    and (0 <> forwardMsgToVBX(vbm_CheckProperty, inx, value)) then
      exit;

    _setPropValue := TRUE;
    if not prop^.isStandard then begin
         if isLFlagSet(prop^.fl, pf_fSetData) and not prop^.isPropArray then begin
            case prop^.dataType of
              dt_HLSTR:
                vbsDestroyHLSTR(HLSTR(_controlData[prop^.offsetData]));
              dt_HSZ:
                vbsDestroyHSZ(HSZ(_controlData[prop^.offsetData]));
            end;
            System.move(value, _controlData[prop^.offsetData], prop^.dataSize)
         end

      end
      else
        case prop^.id of
          ppropinfo_std_Caption:
            setCaption(derefHLSTR(HLSTR(value)));
          ppropinfo_std_Left:
            attr.x := vbsXTwipsToPixels(value);
          ppropinfo_std_Top:
            attr.y := vbsYTwipsToPixels(value);
          ppropinfo_std_Width:
            attr.w := vbsXTwipsToPixels(value);
          ppropinfo_std_Height:
            attr.h := vbsYTwipsToPixels(value);
          ppropinfo_std_ForeColor: begin
            hdc := getDC(hwindow);
            setTextColor(hdc, value);
            releaseDC(hwindow, hdc);
            invalidateRect(hwindow, nil, TRUE)
          end;
          ppropinfo_std_BackColor: begin
            hdc := getDC(hwindow);
            setBkColor(hdc, value);
            releaseDC(hwindow, hdc);
            invalidateRect(hwindow, nil, TRUE)
          end;
          ppropinfo_std_MousePointer: begin
            _cursorInx := Word(value);
            _cursor := loadCursor(0, makeIntResource(_cursorInx));
          end;
          ppropinfo_std_Enabled:
            enableWindow(hwindow, value <> 0);
         ppropinfo_std_Visible:
           if Bool(value) then
             show(sw_Show)
           else
             show(sw_Hide);
        else
          _setPropValue := FALSE
        end;

      if messages {and isLFlagSet(prop^.fl, pf_fSetMsg)} then begin
        if not prop^.isPropArray then
          forwardMsgToVBX(vbm_SetProperty, inx, value)
        else begin
           with arrData do begin
             if prop^.dataType = dt_HLSTR then
               data := Longint(derefHLSTR(HLSTR(value)) )
             else
               data   := value;
             cindex := 1;
             index[0].data     := arrI;
             index[0].dataType := dt_Short;
           end;
           forwardMsgToVBX(vbm_SetProperty, inx, Longint(@arrData))
        end
      end
  end;

  function tVBControlCore.getPropDataDefault(name :pChar; var value :Longint):Boolean;
  begin
    getPropDataDefault := pvbsModel(_model)^.getPropDataDefault(name, value)
  end;

  function tVBControlCore.modelFlags :ULONG;
  begin
    modelFlags := pvbsModel(_model)^.fl
  end;


  procedure tVBControlCore.defVBControlProc(var msg :tMessage);
  var
     model :pvbsModel;
     ps    :tPaintStruct;
     hdc   :tHandle;
     hbr   :tHandle;
     rct   :tRect;
     inx   :Integer;
     color :tColorRef;
  begin
    model := _model;
    case msg.message of
      wm_NCCreate: begin
        overridenWndProc(msg);
      end;
      vbm_Created:
        if not isLFlagSet(model^.fl, model_fInvisAtRun) then
          show(sw_Show);
      vbm_CheckProperty:
         msg.result := 0;
      vbm_GetProperty:
         if _getPropValue(msg.wParam, 0, Pointer(msg.lParam), FALSE) then
           msg.result := 0;
      vbm_SetProperty:
         if _setPropValue(msg.wParam, 0, msg.lParam, FALSE) then
           msg.result := 0;
      vbm_First..vbm_Last:
         msg.result := 0;
    else
        overridenWndProc(msg);
    end
  end;

  procedure __performVBCallback; assembler;
   {$I VBJMPTBL.INC }
  asm
    or   bx, bx
    jnz  @@otherFuncs
    jmp   vbsRegisterModel
 @@otherFuncs:
    cmp  bx, vbs_JumpTableSize*4
    jbe  @@doJump
    jmp  vbsRuntimeError
  @@doJump:
    { standard protocol for calling exported functions }
    mov  ax, SEG @Data                    { put our data segment on AX         }
    mov  es, ax
    jmp  [dword ptr es:jumpTable+bx]      { jump to address of call back       }
  end;


  function testChangeStack(var change:Boolean) :Boolean;
  var
      pdataseg  :pWord;
      pcallback :pLongint;
  begin
    if vbsStackChanged then
      change := FALSE
    else begin
      change := TRUE;
      vbsStackChanged := TRUE;

     { place a verifiable value in the replacement stack, for overruns }
      fillChar(vbsStack^, sizeOf(vbsStack^), vbs_StackFillByte);
      {save address of our data segment here }
      pdataSeg  := pWord(@vbsStack^[vbs_CallbackStackPos-2]);
      pdataseg^ := DSEG;

     { place address of VBX callbak in specific stack offset just like VB does }
      pcallback  := pLongint(@vbsStack^[vbs_CallbackStackPos]);
      pcallback^ := Longint(@__performVBCallback);
    end;
    testChangeStack := change
  end;

  function testRestoreStack(var changed:Boolean) :Boolean;
  begin
    if not changed then
      testRestoreStack := FALSE
    else begin
      testRestoreStack := TRUE;
      vbsStackChanged := FALSE
    end;
    changed := FALSE
  end;


  function registerVBX(name :pChar):Integer;
  type
       tInitCC = procedure;
  var
       procAddr    :tFarProc;
       initcc      :tInitCC;
       dllInstance :tHandle;
       changeStk    :Boolean;
  begin
    dllInstance := loadLibrary(name);
    if dllInstance = 0 then begin
      registerVBX := vbserr_VBXNotFound;
      exit;
    end;

    procAddr := getProcAddress(dllInstance, 'VBINITCC');
    if procAddr = nil then begin
       registerVBX := vbserr_NotVBX;
       exit
    end;


    procaddr := makeProcInstance(procAddr, hInstance);
    if procaddr = nil then begin
      registerVBX := vbserr_CantInitVBX;
      exit;
    end;

    initcc   := tInitCC(procAddr);
    asm push ds end;
    if testChangeStack(changeStk) then
       switchStackTo(vbsSSegment, vbs_StackBase, vbs_StackSafetySize);

    initcc;

    if testRestoreStack(changeStk) then
       switchStackBack;
    asm pop ds end;

    freeProcInstance(procAddr);
    registerVBX := vbserr_OK;
  end;

  function tVBControlCore.forwardMsgToVBX(msg, wParam :Word; lParam :Longint):Longint;
  const
     ctlProc :tVBControlProc = nil;
     result  :Longint        =   0;
  var
     changeStk :Boolean; { this call replaced the stack }
     model     :pvbsModel;
     control   :pVBControlCore;
  begin
      control  := @Self;
      result   := 0;
      asm
        les  di, [dword ptr control]
        push es
        push di
        push [es:di].tVBControlCore.hWindow
        push [msg]
        push [wparam]
        push [word ptr lparam+2]
        push [word ptr lparam]
      end;
      model := control^._model;
      ctlProc := model^.ctlProc;
      if testChangeStack(changeStk) then begin
        switchStackTo(vbsSSegment, vbs_StackBase, vbs_StackSafetySize);
        result := ctlProc{(control, hwindow, msg, wParam, lParam)};
        switchStackBack;
        testRestoreStack(changeStk)
      end
      else
        result := model^.ctlProc{(control, hwindow, msg, wParam, lParam)};
      forwardMsgToVBX := result;
  end;


  CONST
     exitSave :Pointer = nil;

  procedure endvbsim; far;
  var
    i :Integer;
  begin
    for i := 0 to nModels-1 do
      freeLibrary(Models[i]^.dllInstance);
    globalUnlock(vbsStackHandle);
    globalFree(vbsStackHandle);

    exitProc := exitSave;
  end;

  procedure defaultError(num :Word; msg :pChar); far;
  begin
    runError(num)
  end;


  procedure initvbsim;
  var
    n :Integer;
  begin
     vbsErrorMessage := defaultError;
     { allocate a new replacement stack and initialize it  }
     vbsStackHandle := globalAlloc(vbs_StackAllocFlags, sizeOf(tvbsReplacementStack));
     if vbsStackHandle = 0 then begin
       vbsErrorMessage(0, 'Initialization Failed')
     end;
     vbsStack := pvbsReplacementStack(globalLock(vbsStackHAndle));
     if vbsStack = nil then begin
       globalFree(vbsStackHandle);
       vbsErrorMessage(0, 'Initialization Failed')
     end;

     if ofs(vbsStack^) <> 0 then begin
       { won't work, so abort }
       globalUnlock(vbsStackHandle);
       globalFree(vbsStackHandle);
       vbsErrorMessage(0, 'Initialization Failed')
     end;



     { record its segment and simulatad stack pointer position }
     vbsSSegment := seg(vbsStack^);


     exitSave := exitProc;
     exitProc := @endVBSim;
  end;

BEGIN
  initvbsim;
END.