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

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

分三步走：

用PowerBASIC写基本DLL

用VB6写COM组件

用Delphi7写界面验证程序

一、用PowerBASIC写基本DLL

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

下面的MBFIEEE32PD.BAS是用PowerBASIC写的

'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 LONG
 
    SELECT CASE fwdReason
 
    CASE %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 = hInstance
 
        FUNCTION = 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 SELECT
 
END FUNCTION
 
 
FUNCTION myMKI ALIAS "myMKI" (BYVAL Param1 AS INTEGER) EXPORT AS STRING
    DIM I AS INTEGER
    DIM TString AS STRING
 
    I=0: TString=""
 
    ' code goes here
    FOR I = 2 TO 1 STEP -1
        TString=TString+RIGHT$(("0"+LTRIM$(HEX$(ASC(MID$(MKI$(Param1),I,1))))),2)
    NEXT I
    FUNCTION = TString
END FUNCTION
 
FUNCTION myCVI ALIAS "myCVI" (BYVAL Param1 AS STRING) EXPORT AS INTEGER
    DIM I AS INTEGER
    DIM TString AS STRING
 
    I=0: TString=""
 
    ' code goes here
    FOR I = 3 TO 1 STEP -2
        TString=TString+CHR$(VAL("&H"+MID$(Param1,I,2)))
    NEXT I
    FUNCTION = CVI(TString)
END FUNCTION
 
FUNCTION myMKL ALIAS "myMKL" (BYVAL Param1 AS LONG) EXPORT AS STRING
    DIM I AS INTEGER
    DIM TString AS STRING
 
    I=0: TString=""
 
    ' code goes here
    FOR I = 4 TO 1 STEP -1
        TString=TString+RIGHT$(("0"+LTRIM$(HEX$(ASC(MID$(MKL$(Param1),I,1))))),2)
    NEXT I
    FUNCTION = TString
END FUNCTION
 
FUNCTION myCVL ALIAS "myCVL" (BYVAL Param1 AS STRING) EXPORT AS LONG
    DIM I AS INTEGER
    DIM TString AS STRING
 
    I=0: TString=""
 
    ' code goes here
    FOR I = 7 TO 1 STEP -2
        TString=TString+CHR$(VAL("&H"+MID$(Param1,I,2)))
    NEXT I
    FUNCTION = CVL(TString)
END FUNCTION
 
FUNCTION myMKS ALIAS "myMKS" (BYVAL Param1 AS SINGLE) EXPORT AS STRING
    DIM I AS INTEGER
    DIM TString AS STRING
 
    I=0: TString=""
 
    ' code goes here
    FOR I = 4 TO 1 STEP -1
        TString=TString+RIGHT$(("0"+LTRIM$(HEX$(ASC(MID$(MKS$(Param1),I,1))))),2)
    NEXT I
    FUNCTION = TString
END FUNCTION
 
FUNCTION myCVS ALIAS "myCVS" (BYVAL Param1 AS STRING) EXPORT AS SINGLE
    DIM I AS INTEGER
    DIM TString AS STRING
 
    I=0: TString=""
 
    ' code goes here
    FOR I = 7 TO 1 STEP -2
        TString=TString+CHR$(VAL("&H"+MID$(Param1,I,2)))
    NEXT I
    FUNCTION = CVS(TString)
END FUNCTION
 
FUNCTION myMKD ALIAS "myMKD" (BYVAL Param2 AS DOUBLE) EXPORT AS STRING
    DIM I AS INTEGER
    DIM TString AS STRING
 
    I=0: TString=""
 
    ' code goes here
    FOR I = 8 TO 1 STEP -1
        TString=TString+RIGHT$(("0"+LTRIM$(HEX$(ASC(MID$(MKD$(Param2),I,1))))),2)
    NEXT I
    FUNCTION = TString
END FUNCTION
 
FUNCTION myCVD ALIAS "myCVD" (BYVAL Param1 AS STRING) EXPORT AS DOUBLE
    DIM I AS INTEGER
    DIM TString AS STRING
 
    I=0: TString=""
 
    ' code goes here
    FOR I = 15 TO 1 STEP -2
        TString=TString+CHR$(VAL("&H"+MID$(Param1,I,2)))
    NEXT I
    FUNCTION = CVD(TString)
END FUNCTION
 
FUNCTION myCRC16 ALIAS "myCRC16" (BYVAL Param1 AS STRING) EXPORT AS STRING
    'An input string converted to a 4-byte HEX string
    DIM DataA() AS BYTE
    DIM CRC16Lo AS BYTE, CRC16Hi AS BYTE        'CRC寄存器
    DIM CL     AS BYTE, CH       AS BYTE                  '多项式码&HA001
    DIM SaveHi     AS BYTE, SaveLo       AS BYTE
    DIM I     AS INTEGER
    DIM Flag     AS INTEGER
    DIM strMsg AS STRING
    DIM intLen AS INTEGER
    strMsg = Param1
    REPLACE " " WITH "" IN StrMsg
    intLen = LEN(strMsg) / 2 - 1
    REDIM DataA(0 TO intLen) AS BYTE
    FOR I = 0 TO intLen
        DataA(I) = VAL("&H" & MID$(strMsg, I * 2 + 1, 2))
    NEXT
    CRC16Lo = &HFF
    CRC16Hi = &HFF
    CL = &H1
    CH = &HA0
    FOR I = 0 TO UBOUND(DataA, 1)
        CRC16Lo = CRC16Lo XOR DataA(I)
        FOR Flag = 0 TO 7
            SaveHi = CRC16Hi
            SaveLo = CRC16Lo
            'CRC16Hi = CRC16Hi \ 2
            SHIFT RIGHT CRC16Hi, 1
            'CRC16Lo = CRC16Lo \ 2
            SHIFT RIGHT CRC16Lo, 1
            IF ((SaveHi AND &H1) = &H1) THEN
                CRC16Lo = CRC16Lo OR &H80
            END IF
            IF ((SaveLo AND &H1) = &H1) THEN
                CRC16Hi = CRC16Hi XOR CH
                CRC16Lo = CRC16Lo XOR CL
            END IF
        NEXT Flag
    NEXT
    ERASE DataA
    FUNCTION = RIGHT$("0" & HEX$(CRC16Lo), 2) & RIGHT$("0" & HEX$(CRC16Hi), 2)
END FUNCTION
 
FUNCTION myINSTRU ALIAS "myINSTRU" (BYVAL Param1 AS STRING) EXPORT AS STRING
    DIM LParam1 AS STRING
    DIM RETURNSTR AS STRING
 
    RETURNSTR = "UNKNOWN"
 
    LParam1 = TRIM$(Param1)
    SELECT CASE LParam1
        CASE "VERSION"
             RETURNSTR = "VERSION 1.00 9AUG2023"
        CASE "AUTHOR"
             RETURNSTR = "Mongnewer"
    END SELECT
    FUNCTION = 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 Double
 
Private 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 String
 
Public Function ModbusRoutines(ByVal commandno As Integer, ByVal commandval As String) As String
    Select Case commandno
    Case 1
        'MKI
        ModbusRoutines = setMKI(Val(commandval))
    Case 2
        'MKL
        ModbusRoutines = setMKL(Val(commandval))
    Case 3
        'MKS
        ModbusRoutines = setMKS(Val(commandval))
    Case 4
        'MKD
        ModbusRoutines = setMKD(Val(commandval))
    Case 5
        'CVI
        ModbusRoutines = Str$(getCVI(commandval))
    Case 6
        'CVL
        ModbusRoutines = Str$(getCVL(commandval))
    Case 7
        'CVS
        toSingle = getCVS(commandval)
        toDouble = toSingle
        ModbusRoutines = Str$(toDouble)
    Case 8
        'CVD
        ModbusRoutines = Str$(getCVD(commandval))
    Case 9
        'CRC16
        ModbusRoutines = getCRC16(commandval)
    Case 10
        'Version
        ModbusRoutines = getINSTRU(commandval)
    End Select
End Function
Private Function setMKI(ByVal a As Integer) As String
    M2I3HiddenWND.Text1.Text = myMKI(a)
    setMKI = M2I3HiddenWND.Text1.Text
End Function
Private Function getCVI(ByVal a As String) As Integer
    M2I3HiddenWND.Text2.Text = a
    getCVI = myCVI(M2I3HiddenWND.Text2.Text)
End Function
Private Function setMKL(ByVal a As Long) As String
    M2I3HiddenWND.Text3.Text = myMKL(a)
    setMKL = M2I3HiddenWND.Text3.Text
End Function
Private Function getCVL(ByVal a As String) As Long
    M2I3HiddenWND.Text4.Text = a
    getCVL = myCVL(M2I3HiddenWND.Text4.Text)
End Function
Private Function setMKS(ByVal a As Single) As String
    M2I3HiddenWND.Text5.Text = myMKS(a)
    setMKS = M2I3HiddenWND.Text5.Text
End Function
Private Function getCVS(ByVal a As String) As Single
    M2I3HiddenWND.Text6.Text = a
    getCVS = myCVS(M2I3HiddenWND.Text6.Text)
End Function
Private Function setMKD(ByVal a As Double) As String
    M2I3HiddenWND.Text7.Text = myMKD(a)
    setMKD = M2I3HiddenWND.Text7.Text
End Function
Private Function getCVD(ByVal a As String) As Double
    M2I3HiddenWND.Text8.Text = a
    getCVD = myCVD(M2I3HiddenWND.Text8.Text)
End Function
Private Function getCRC16(ByVal a As String) As String
    getCRC16 = myCRC16(a)
End Function
Private Function getINSTRU(ByVal a As String) As String
    getINSTRU = 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位编译器。