**************************************
* Program: VFP_OLE.PRG
* Visual FoxPro 5 OLE DLL
**************************************
DEFINE CLASS VFP_OLE_Server AS CONTAINER OLEPUBLIC
Procedure Init
* The Procedure INIT is automatically
* executed when the DLL is loaded.
Set Talk Off
Set Safe Off
On Error Do Ole_Err With Error(),Lineno(),;
Message(),Program()
Set Exclusive Off
Set Null On
*****************************************
*-- If CPDIALOG is ON and a DBF that was
*-- created without a CodePage is opened,
*-- the CodePage dialog box will confront
*-- the user.
*****************************************
SET CPDIALOG OFF
*
Set Reprocess To 1
*
* Move FoxPro main screen way off to the
* bit-bucket so it won't be seen if
* it's made visible.
Move Window Screen To -1000,-1000
Modify Window Screen Title "VFP OLE"
Hide Window Screen
EndProc
Procedure SetDir
Parameter cDir
Set Default to (m.cDir)
EndProc
Function ExeSql
Parameter cSql
Private nRecs,i,cFile,cFileSrc,cFullPath,;
cDestpath,IsVFPFile,;
cDbfFileName,nHandle
lIsVFPFile = .F.
cFullPath = Set('FullPath')
*
* Show main VFP window so File
* dialog box will be visible
* if VFP can't find a file that's
* needed for the SQL command.
*
Show Window Screen
*
*-- Execute SQL Statement --*
*
cSql = AllTrim(m.cSql)
&cSql
*
Hide Window Screen
*
nRecs = _Tally
*
Set FullPath On
cFileSrc = DBF()
Use
**************************************
*-- Check TableType.
*-- If Type Is Visual FoxPro,
*-- convert to Fox2x.
**************************************
nHandle = FOpen(m.cFileSrc)
If nHandle <> -1
lIsVFPFile = (FGets(m.nHandle,1)=Chr(48))
=FClose(m.nHandle)
Endif
Use (m.cFileSrc) Exclusive
cDestPath = left(dbf(),rat('\',dbf()))
If m.lIsVFPFile
*-- Convert result To Fox2x format --*
cFile = 'T'+right(sys(3),7)
Copy To (m.cDestPath+m.cFile) Type Fox2x
Use
Erase (m.cFileSrc)
If File(Left(m.cFileSrc,;
Len(m.cFileSrc)-4)+'.FTP')
Erase (Left(m.cFileSrc,;
Len(m.cFileSrc)-4)+'.FTP')
Endif
Rename (m.cDestPath+m.cFile+'.DBF') ;
TO (m.cFileSrc)
If File(m.cDestPath+m.cFile+'.FPT')
Rename (m.cDestPath+m.cFile+'.FPT');
TO (Left(m.cFileSrc,;
Len(m.cFileSrc)-4)+'.FTP')
Endif
Use (m.cFileSrc) Exclusive
Endif
*-- Restore FullPath setting --*
Set FullPath &cFullPath
**-- Return Result Record Count --**
Return (m.nRecs)
EndFunc
Procedure IndexOn
**-- Create Index Tags --*
Parameter cDBF,cKey,cTag,lDeleteTags
Use (m.cDBF) EXCLUSIVE In 0 Alias IndexDBF
Select IndexDBF
If m.lDeleteTags
DELETE TAG ALL
Endif
INDEX ON &cKey TAG &cTag
USE
EndProc
Procedure SetPath
Parameter cPath
Set Path To (m.cPath)
EndProc
Procedure FoxCommand
Parameter cCMD
&cCMD
EndProc
Function FoxFunction
Parameter cFunc
Private Rtn
Rtn = Eval(m.cFunc)
Return (m.Rtn)
EndFunc
ENDDEFINE
Procedure Ole_Err
**-- Handle DLL internal errors --**
Parameter nErr,nLine,cMessage,cPRG
IF (m.nErr=1707)
*-- CDX not present, OK to Retry --*
Retry
Else
MessageBox( m.cMessage+Chr(13)+Chr(13)+;
'Error# '+str(m.nErr,5)+Chr(13)+;
'At Line#'+Str(m.nLine,5)+Chr(13)+;
'In '+m.cPrg+chr(13)+Chr(13)+;
'See File:OLE_ERR.txt for details.';
,16,'ERROR in VFP_OLE.DLL Module')
*
*-- Dump memory and file Status to text file.
*
Create Cursor OleError (ErrText M(10))
List Status NoConsole To File OLE_STAT.TMP
List Memory Like * NoConsole To File OLE_MEM.TMP
Append Blank
Replace ErrText With ;
Replicate('*',80)+Chr(13)+Chr(10)+;
DTOC(Date())+' '+Time()+;
Chr(13)+Chr(10)+;
PadC(' STATUS ',80,'*')+;
Chr(13)+Chr(10)
Append Memo ErrText From OLE_STAT.TMP
Replace ErrText With Chr(13)+Chr(10)+;
PadC(' MEMORY ',80,'*')+;
Chr(13)+Chr(10) Addi
Append Memo ErrText From OLE_MEM.TMP
Replace ErrText With Chr(13)+Chr(10)+;
PadC('-- End Error --',80,'*')+;
Chr(13)+Chr(10) Addi
If File('OLE_ERR.txt')
Copy Memo ErrText To OLE_ERR.txt Addi
Else
Copy Memo ErrText To OLE_ERR.txt
Endif
Erase OLE_STAT.TMP
Erase OLE_MEM.TMP
*
Close Data
*-- Cancel causes Delphi or VB to raise an
*-- error.
Hide Window Screen
*-- The CANCEL command causes Delphi
*-- to be able to trap the error.
Cancel
Endif
EndProc
*:EOF(VFP_OLE.PRG)
|