Delphi7通过VB6之COM对象调用PowerBASIC写的DLL功能

Delphi7通过VB6之COM对象调用PowerBASIC写的DLL功能。标题挺长，其实目标很简单，就是在Delphi7中使用PowerBASIC的MKI/CVI, MKS/CVS, MKD/CVD，并顺便加入CRC16检验函数，再进行16进制高低字节调整，方便在VB6、Delphi、Lazarus等环境下利用Modbus协议传送指令和数据时，进行十进制数的浮点转换和数据接收校验。我写的只是一个方法，其实用算法实现也并不十分复杂，但总觉得应该让曾经精典的老古懂们能做点事情，不希望职场上那样只要年龄大了就弃了不招不用的做法。

 分三步走：

1.  用PowerBASIC写基本DLL
2.  用VB6写COM组件
3.  用Delphi7写界面验证程序

一、用PowerBASIC写基本DLL

PowerBASIC兼容VB6最好，甚至许多功能完胜VB6，而且QBASIC有的功能它基本上都保留了，只是随着VB6的淡出而停止了前行。如果用现在语言的功能衡量它们，它们确实老了，但在工控领域里还是有许多用武之地的，比如工厂一般使用的总线方面，Modbus在国内比较普及，即使有了TCP也只是从Modbus ASCII或Modbus RTU变成了Modbus TCP，所以小而精的东西在这方面比大而复杂的东西更受青睐。PowerBASIC写DLL很简单，DLL入口出口不用管，写自己的功能函数并EXPORT即可。

下面的MBFIEEE32PD.BAS是用PowerBASIC写的(由代码时都找不到选哪个了，就选VB.NET吧)

'MBFIEEE32PD.BAS
'===============================================================================
'
'  Generic DLL Template for PowerBASIC for Windows
'  Copyright (c) 1997-2011 PowerBASIC, Inc.
'  All Rights Reserved.
'
'  LIBMAIN function Purpose:
'
'    User-defined function called by Windows each time a DLL is loaded into,
'    and unloaded from, memory. In 32-bit Windows, LibMain is called each
'    time a DLL is loaded by an application or process.  Your code should
'    never call LibMain explicitly.
'
'    hInstance is the DLL instance handle.  This handle is used by the
'    calling application to identify the DLL being called.  To access
'    resources in the DLL, this handle will need to be stored in a global
'    variable.  Use the GetModuleHandle(BYVAL 0&) to get the instance
'    handle of the calling EXE.
'
'    fdwReason specifies a flag indicating why the DLL entry-point
'    (LibMain) is being called by Windows.
'
'    lpvReserved specifies further aspects of the DLL initialization
'    and cleanup.  If fdwReason is %DLL_PROCESS_ATTACH, lpvReserved is
'    NULL (zero) for dynamic loads and non-NULL for static loads.  If
'    fdwReason is %DLL_PROCESS_DETACH, lpvReserved is NULL if LibMain
'    has been called by using the FreeLibrary API call and non-NULL if
'    LibMain has been called during process termination.
'
' Return
'
'    If LibMain is called with %DLL_PROCESS_ATTACH, your LibMain function
'    should return a zero (0) if any part of your initialization process
'    fails or a one (1) if no errors were encountered.  If a zero is
'    returned, Windows will abort and unload the DLL from memory. When
'    LibMain is called with any other value than %DLL_PROCESS_ATTACH, the
'    return value is ignored.
'
'===============================================================================#COMPILER PBWIN 10
#COMPILE DLL#INCLUDE ONCE "Win32api.inc"GLOBAL ghInstance AS DWORD'-------------------------------------------------------------------------------
' Main DLL entry point called by Windows...
'
FUNCTION LIBMAIN (BYVAL hInstance   AS LONG, _BYVAL fwdReason   AS LONG, _BYVAL lpvReserved AS LONG) AS LONGSELECT CASE fwdReasonCASE %DLL_PROCESS_ATTACH'Indicates that the DLL is being loaded by another process (a DLL'or EXE is loading the DLL).  DLLs can use this opportunity to'initialize any instance or global data, such as arrays.ghInstance = hInstanceFUNCTION = 1   'success!'FUNCTION = 0   'failure!  This will prevent the EXE from running.CASE %DLL_PROCESS_DETACH'Indicates that the DLL is being unloaded or detached from the'calling application.  DLLs can take this opportunity to clean'up all resources for all threads attached and known to the DLL.FUNCTION = 1   'success!'FUNCTION = 0   'failure!CASE %DLL_THREAD_ATTACH'Indicates that the DLL is being loaded by a new thread in the'calling application.  DLLs can use this opportunity to'initialize any thread local storage (TLS).FUNCTION = 1   'success!'FUNCTION = 0   'failure!CASE %DLL_THREAD_DETACH'Indicates that the thread is exiting cleanly.  If the DLL has'allocated any thread local storage, it should be released.FUNCTION = 1   'success!'FUNCTION = 0   'failure!END SELECTEND FUNCTIONFUNCTION myMKI ALIAS "myMKI" (BYVAL Param1 AS INTEGER) EXPORT AS STRINGDIM I AS INTEGERDIM TString AS STRINGI=0: TString=""' code goes hereFOR I = 2 TO 1 STEP -1TString=TString+RIGHT$(("0"+LTRIM$(HEX$(ASC(MID$(MKI$(Param1),I,1))))),2)NEXT IFUNCTION = TString
END FUNCTIONFUNCTION myCVI ALIAS "myCVI" (BYVAL Param1 AS STRING) EXPORT AS INTEGERDIM I AS INTEGERDIM TString AS STRINGI=0: TString=""' code goes hereFOR I = 3 TO 1 STEP -2TString=TString+CHR$(VAL("&H"+MID$(Param1,I,2)))NEXT IFUNCTION = CVI(TString)
END FUNCTIONFUNCTION myMKL ALIAS "myMKL" (BYVAL Param1 AS LONG) EXPORT AS STRINGDIM I AS INTEGERDIM TString AS STRINGI=0: TString=""' code goes hereFOR I = 4 TO 1 STEP -1TString=TString+RIGHT$(("0"+LTRIM$(HEX$(ASC(MID$(MKL$(Param1),I,1))))),2)NEXT IFUNCTION = TString
END FUNCTIONFUNCTION myCVL ALIAS "myCVL" (BYVAL Param1 AS STRING) EXPORT AS LONGDIM I AS INTEGERDIM TString AS STRINGI=0: TString=""' code goes hereFOR I = 7 TO 1 STEP -2TString=TString+CHR$(VAL("&H"+MID$(Param1,I,2)))NEXT IFUNCTION = CVL(TString)
END FUNCTIONFUNCTION myMKS ALIAS "myMKS" (BYVAL Param1 AS SINGLE) EXPORT AS STRINGDIM I AS INTEGERDIM TString AS STRINGI=0: TString=""' code goes hereFOR I = 4 TO 1 STEP -1TString=TString+RIGHT$(("0"+LTRIM$(HEX$(ASC(MID$(MKS$(Param1),I,1))))),2)NEXT IFUNCTION = TString
END FUNCTIONFUNCTION myCVS ALIAS "myCVS" (BYVAL Param1 AS STRING) EXPORT AS SINGLEDIM I AS INTEGERDIM TString AS STRINGI=0: TString=""' code goes hereFOR I = 7 TO 1 STEP -2TString=TString+CHR$(VAL("&H"+MID$(Param1,I,2)))NEXT IFUNCTION = CVS(TString)
END FUNCTIONFUNCTION myMKD ALIAS "myMKD" (BYVAL Param2 AS DOUBLE) EXPORT AS STRINGDIM I AS INTEGERDIM TString AS STRINGI=0: TString=""' code goes hereFOR I = 8 TO 1 STEP -1TString=TString+RIGHT$(("0"+LTRIM$(HEX$(ASC(MID$(MKD$(Param2),I,1))))),2)NEXT IFUNCTION = TString
END FUNCTIONFUNCTION myCVD ALIAS "myCVD" (BYVAL Param1 AS STRING) EXPORT AS DOUBLEDIM I AS INTEGERDIM TString AS STRINGI=0: TString=""' code goes hereFOR I = 15 TO 1 STEP -2TString=TString+CHR$(VAL("&H"+MID$(Param1,I,2)))NEXT IFUNCTION = CVD(TString)
END FUNCTIONFUNCTION myCRC16 ALIAS "myCRC16" (BYVAL Param1 AS STRING) EXPORT AS STRING'An input string converted to a 4-byte HEX stringDIM DataA() AS BYTEDIM CRC16Lo AS BYTE, CRC16Hi AS BYTE        'CRC寄存器DIM CL     AS BYTE, CH       AS BYTE                  '多项式码&HA001DIM SaveHi     AS BYTE, SaveLo       AS BYTEDIM I     AS INTEGERDIM Flag     AS INTEGERDIM strMsg AS STRINGDIM intLen AS INTEGERstrMsg = Param1REPLACE " " WITH "" IN StrMsgintLen = LEN(strMsg) / 2 - 1REDIM DataA(0 TO intLen) AS BYTEFOR I = 0 TO intLenDataA(I) = VAL("&H" & MID$(strMsg, I * 2 + 1, 2))NEXTCRC16Lo = &HFFCRC16Hi = &HFFCL = &H1CH = &HA0FOR I = 0 TO UBOUND(DataA, 1)CRC16Lo = CRC16Lo XOR DataA(I)FOR Flag = 0 TO 7SaveHi = CRC16HiSaveLo = CRC16Lo'CRC16Hi = CRC16Hi \ 2SHIFT RIGHT CRC16Hi, 1'CRC16Lo = CRC16Lo \ 2SHIFT RIGHT CRC16Lo, 1IF ((SaveHi AND &H1) = &H1) THENCRC16Lo = CRC16Lo OR &H80END IFIF ((SaveLo AND &H1) = &H1) THENCRC16Hi = CRC16Hi XOR CHCRC16Lo = CRC16Lo XOR CLEND IFNEXT FlagNEXTERASE DataAFUNCTION = RIGHT$("0" & HEX$(CRC16Lo), 2) & RIGHT$("0" & HEX$(CRC16Hi), 2)
END FUNCTIONFUNCTION myINSTRU ALIAS "myINSTRU" (BYVAL Param1 AS STRING) EXPORT AS STRINGDIM LParam1 AS STRINGDIM RETURNSTR AS STRINGRETURNSTR = "UNKNOWN"LParam1 = TRIM$(Param1)SELECT CASE LParam1CASE "VERSION"RETURNSTR = "VERSION 1.00 9AUG2023"CASE "AUTHOR"RETURNSTR = "Mongnewer"END SELECTFUNCTION = RETURNSTR
END FUNCTION

不难看出，MKI/CVI MKS/CVS MKD/CVD这些函数在PowerBASIC里是保留的关键字，CRC16计算是我从CSDN上载了贴上去的，在这里感谢那位CSDN朋友的贡献。Modbus RTU一般使用十六进制浮点传送，因此程序里做了变换处理。

二、用VB6写COM组件

用VB6调用刚才编译后的MBFIEEE32PD.DLL非常容易，不需要做任何字符串处理，两者是100%一致的。做声明定义时完全按VB6的原则来即可，PowerBASIC是无条件遵从的。如果是写VB6应用程序，直接调用DLL中的函数，直接应用就可以了，这里路过就不多说了，还是接着往下写COM组件。

Private toSingle As Single
Private toDouble As DoublePrivate Declare Function myMKI Lib "MBFIEEE32PD" (ByVal a As Integer) As String
Private Declare Function myCVI Lib "MBFIEEE32PD" (ByVal b As String) As Integer
Private Declare Function myMKL Lib "MBFIEEE32PD" (ByVal a As Long) As String
Private Declare Function myCVL Lib "MBFIEEE32PD" (ByVal b As String) As Long
Private Declare Function myMKS Lib "MBFIEEE32PD" (ByVal a As Single) As String
Private Declare Function myCVS Lib "MBFIEEE32PD" (ByVal b As String) As Single
Private Declare Function myMKD Lib "MBFIEEE32PD" (ByVal a As Double) As String
Private Declare Function myCVD Lib "MBFIEEE32PD" (ByVal b As String) As Double
Private Declare Function myCRC16 Lib "MBFIEEE32PD" (ByVal a As String) As String
Private Declare Function myINSTRU Lib "MBFIEEE32PD" (ByVal a As String) As StringSelect Case commandnoCase 1'MKIModbusRoutines = setMKI(Val(commandval))Case 2'MKLModbusRoutines = setMKL(Val(commandval))Case 3'MKSModbusRoutines = setMKS(Val(commandval))Case 4'MKDModbusRoutines = setMKD(Val(commandval))Case 5'CVIModbusRoutines = Str$(getCVI(commandval))Case 6'CVLModbusRoutines = Str$(getCVL(commandval))Case 7'CVStoSingle = getCVS(commandval)toDouble = toSingleModbusRoutines = Str$(toDouble)Case 8'CVDModbusRoutines = Str$(getCVD(commandval))Case 9'CRC16ModbusRoutines = getCRC16(commandval)Case 10'VersionModbusRoutines = getINSTRU(commandval)End Select
End Function
Private Function setMKI(ByVal a As Integer) As StringM2I3HiddenWND.Text1.Text = myMKI(a)setMKI = M2I3HiddenWND.Text1.Text
End Function
Private Function getCVI(ByVal a As String) As IntegerM2I3HiddenWND.Text2.Text = agetCVI = myCVI(M2I3HiddenWND.Text2.Text)
End Function
Private Function setMKL(ByVal a As Long) As StringM2I3HiddenWND.Text3.Text = myMKL(a)setMKL = M2I3HiddenWND.Text3.Text
End Function
Private Function getCVL(ByVal a As String) As LongM2I3HiddenWND.Text4.Text = agetCVL = myCVL(M2I3HiddenWND.Text4.Text)
End Function
Private Function setMKS(ByVal a As Single) As StringM2I3HiddenWND.Text5.Text = myMKS(a)setMKS = M2I3HiddenWND.Text5.Text
End Function
Private Function getCVS(ByVal a As String) As SingleM2I3HiddenWND.Text6.Text = agetCVS = myCVS(M2I3HiddenWND.Text6.Text)
End Function
Private Function setMKD(ByVal a As Double) As StringM2I3HiddenWND.Text7.Text = myMKD(a)setMKD = M2I3HiddenWND.Text7.Text
End Function
Private Function getCVD(ByVal a As String) As DoubleM2I3HiddenWND.Text8.Text = agetCVD = myCVD(M2I3HiddenWND.Text8.Text)
End Function
Private Function getCRC16(ByVal a As String) As StringgetCRC16 = myCRC16(a)
End Function
Private Function getINSTRU(ByVal a As String) As StringgetINSTRU = myINSTRU(a)
End Function

打开VB6，选Active X，把上面的码贴进去，添加个无边的小窗体，放上Text1到Text7共7个文本框，Form的名字 M2I3HiddenWND，属性是 Hidden 隐藏的。文件名 MBFMODIEEE，类名 MBFIEEECRC，存盘、生成 MBFMODIEEE.DLL，即为其它开发环境使用的COM了。

加这个Hidden窗口是这么想的，VB6和PowerBASIC变量和字符串完全兼容，但Delphi7就不一定了，尤其是字符串存储方式的转换。从Delphi来的字符串显示在VB6的文本框可以，但直接传送给PowerBASIC或许有问题，于是就想让文本框做个过渡，或许直接传也不是问题，我没做验证。

因为这个DLL是COM，需要将 MBFMODIEEE.DLL和MBFIEEE32PD.DLL放在同一目录下，并在目录中放入Delphi7应用程序。为了让程序能互访，在CMD窗口里，转到它们所在的目录下，用regsvr32将MBFMODIEEE.DLL注册到系统中。regsvr32 MBFMODIEEE.DLL 回车即可。

三、用Delphi7写界面验证程序

在Delphi下引用刚才注册的MBFMODIEEE.DLL

 在弹出的列表中选中刚才注册的MBFMODIEEE，并点击 Create Unit生成 MBFMODIEEE_TLB声明文件，刚才注册的DLL中要调用的类和接口就都有了。

 在USE中引用生成的PAS，然后为接口声明个handle

 在Form产生时创建对象

 然后在需要的地方就可以通过接口使用对象中的功能函数了

 然后就是正常的开发应用程序，编译后运行(有时开发环境下可能出现异常，但编译后运行是比较好的方法。都是老顽固，稳定可靠，但要就着它们的性子，不能太勉强了)。

BTW：这些功能除PowerBASIC外，FreeBASIC里更齐全，甚至包括了QBASIC的全部关键字，但它的字符串不同于VB和Delphi，需要另外处理。不过它可以写COM，除32位编译器，它还有64位编译器。