Creating an OLE Server DLL with Harbour to be Called from Other Languages

[Jeff Stone]

Having previously created a .DLL with Harbour to offer xbase functionality to programs written in other languages, I resumed work on converting my VFP DLL code to Harbour.  However, this code creates an OLE Server which is a .DLL that is registered.  So, I wanted to keep the same functionality to minimize changes to our C++ calling programs.  After reviewing Przemyslaw's OLE Server examples, I created the following code that enables calling programs to open a .DBF file, retrieve the values of variables in the current record, skip records, and close the DBF.  This code is easier to construct than the previous unregistered .DLL as no C code is needed. Please note the passing back of String variables to languages like C has to be done with care to avoid memory issues which can occur when passing back a string to C in excess of the C char pointers allocated memory.

I hope this is helpful to someone.

Regards,

Jeff

**************************************************

HbrOLEServer.PRG code for .DLL

/****
  Example of Harbour code for an OLE Server to open a DBF file(s) with assigned alias,
  get field values, close DBF, and more from any language that can access an OLE Server

  Excuse the VFP code 'translated' to Harbour as I'm converting a VFP DLL to Harbour
*****/
#define ETIHBR  1
#IFDEF ETIHBR
 #require hbwin
 #require common
 #require inkey
 #translate .NULL. => NIL
 #translate WshShell.Run => WshShell:Run
 #translate GETE(<cString>) => GETENV(<cString>)
 #translate THIS. => ::
 #translate SYS(5) => diskname()+":\"
 #include <dbinfo.ch>
 #include <hbclass.ch>

 /* remove outcomment of next line for debug purpose */
 //#define DEBUG 1

 #define CLS_Name  "HBRimport"
 #define CLS_ID    "{466AC7B2-35D7-4509-B909-C3C2F8FDBABC}"
#ENDIF

PROCEDURE DllMain()

   /* Initialize OLE server ID and name.
    * win_oleServerInit() should be executed from DllMain()
    */
   win_oleServerInit( CLS_ID, CLS_Name, HBRimport():new() )

RETURN

*********************************************************
CREATE CLASS HBRimport
 request  DBFCDX, DBFFPT
 RDDSETDEFAULT("DBFCDX")
 SET DBFLOCKSCHEME TO DB_DBFLOCK_VFP
 **set system to make dbf files more VFP compatible
 hb_rddinfo(RDDI_TABLETYPE,DB_DBF_VFP)

 HIDDEN:
   VAR TAXDIR    INIT  ""
   VAR TEMPLTDIR INIT  ""
   VAR cCurrentPath INIT ""
   VAR mTOTCAPPMT   INIT 0
   VAR mNETCAPPMT   INIT 0
   VAR mEXSCAPPMT   INIT 0

 EXPORTED:
   METHOD setcentury
   METHOD initdirs
   METHOD setcurrentpath(lcPath)
   METHOD usefile(lcname, laliasname)
   METHOD get(laliasname, lcfieldname)
   METHOD skiprec(laliasname, numskip)
   METHOD closefile(laliasname)
ENDCLASS

Method setcentury() CLASS HBRimport
  set century on    &&just as a precaution
  && need to set exact on --- not sure why we never turned it on before, but seeks won't work correctly - AS 5/29/15
  set exact on
return

METHOD initdirs() CLASS HBRimport
  THIS.TAXDIR = GETE("TAXDIR")
  THIS.TEMPLTDIR = GETE("TEMPLTDIR")
  if len(rtrim(THIS.TEMPLTDIR)) = 0
    THIS.TEMPLTDIR = "D:\TEMPLATE\"   &&for jeff
  endif
  if len(rtrim(THIS.TAXDIR)) < 5
    THIS.TAXDIR = "E:\BONY\"
  endif
Return

METHOD setcurrentpath(lcPath) CLASS HBRimport
lcOldPath = SYS(5) + CURDIR()
IF !EMPTY(lcPath)
#IFNDEF ETIHBR
   cd (lcPath)
#ELSE
   ft_chdir(lcPath)
#ENDIF
   THIS.cCurrentPath = SYS(5) + CURDIR()
ELSE
   THIS.cCurrentPath = lcOldPath
ENDIF
RETURN lcOldPath

METHOD usefile(lcname, laliasname) CLASS HBRimport
if !file(lcname)
 return 'N'
endif
select 0
use (lcname) alias (laliasname)
return 'Y'

METHOD get(laliasname, lcfieldname) CLASS HBRimport
select (laliasname)
**RETURN eval(lcfieldname)
RETURN &lcfieldname

METHOD skiprec(laliasname, numskip) CLASS HBRimport
select (laliasname)
skip numskip
**messagebox(laliasname+str(recno(),5))
if eof() .or. bof()
 RETURN "Y"
endif
RETURN "N"

METHOD closefile(laliasname) CLASS HBRimport
select (laliasname)
use
return

.DLL Compiling command lines:

set PATHSAVE=%PATH%
set PATH=C:\hb32\comp\mingw\bin
SET HB_INSTALL_PREFIX=c:\hb32
C:\hb32\bin\hbmk2.exe -hbdynvm -gtgui -st HbrOLEServer.prg  hbolesrv.hbc hbnf.hbc
set PATH=%PATHSAVE%

Command to register the .DLL

regsvr32 HbrOLEServer.dll

TestHbrOLESvr.vbs code to test calling the .DLL

SET oObject = CreateObject( "HBRimport")

 oObject.initdirs
 oObject.setcurrentpath

 'specify the file the file you want to open and assign an alias
 oObject.usefile "Existing.DBF", "xalias"

 'now specify the field you want to retrieve from the current record
 'I'm checking out the field 'COMP_ID'
 xfld = oObject.get("xalias", "COMP_ID")
 MsgBox xfld

 'let's skip one record and look at the value of the same field in the next record
 oObject.skiprec "xalias",1
 xfld = oObject.get("xalias", "COMP_ID")
 MsgBox xfld

 'Close the DBF
 oObject.closefile "xalias"