CHANGELOG: 2002-02-16 17:00 UTC+0500 Jorge A. Giraldo <jgiraldo@col2.telecom.com.co>
This commit is contained in:
Jorge Alberto Giraldo Salazar
84
harbour/contrib/delphi/hbdll/bld_sdll.bat
Normal file
84
harbour/contrib/delphi/hbdll/bld_sdll.bat
Normal file
@@ -0,0 +1,84 @@
|
||||
rem Self contained Harbour DLL, original idea and research Antonio Linares
|
||||
rem
|
||||
rem $Id$
|
||||
rem
|
||||
@ECHO OFF
|
||||
CLS
|
||||
|
||||
if A%1 == A GOTO :SINTAX
|
||||
if NOT EXIST %1.prg GOTO :NOEXIST
|
||||
|
||||
ECHO Compiling...
|
||||
|
||||
set hdir=c:\hb-dev\harbour
|
||||
set bcdir=c:\borland\bcc55\bin
|
||||
|
||||
%bcdir%\bcc32 -c -D__EXPORT__ -I..\..\..\include -L..\lib ..\..\..\source\vm\maindll.c
|
||||
|
||||
rem Files to integrate harbour DLL to Delphi
|
||||
%bcdir%\bcc32 -c -D__EXPORT__ -I..\..\..\include -L..\lib macrcall.c
|
||||
%hdir%\bin\harbour -n -w errorsys
|
||||
%bcdir%\bcc32 -c -D__EXPORT__ -I..\..\..\include -L..\lib errorsys.c
|
||||
|
||||
%hdir%\bin\harbour %1 /b /n /i..\include;%hdir%\include /w /p %2 %3 > clip.log
|
||||
@type clip.log
|
||||
IF ERRORLEVEL 1 PAUSE
|
||||
IF ERRORLEVEL 1 GOTO EXIT
|
||||
|
||||
echo -O2 -I%hdir%\include %1.c > b32.bc
|
||||
%bcdir%\bcc32 -M -c @b32.bc
|
||||
:ENDCOMPILE
|
||||
|
||||
IF EXIST %1.rc %bcdir%\brc32 -r %1
|
||||
|
||||
echo c0d32.obj + > b32.bc
|
||||
echo %1.obj+errorsys.obj+maindll.obj+macrcall.obj, + >> b32.bc
|
||||
echo %1.dll, + >> b32.bc
|
||||
echo %1.map, + >> b32.bc
|
||||
rem echo ..\lib\FiveH.lib ..\lib\FiveHC.lib + >> b32.bc
|
||||
echo %hdir%\lib\rtl.lib + >> b32.bc
|
||||
echo %hdir%\lib\vm.lib + >> b32.bc
|
||||
echo %hdir%\lib\gtwin.lib + >> b32.bc
|
||||
echo %hdir%\lib\lang.lib + >> b32.bc
|
||||
echo %hdir%\lib\macro.lib + >> b32.bc
|
||||
echo %hdir%\lib\rdd.lib + >> b32.bc
|
||||
echo %hdir%\lib\dbfntx.lib + >> b32.bc
|
||||
echo %hdir%\lib\dbfcdx.lib + >> b32.bc
|
||||
echo %hdir%\lib\debug.lib + >> b32.bc
|
||||
echo %hdir%\lib\common.lib + >> b32.bc
|
||||
echo %hdir%\lib\pp.lib + >> b32.bc
|
||||
|
||||
rem Uncomment these two lines to use Advantage RDD
|
||||
rem echo %hdir%\lib\rddads.lib + >> b32.bc
|
||||
rem echo ..\lib\Ace32.lib + >> b32.bc
|
||||
|
||||
echo %bcdir%\lib\import32.lib + >> b32.bc
|
||||
echo %bcdir%\lib\cw32.lib + >> b32.bc
|
||||
echo %bcdir%\lib\psdk\odbc32.lib, >> b32.bc
|
||||
IF EXIST %1.res echo %1.res >> b32.bc
|
||||
%bcdir%\ilink32 -Tpd -aa -L\borland\bcc55\lib -L\borland\bcc55\lib\PSDK @b32.bc
|
||||
|
||||
rem delete temporary files
|
||||
@del %1.c
|
||||
@del %1.il?
|
||||
|
||||
IF ERRORLEVEL 1 GOTO LINKERROR
|
||||
ECHO * self contained DLL successfully built
|
||||
GOTO EXIT
|
||||
ECHO
|
||||
|
||||
:LINKERROR
|
||||
rem if exist meminfo.txt notepad meminfo.txt
|
||||
rem PAUSE * Linking errors *
|
||||
GOTO EXIT
|
||||
|
||||
:SINTAX
|
||||
ECHO SYNTAX: Build [Program] {-- No especifiques la extensi½n PRG
|
||||
ECHO {-- Don't specify .PRG extension
|
||||
GOTO EXIT
|
||||
|
||||
:NOEXIST
|
||||
ECHO The specified PRG %1 does not exist
|
||||
|
||||
:EXIT
|
||||
|
||||
17
harbour/contrib/delphi/hbdll/easypath.dpr
Normal file
17
harbour/contrib/delphi/hbdll/easypath.dpr
Normal file
@@ -0,0 +1,17 @@
|
||||
{*
|
||||
* $id$
|
||||
*}
|
||||
|
||||
program EasyPath;
|
||||
|
||||
uses
|
||||
Forms,
|
||||
Main in 'Main.pas' {Main_FRM};
|
||||
|
||||
{$R *.RES}
|
||||
|
||||
begin
|
||||
Application.Initialize;
|
||||
Application.CreateForm(TMain_FRM, Main_FRM);
|
||||
Application.Run;
|
||||
end.
|
||||
204
harbour/contrib/delphi/hbdll/errorsys.prg
Normal file
204
harbour/contrib/delphi/hbdll/errorsys.prg
Normal file
@@ -0,0 +1,204 @@
|
||||
/*
|
||||
* $Id$
|
||||
*/
|
||||
|
||||
/*
|
||||
* Harbour Project source code:
|
||||
* The default error handler
|
||||
*
|
||||
* Copyright 1999 Antonio Linares <alinares@fivetech.com>
|
||||
* www - http://www.harbour-project.org
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU General Public License as published by
|
||||
* the Free Software Foundation; either version 2, or (at your option)
|
||||
* any later version.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU General Public License
|
||||
* along with this software; see the file COPYING. If not, write to
|
||||
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
|
||||
*
|
||||
* As a special exception, the Harbour Project gives permission for
|
||||
* additional uses of the text contained in its release of Harbour.
|
||||
*
|
||||
* The exception is that, if you link the Harbour libraries with other
|
||||
* files to produce an executable, this does not by itself cause the
|
||||
* resulting executable to be covered by the GNU General Public License.
|
||||
* Your use of that executable is in no way restricted on account of
|
||||
* linking the Harbour library code into it.
|
||||
*
|
||||
* This exception does not however invalidate any other reasons why
|
||||
* the executable file might be covered by the GNU General Public License.
|
||||
*
|
||||
* This exception applies only to the code released by the Harbour
|
||||
* Project under the name Harbour. If you copy code from other
|
||||
* Harbour Project or Free Software Foundation releases into a copy of
|
||||
* Harbour, as the General Public License permits, the exception does
|
||||
* not apply to the code that you add in this way. To avoid misleading
|
||||
* anyone as to the status of such modified files, you must delete
|
||||
* this exception notice from them.
|
||||
*
|
||||
* If you write modifications of your own for Harbour, it is your choice
|
||||
* whether to permit this exception to apply to your modifications.
|
||||
* If you do not wish that, delete this exception notice.
|
||||
*
|
||||
*/
|
||||
|
||||
#include "common.ch"
|
||||
#include "error.ch"
|
||||
|
||||
PROCEDURE ErrorSys
|
||||
|
||||
ErrorBlock( { | oError | DefError( oError ) } )
|
||||
|
||||
RETURN
|
||||
|
||||
STATIC FUNCTION DefError( oError )
|
||||
LOCAL cMessage
|
||||
LOCAL cDOSError
|
||||
|
||||
LOCAL aOptions
|
||||
LOCAL nChoice
|
||||
|
||||
LOCAL n
|
||||
|
||||
// By default, division by zero results in zero
|
||||
IF oError:genCode == EG_ZERODIV
|
||||
RETURN 0
|
||||
ENDIF
|
||||
|
||||
// Set NetErr() of there was a database open error
|
||||
IF oError:genCode == EG_OPEN .AND. ;
|
||||
oError:osCode == 32 .AND. ;
|
||||
oError:canDefault
|
||||
NetErr( .T. )
|
||||
RETURN .F.
|
||||
ENDIF
|
||||
|
||||
// Set NetErr() if there was a lock error on dbAppend()
|
||||
IF oError:genCode == EG_APPENDLOCK .AND. ;
|
||||
oError:canDefault
|
||||
NetErr( .T. )
|
||||
RETURN .F.
|
||||
ENDIF
|
||||
|
||||
cMessage := ErrorMessage( oError )+Chr(13)
|
||||
IF ! Empty( oError:osCode )
|
||||
cDOSError := "(DOS Error " + LTrim( Str( oError:osCode ) ) + ")"
|
||||
ENDIF
|
||||
|
||||
/* RETRY OPTIONS NOT AVAILABLE RIGHT NOW
|
||||
COMMENTED OUT ONLY FOR DELPHI INTEGRATION
|
||||
|
||||
// Build buttons
|
||||
|
||||
aOptions := {}
|
||||
|
||||
// AAdd( aOptions, "Break" )
|
||||
AAdd( aOptions, "Quit" )
|
||||
|
||||
IF oError:canRetry
|
||||
AAdd( aOptions, "Retry" )
|
||||
ENDIF
|
||||
|
||||
IF oError:canDefault
|
||||
AAdd( aOptions, "Default" )
|
||||
ENDIF
|
||||
|
||||
// Show alert box
|
||||
|
||||
nChoice := 0
|
||||
WHILE nChoice == 0
|
||||
|
||||
IF Empty( oError:osCode )
|
||||
|
||||
nChoice := Alert( cMessage, aOptions )
|
||||
ELSE
|
||||
nChoice := Alert( cMessage + ";" + cDOSError, aOptions)
|
||||
ENDIF
|
||||
|
||||
ENDDO
|
||||
|
||||
IF ! Empty( nChoice )
|
||||
DO CASE
|
||||
CASE aOptions[ nChoice ] == "Break"
|
||||
Break( oError )
|
||||
CASE aOptions[ nChoice ] == "Retry"
|
||||
RETURN .T.
|
||||
CASE aOptions[ nChoice ] == "Default"
|
||||
RETURN .F.
|
||||
ENDCASE
|
||||
ENDIF
|
||||
|
||||
*/
|
||||
|
||||
// "Quit" selected
|
||||
|
||||
IF ! Empty( oError:osCode )
|
||||
cMessage += " " + cDOSError+Chr(13)
|
||||
ENDIF
|
||||
|
||||
// QOut() /// dgh - Temporary to keep DOS prompt from overwriting message.
|
||||
// QOut( cMessage )
|
||||
|
||||
n := 2
|
||||
WHILE ! Empty( ProcName( n ) )
|
||||
/* CHANGED */
|
||||
cMessage += "Called from " + ProcName( n ) + ;
|
||||
"(" + AllTrim( Str( ProcLine( n++ ) ) ) + ")"+Chr(13)
|
||||
|
||||
// QOut("Called from " + ProcName( n ) + ;
|
||||
// "(" + AllTrim( Str( ProcLine( n++ ) ) ) + ")")
|
||||
ENDDO
|
||||
|
||||
MSGBOX( cMessage ) // Windows MessageBox
|
||||
|
||||
/// For some strange reason, the DOS prompt gets written on the first line
|
||||
/// *of* the message instead of on the first line *after* the message after
|
||||
/// the program quits, unless the screen has scrolled. - dgh
|
||||
QUIT
|
||||
|
||||
RETURN .F.
|
||||
|
||||
// [vszakats]
|
||||
|
||||
STATIC FUNCTION ErrorMessage( oError )
|
||||
LOCAL cMessage
|
||||
|
||||
// start error message
|
||||
cMessage := iif( oError:severity > ES_WARNING, "Error", "Warning" ) + " "
|
||||
|
||||
// add subsystem name if available
|
||||
IF ISCHARACTER( oError:subsystem )
|
||||
cMessage += oError:subsystem()
|
||||
ELSE
|
||||
cMessage += "???"
|
||||
ENDIF
|
||||
|
||||
// add subsystem's error code if available
|
||||
IF ISNUMBER( oError:subCode )
|
||||
cMessage += "/" + LTrim( Str( oError:subCode ) )
|
||||
ELSE
|
||||
cMessage += "/???"
|
||||
ENDIF
|
||||
|
||||
// add error description if available
|
||||
IF ISCHARACTER( oError:description )
|
||||
cMessage += " " + oError:description
|
||||
ENDIF
|
||||
|
||||
// add either filename or operation
|
||||
DO CASE
|
||||
CASE !Empty( oError:filename )
|
||||
cMessage += ": " + oError:filename
|
||||
CASE !Empty( oError:operation )
|
||||
cMessage += ": " + oError:operation
|
||||
ENDCASE
|
||||
|
||||
RETURN cMessage
|
||||
128
harbour/contrib/delphi/hbdll/macrcall.c
Normal file
128
harbour/contrib/delphi/hbdll/macrcall.c
Normal file
@@ -0,0 +1,128 @@
|
||||
/*
|
||||
* $Id$
|
||||
*/
|
||||
|
||||
/*
|
||||
* Harbour Project source code:
|
||||
*
|
||||
* Macro processing requested from Delphi and setting callbacks
|
||||
* to interact with Delphi
|
||||
*
|
||||
* Copyright 2002 Jorge A. Giraldo S. <jgiraldo@col2.telecom.com.co>
|
||||
* <jorgeagiraldo@hotmail.com>
|
||||
* www - http://www.harbour-project.org
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU General Public License as published by
|
||||
* the Free Software Foundation; either version 2, or (at your option)
|
||||
* any later version.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU General Public License
|
||||
* along with this software; see the file COPYING. If not, write to
|
||||
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
|
||||
*
|
||||
* As a special exception, the Harbour Project gives permission for
|
||||
* additional uses of the text contained in its release of Harbour.
|
||||
*
|
||||
* The exception is that, if you link the Harbour libraries with other
|
||||
* files to produce an executable, this does not by itself cause the
|
||||
* resulting executable to be covered by the GNU General Public License.
|
||||
* Your use of that executable is in no way restricted on account of
|
||||
* linking the Harbour library code into it.
|
||||
*
|
||||
* This exception does not however invalidate any other reasons why
|
||||
* the executable file might be covered by the GNU General Public License.
|
||||
*
|
||||
* This exception applies only to the code released by the Harbour
|
||||
* Project under the name Harbour. If you copy code from other
|
||||
* Harbour Project or Free Software Foundation releases into a copy of
|
||||
* Harbour, as the General Public License permits, the exception does
|
||||
* not apply to the code that you add in this way. To avoid misleading
|
||||
* anyone as to the status of such modified files, you must delete
|
||||
* this exception notice from them.
|
||||
*
|
||||
* If you write modifications of your own for Harbour, it is your choice
|
||||
* whether to permit this exception to apply to your modifications.
|
||||
* If you do not wish that, delete this exception notice.
|
||||
*
|
||||
*/
|
||||
|
||||
#define HB_OS_WIN_32_USED
|
||||
|
||||
#include "hbvm.h"
|
||||
#include "hbapiitm.h"
|
||||
#include "hbstack.h"
|
||||
|
||||
#if defined(HB_OS_WIN_32)
|
||||
|
||||
// Function pointer type
|
||||
typedef long (__stdcall *CallBackFuncType)(const char* message);
|
||||
|
||||
// Setter function
|
||||
HB_EXPORT __stdcall void SetCallBack(CallBackFuncType fun);
|
||||
|
||||
char * HB_EXPORT __stdcall MacroCall( char * sParam )
|
||||
{
|
||||
char *szFunc = "MacroCall";
|
||||
|
||||
PHB_DYNS pDynSym = hb_dynsymFindName( szFunc ); /* The PRG function to use */
|
||||
|
||||
if( pDynSym )
|
||||
{
|
||||
|
||||
hb_vmPushSymbol( pDynSym->pSymbol );
|
||||
hb_vmPushNil();
|
||||
hb_vmPushString( sParam, strlen( sParam ) );
|
||||
|
||||
hb_vmFunction( 1 ); /* as we receive one parameter */
|
||||
|
||||
return hb_stack.Return.item.asString.value;
|
||||
|
||||
}
|
||||
else
|
||||
return "error ...";
|
||||
|
||||
}
|
||||
|
||||
static CallBackFuncType cbfun = 0;
|
||||
void __stdcall SetCallBack(CallBackFuncType fun)
|
||||
{
|
||||
CallBackFuncType oldfun = cbfun;
|
||||
cbfun = fun;
|
||||
return oldfun;
|
||||
}
|
||||
|
||||
HB_FUNC( CALLBACK )
|
||||
{
|
||||
long result = 0;
|
||||
|
||||
if (cbfun != 0)
|
||||
{
|
||||
|
||||
result = cbfun( hb_parc( 1 ) );
|
||||
}
|
||||
else
|
||||
{
|
||||
MessageBox( NULL, //HWINDOW of the window that owns the message box
|
||||
"CallBack failed under MacrCall.c" , //Text
|
||||
"Warning" ,//Title
|
||||
MB_OK | MB_ICONINFORMATION );//Bit mask flags
|
||||
}
|
||||
|
||||
hb_retl( result ); // QUESTION: If you can make this to return a char pointer
|
||||
// being interpreted correctly by Delphi,
|
||||
// please inform me, I'm all ears, thank you.
|
||||
}
|
||||
|
||||
HB_FUNC( MSGBOX )
|
||||
{
|
||||
MessageBox( 0, hb_parc( 1 ), "Warning", 0 );
|
||||
}
|
||||
|
||||
#endif
|
||||
150
harbour/contrib/delphi/hbdll/main.pas
Normal file
150
harbour/contrib/delphi/hbdll/main.pas
Normal file
@@ -0,0 +1,150 @@
|
||||
{*
|
||||
* $id$
|
||||
*}
|
||||
|
||||
{*
|
||||
* Harbour Project source code:
|
||||
*
|
||||
* Copyright 2002 Jorge A. Giraldo S. <jgiraldo@col2.telecom.com.co>
|
||||
* <jorgeagiraldo@hotmail.com>
|
||||
* www - http://www.harbour-project.org
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU General Public License as published by
|
||||
* the Free Software Foundation; either version 2, or (at your option)
|
||||
* any later version.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU General Public License
|
||||
* along with this software; see the file COPYING. If not, write to
|
||||
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
|
||||
*
|
||||
* As a special exception, the Harbour Project gives permission for
|
||||
* additional uses of the text contained in its release of Harbour.
|
||||
*
|
||||
* The exception is that, if you link the Harbour libraries with other
|
||||
* files to produce an executable, this does not by itself cause the
|
||||
* resulting executable to be covered by the GNU General Public License.
|
||||
* Your use of that executable is in no way restricted on account of
|
||||
* linking the Harbour library code into it.
|
||||
*
|
||||
* This exception does not however invalidate any other reasons why
|
||||
* the executable file might be covered by the GNU General Public License.
|
||||
*
|
||||
* This exception applies only to the code released by the Harbour
|
||||
* Project under the name Harbour. If you copy code from other
|
||||
* Harbour Project or Free Software Foundation releases into a copy of
|
||||
* Harbour, as the General Public License permits, the exception does
|
||||
* not apply to the code that you add in this way. To avoid misleading
|
||||
* anyone as to the status of such modified files, you must delete
|
||||
* this exception notice from them.
|
||||
*
|
||||
* If you write modifications of your own for Harbour, it is your choice
|
||||
* whether to permit this exception to apply to your modifications.
|
||||
* If you do not wish that, delete this exception notice.
|
||||
*
|
||||
*}
|
||||
|
||||
unit Main;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
|
||||
StdCtrls, Buttons, ComCtrls;
|
||||
|
||||
type
|
||||
TMain_FRM = class(TForm)
|
||||
BitBtn1: TBitBtn;
|
||||
ProgressBar1: TProgressBar;
|
||||
procedure BitBtn1Click(Sender: TObject);
|
||||
private
|
||||
{ Private declarations }
|
||||
public
|
||||
{ Public declarations }
|
||||
end;
|
||||
|
||||
|
||||
var
|
||||
Main_FRM: TMain_FRM;
|
||||
oApplication : TApplication;
|
||||
|
||||
type
|
||||
CallBackFuncType = function (mesg: PChar): integer; stdcall;
|
||||
|
||||
procedure SetCallBack(cbfunc: CallBackFuncType); stdcall;
|
||||
external 'MyProg' name 'SetCallBack';
|
||||
|
||||
function MacroCall( pParam : pchar ) : pchar; stdcall;
|
||||
external 'MyProg' name 'MacroCall';
|
||||
|
||||
function h( sParam : String ) : variant;
|
||||
|
||||
implementation
|
||||
|
||||
{$R *.DFM}
|
||||
|
||||
procedure TMain_FRM.BitBtn1Click(Sender: TObject);
|
||||
begin
|
||||
ProgressBar1.Position := 0;
|
||||
ShowMessage( h(' MakeIndex("..\..\..\TESTS\TEST", "ZIP") ') );
|
||||
|
||||
end;
|
||||
|
||||
function h( sParam : String ) : variant;
|
||||
Var
|
||||
sRtnVal,
|
||||
sType,
|
||||
sResult : String;
|
||||
begin
|
||||
sRtnVal := MacroCall( PChar(sParam) );
|
||||
sType := Copy(sRtnVal,1,1);
|
||||
sResult := Copy(sRtnVal,2,Length(sRtnVal)-1);
|
||||
|
||||
// Changes string result to the expected type
|
||||
if sType = 'C' then // is character or string
|
||||
result := sResult
|
||||
else
|
||||
if sType = 'I' then // integer
|
||||
result := StrToInt(sResult)
|
||||
else
|
||||
if sType = 'F' then // float
|
||||
result := StrToFloat(sResult)
|
||||
else
|
||||
if sType = 'D' then // date
|
||||
result := StrToDate(sResult)
|
||||
else
|
||||
if sType = 'L' then // boolean
|
||||
if sResult = 'True' then
|
||||
result := true
|
||||
else
|
||||
result := false;
|
||||
|
||||
end;
|
||||
|
||||
function ReceiveCallBack(mesg: PChar): integer; stdcall;
|
||||
const
|
||||
nCallsMade : integer = 0;
|
||||
begin
|
||||
Main_FRM.ProgressBar1.Position := StrToInt(String(mesg));
|
||||
oApplication.ProcessMessages;
|
||||
Inc(nCallsMade);
|
||||
// The answer our Harbour program expects.
|
||||
// Callbackresult is a Harbour Public variable
|
||||
// that is requested when expecting some answer.
|
||||
// h(' CallBackResult := "NOANSWER" ');
|
||||
result := 0;
|
||||
end;
|
||||
|
||||
Initialization
|
||||
begin
|
||||
SetCallBack(ReceiveCallBack);
|
||||
oApplication := Application;
|
||||
end;
|
||||
|
||||
end.
|
||||
113
harbour/contrib/delphi/hbdll/myprog.prg
Normal file
113
harbour/contrib/delphi/hbdll/myprog.prg
Normal file
@@ -0,0 +1,113 @@
|
||||
/*
|
||||
* $Id$
|
||||
*/
|
||||
|
||||
/*
|
||||
* Harbour Project source code:
|
||||
*
|
||||
* Macro processing requested from Delphi and setting callbacks
|
||||
* to interact with Delphi
|
||||
*
|
||||
* Copyright 2002 Jorge A. Giraldo S. <jgiraldo@col2.telecom.com.co>
|
||||
* <jorgeagiraldo@hotmail.com>
|
||||
* www - http://www.harbour-project.org
|
||||
*
|
||||
* This program is free software; you can redistribute it and/or modify
|
||||
* it under the terms of the GNU General Public License as published by
|
||||
* the Free Software Foundation; either version 2, or (at your option)
|
||||
* any later version.
|
||||
*
|
||||
* This program is distributed in the hope that it will be useful,
|
||||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
* GNU General Public License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU General Public License
|
||||
* along with this software; see the file COPYING. If not, write to
|
||||
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||
* Boston, MA 02111-1307 USA (or visit the web site http://www.gnu.org/).
|
||||
*
|
||||
* As a special exception, the Harbour Project gives permission for
|
||||
* additional uses of the text contained in its release of Harbour.
|
||||
*
|
||||
* The exception is that, if you link the Harbour libraries with other
|
||||
* files to produce an executable, this does not by itself cause the
|
||||
* resulting executable to be covered by the GNU General Public License.
|
||||
* Your use of that executable is in no way restricted on account of
|
||||
* linking the Harbour library code into it.
|
||||
*
|
||||
* This exception does not however invalidate any other reasons why
|
||||
* the executable file might be covered by the GNU General Public License.
|
||||
*
|
||||
* This exception applies only to the code released by the Harbour
|
||||
* Project under the name Harbour. If you copy code from other
|
||||
* Harbour Project or Free Software Foundation releases into a copy of
|
||||
* Harbour, as the General Public License permits, the exception does
|
||||
* not apply to the code that you add in this way. To avoid misleading
|
||||
* anyone as to the status of such modified files, you must delete
|
||||
* this exception notice from them.
|
||||
*
|
||||
* If you write modifications of your own for Harbour, it is your choice
|
||||
* whether to permit this exception to apply to your modifications.
|
||||
* If you do not wish that, delete this exception notice.
|
||||
*
|
||||
*/
|
||||
|
||||
#Include 'HbClass.ch'
|
||||
|
||||
MEMVAR CallBackResult
|
||||
|
||||
FUNCTION MakeIndex( cFileName, cField )
|
||||
PUBLIC CallBackResult := ''
|
||||
|
||||
Use (cFileName) Alias FIL
|
||||
Index on &(cField) to (cFileName) EVAL IndexStatus() EVERY LastRec()/10
|
||||
Close FIL
|
||||
RETURN 'The file '+cFileName+' has been indexed'
|
||||
|
||||
FUNCTION IndexStatus
|
||||
LOCAL cCompleted := LTrim( Str(Int((RecNo()/LastRec()) * 100)) ), nSeconds
|
||||
D(cCompleted)
|
||||
|
||||
nSeconds := Seconds() // Let's make this thing to go slowly
|
||||
WHILE nSeconds+1 >= Seconds()
|
||||
END
|
||||
|
||||
RETURN .T.
|
||||
|
||||
//---------------------------------------//
|
||||
// Library functions //
|
||||
//---------------------------------------//
|
||||
|
||||
FUNCTION D( cString )
|
||||
CallBack( cString )
|
||||
RETURN CallBackResult
|
||||
|
||||
FUNCTION MacroCall( cString )
|
||||
LOCAL xMacroResult, cRtnType, cRtnVal
|
||||
|
||||
cRtnType := ValType( xMacroResult := &(cString) )
|
||||
|
||||
// Well, if memory is like a string, why not to use strings
|
||||
// for any type of vars?... ok, ok, I know. :-)
|
||||
|
||||
Do Case
|
||||
Case cRtnType = 'C'
|
||||
cRtnVal := 'C'+xMacroResult
|
||||
Case cRtnType = 'N'
|
||||
If Int(xMacroResult) = xMacroResult
|
||||
cRtnVal := 'I'+AllTrim(Str(xMacroResult,,0))
|
||||
Else
|
||||
cRtnVal := 'F'+AllTrim(Str(xMacroResult))
|
||||
EndIf
|
||||
Case cRtnType = 'L'
|
||||
cRtnVal := 'L'+If(xMacroResult,'True','False')
|
||||
Case cRtnType = 'D'
|
||||
cRtnVal := 'D'+DtoC(xMacroResult)
|
||||
OtherWise
|
||||
cRtnVal := NIL // NOTE: If Delphi doesn't expect a result, returning any result
|
||||
// will corrupt Delphi's memory. So this is set to NIL.
|
||||
EndCase
|
||||
|
||||
RETURN cRtnVal
|
||||
|
||||
5
harbour/contrib/delphi/hbdll/start.bat
Normal file
5
harbour/contrib/delphi/hbdll/start.bat
Normal file
@@ -0,0 +1,5 @@
|
||||
rem Makes our PRG to be a DLL, from an Antonio's idea an research
|
||||
rem
|
||||
rem $Id$
|
||||
rem
|
||||
Call bld_sdll myprog
|
||||
Reference in New Issue
Block a user