DDE在vb.net中的应用

来源：互联网发布：军工加人工智能的股票编辑：程序博客网时间：2024/06/15 19:44

随便罗嗦几句，自己已经好几年没有写什么东西了，而自己已经从事这一行好久了，希望能提供一些东西给大家，好与坏无所谓。

很早的时候做过DDE方面的程序，那是在2005年刚来深圳的时候，公司的一个产品需要在excel中动态显示数据，临时做了这么个东西，那个产品是vb.net做的，因此就现在vc下面测试后移到vb中应用，还真的成功了。但是时间不经意间已经过去6年时间了，自己早已经不再涉及vb的东西，看到有个朋友提到这方面的东西向我咨询，于是有了把自己的那个程序拿出来，希望能够对需要的人一点帮助。

DDE 的步骤就不用列出了，网上很多，也能从代码中了解到。用到的函数如下

Public Class DDEML

    '*************************************************************************
    '    created:    2005/08/03
    '    created:    3:8:2005   15:31
    '    filename:     D:/vbdde/Win32.vb
    '    file path:    D:/vbdde
    '    file base:    Win32
    '    file ext:    vb
    '    author:        Peter
    '
    '    purpose:
    '   This code Class contains all of the DDEML declarations that I use throughout
    '   the application. I've tried to comment any declaration/type changes I've made.
    '*************************************************************************

    '*************************************************************************
    ' DDEML Return Values
    '*************************************************************************
    Public Const DMLERR_NO_ERROR As Short = 0
    Public Const DMLERR_ADVACKTIMEOUT As Short = &H4000S
    Public Const DMLERR_BUSY As Short = &H4001S
    Public Const DMLERR_DATAACKTIMEOUT As Short = &H4002S
    Public Const DMLERR_DLL_NOT_INITIALIZED As Short = &H4003S
    Public Const DMLERR_DLL_USAGE As Short = &H4004S
    Public Const DMLERR_EXECACKTIMEOUT As Short = &H4005S
    Public Const DMLERR_INVALIDPARAMETER As Short = &H4006S
    Public Const DMLERR_LOW_MEMORY As Short = &H4007S
    Public Const DMLERR_MEMORY_ERROR As Short = &H4008S
    Public Const DMLERR_NOTPROCESSED As Short = &H4009S
    Public Const DMLERR_NO_CONV_ESTABLISHED As Short = &H400AS
    Public Const DMLERR_POKEACKTIMEOUT As Short = &H400BS
    Public Const DMLERR_POSTMSG_FAILED As Short = &H400CS
    Public Const DMLERR_REENTRANCY As Short = &H400DS
    Public Const DMLERR_SERVER_DIED As Short = &H400ES
    Public Const DMLERR_SYS_ERROR As Short = &H400FS
    Public Const DMLERR_UNADVACKTIMEOUT As Short = &H4010S
    Public Const DMLERR_UNFOUND_QUEUE_ID As Short = &H4011S

    '*************************************************************************
    ' DDEML Flags
    '*************************************************************************
    Public Const XCLASS_BOOL As Short = &H1000S
    Public Const XCLASS_DATA As Short = &H2000S
    Public Const XCLASS_FLAGS As Short = &H4000S
    Public Const XTYPF_NOBLOCK As Short = &H2S ' CBR_BLOCK doesn't seem to work

    Public Const XTYP_CONNECT As Integer = &H60S Or XCLASS_BOOL Or XTYPF_NOBLOCK
    Public Const XTYP_DISCONNECT As Integer = (&HC0 Or XCLASS_NOTIFICATION Or XTYPF_NOBLOCK)
    Public Const XTYP_CONNECT_CONFIRM As Integer = (&H70 Or XCLASS_NOTIFICATION Or XTYPF_NOBLOCK)
    Public Const XTYP_WILDCONNECT As Integer = (&HE0 Or XCLASS_DATA Or XTYPF_NOBLOCK)
    Public Const XTYP_EXECUTE As Integer = (&H50S Or XCLASS_FLAGS)
    Public Const XTYP_REQUEST As Integer = (&HB0S Or XCLASS_DATA)
    Public Const XTYP_POKE As Integer = (&H90S Or XCLASS_FLAGS)
    Public Const XTYP_ERROR As Integer = (&H0 Or XCLASS_NOTIFICATION Or XTYPF_NOBLOCK)
    Public Const XTYP_REGISTER As Integer = (&HA0 Or XCLASS_NOTIFICATION Or XTYPF_NOBLOCK)
    Public Const XTYP_UNREGISTER As Integer = (&HD0 Or XCLASS_NOTIFICATION Or XTYPF_NOBLOCK)

    Public Const XTYP_ADVDATA As Integer = (&H10 Or XCLASS_FLAGS)
    Public Const XTYP_ADVSTART As Integer = (&H30 Or XCLASS_BOOL)
    Public Const XTYP_ADVREQ As Integer = (&H20 Or XCLASS_DATA Or XTYPF_NOBLOCK)
    Public Const XTYP_ADVSTOP As Integer = (&H40 Or XCLASS_NOTIFICATION)

    Public Const XTYP_MASK As Integer = &HF0
    Public Const XTYP_MONITOR As Integer = (XCLASS_NOTIFICATION Or &HF0 Or XTYPF_NOBLOCK)
    Public Const XTYP_SHIFT As Short = 4 ' shift to turn XTYP_ into an index
    Public Const XTYP_XACT_COMPLETE As Integer = (XCLASS_NOTIFICATION Or &H80)

    Public Const CP_WINANSI As Short = 1004 ' Default codepage for DDE conversations.
    Public Const CP_WINUNICODE As Short = 1200
    Public Const DNS_REGISTER As Short = &H1S
    Public Const DNS_UNREGISTER As Short = &H2S
    Public Const DDE_FACK As Short = &H8000S
    Public Const DDE_FBUSY As Short = &H4000S
    Public Const DDE_FNOTPROCESSED As Short = &H0S

    Public Const XCLASS_NOTIFICATION = &H8000
    Public Const APPCLASS_STANDARD = &H0&
    Public Const APPCMD_CLIENTONLY = &H10&
    Public Const APPCLASS_MONITOR As Short = &H1S
    Public Const SW_SHOWNORMAL = 1

    '*************************************************************************
    ' DDEML Function Declarations
    '*************************************************************************
    'auto as charset''''''''pfnCallback is callback function
    Public Declare Function DdeInitialize Lib "user32" Alias "DdeInitializeA" (ByRef pidInst As Integer, ByVal pfnCallback As DDECallBackDelegate, ByVal afCmd As Integer, ByVal ulRes As Integer) As Short

Public Declare Function DdeUninitialize Lib "user32" Alias "DdeUninitialize" (ByVal idInst As Integer) As Integer

Public Declare Function DdeNameService Lib "user32" Alias "DdeNameService" (ByVal idInst As Integer, ByVal hsz1 As Integer, ByVal hsz2 As Integer, ByVal afCmd As Integer) As Integer

Public Declare Function DdeCreateStringHandle Lib "user32" Alias "DdeCreateStringHandleA" _
(ByVal idInst As Integer, ByVal psz As String, ByVal iCodePage As Integer) As Integer

Public Declare Function DdeFreeStringHandle Lib "user32" Alias "DdeFreeStringHandle" _
(ByVal idInst As Integer, ByVal hsz As Integer) As Integer

Public Declare Function DdeQueryString Lib "user32" Alias "DdeQueryStringA" _
(ByVal idInst As Integer, ByVal hsz As Integer, ByVal psz As String, ByVal cchMax As Integer, ByVal iCodePage As Integer) As Integer

Public Declare Function DdeCmpStringHandles Lib "user32" Alias "DdeCmpStringHandles" _
(ByVal hsz1 As Integer, ByVal hsz2 As Integer) As Integer

    ' Removed the alias and changed the pSrc parameter from "ByVal pSrc as Byte"
    ' to "ByVal pSrc as String".
    Public Declare Function DdeCreateDataHandle Lib "user32" _
    (ByVal idInst As Integer, ByVal pSrc As String, ByVal cb As Integer, ByVal cbOff As Integer, ByVal hszItem As Integer, ByVal wFmt As Integer, ByVal afCmd As Integer) As Integer

Public Declare Function DdeFreeDataHandle Lib "user32" Alias "DdeFreeDataHandle" (ByVal hData As Integer) As Integer

Public Declare Function DdeGetLastError Lib "user32" Alias "DdeGetLastError" (ByVal idInst As Integer) As Integer

Public Declare Function DdePostAdvise Lib "user32" Alias "DdePostAdvise" _
(ByVal idInst As Integer, ByVal hszTopic As Integer, ByVal hszItem As Integer) As Integer

    ''' <summary>
    'dde callback function
    ''' </summary>
    Public Delegate Function DDECallBackDelegate( _
    ByVal wType As Integer, _
    ByVal wFmt As Integer, _
    ByVal hConv As Integer, _
    ByVal hszTopic As Integer, _
    ByVal hszItem As Integer, _
    ByVal hData As Integer, _
    ByVal lData1 As Integer, _
    ByVal lData2 As Integer _
            ) As Integer

End Class

--------------

打包到一个类中

Public NotInheritable Class ExcelDDE
    '*************************************************************************
    '    created:    2005/08/03
    '    created:    3:8:2005   16:15
    '    filename:     D:/vbdde/Win32.vb
    '    file path:    D:/vbdde
    '    file base:    Win32
    '    file ext:    vb
    '    author:        peter
    '
    '    purpose:    This application is programing for provide some dde server.
    '*************************************************************************

    '*************************************************************************
    ' DDEML Server Constants
    '*************************************************************************
    ' instance of application
    ' This is just a string that we'll return whenever a client performs a DDE
    ' request.
    'declear server
    Private Const DDE_SERVER As String = "PS"

'declear callback
Private _DDECallBack As DDEML.DDECallBackDelegate = Nothing

    'declear server global variable
    Private g_lInstID As Integer ' DDE instance identifier.
    Private g_hszDDEServer As Integer ' String handle for the server name.

'Private g_lDDERet As Integer ' Generic return variable.

' other variable.
Private g_bRunning As Boolean ' Server running flag.

Private g_hDDETopic(-1) As Integer ' String handle for the topic name. {htopic1,htopic1,...}
'Private g_strDDETopic(-1) As String

Private g_hDDETopicItem(-1) As String ' String handle for the topic name. {{htopic-hitem},...}
' set current topic in "QUOTE, DES, ESTIMATES, FUNDA, HISTORY, FINET"

    Private g_hDDEConn(-1) As Integer '
    '*************************************************************************
    '    purpose:计时器及传递字符串操作相关
    '需要3个字符串,1从excel中生成的字符串，我要把这个字符串交给ps程序
    '2、ps返回的字符串，我要解析这个字符串，
    '3、取出与item值相互对应的值，放回excel的对应cell
    '
    '*************************************************************************

Private m_strTanslate As String = "" '原始传递字符串
Private m_strTansWithValue As String = "" '返回含值的字符串

    Private Sub ClearVariable()
        'inialize variable
        g_lInstID = 0
        g_hszDDEServer = 0
        g_bRunning = False

        ReDim g_hDDETopic(-1)
        ReDim g_hDDETopicItem(-1)
        ReDim g_hDDEConn(-1)

        m_strTanslate = ""
        m_strTansWithValue = ""
    End Sub

Public Sub BeginDDEServer()

System.Diagnostics.Debug.WriteLine("-------------- Begin DDE Server Test --------------")

ClearVariable()

' Initialize the DDE subsystem. This only needs to be done once.
If g_lInstID <> 0 Then EndDDEServer()

DDEInitial()

'TranslateError()

        ' set topics in "QUOTE, DES, ESTIMATES, FUNDA, HISTORY, FINET"
        DDECreateStringHandles("PS")
        CreateDDETopic("QUOTE") ',('EUR-FX','last')
        CreateDDETopic("DES")
        CreateDDETopic("ESTIMATES")
        CreateDDETopic("FUNDA")
        CreateDDETopic("HISTORY")
        CreateDDETopic("FINET")

'TranslateError()
DDEServerRegister(g_lInstID, g_hszDDEServer)

'TranslateError()

End Sub

    Public Sub CreateDDETopic(ByRef strTopic As String)
        DDECreateStringHandles("", strTopic)
    End Sub

Public Sub EndDDEServer()
'TranslateError()

DDEFreeStringHandles()
'TranslateError()

DDEServerUnregister()
'TranslateError()

        ' Break down the link with the DDE subsystem.
        DDEUninitialize()
        'TranslateError()

ClearVariable()
System.Diagnostics.Debug.WriteLine("------------------- end DDE Server Test -----------------------")

End Sub

Private Function DDEInitial() As Boolean
_DDECallBack = New DDEML.DDECallBackDelegate(AddressOf DDECallBack)

        Dim ddeinst As Integer
        'server
        ddeinst = DDEML.DdeInitialize(g_lInstID, _DDECallBack, DDEML.APPCLASS_STANDARD, 0)
        If ddeinst = DDEML.XTYP_ERROR Then
            'If not ddeinst = DDEML.DMLERR_NO_ERROR then
            System.Diagnostics.Debug.WriteLine("DDE Initialize Failure.")
            'TranslateError()
        Else
            System.Diagnostics.Debug.WriteLine("DDE Initialize Success.")
        End If

End Function

    Private Sub DDEServerRegister(ByVal lInstID As Integer, ByVal hszDDEServer As Integer)
        ' Lets check to see if another DDE server has already registered with identical
        ' server/topic names. If so we'll exit. If we were to continue the DDE subsystem
        ' could become unstable when a client tried to converse with the server/topic.

        ' We need to register the server with the DDE subsystem.
        If (DDEML.DdeNameService(lInstID, hszDDEServer, 0, DDEML.DNS_REGISTER)) Then
            ' Set the server running flag.
            g_bRunning = True
        End If

End Sub

Private Sub DDEServerUnregister()

        ' Unregister the DDE server.
        If g_bRunning Then
            DDEML.DdeNameService(g_lInstID, g_hszDDEServer, 0, DDEML.DNS_UNREGISTER)
        End If

End Sub

    '回调函数。
    Private Function DDECallBack( _
            ByVal wType As Integer, _
            ByVal wFmt As Integer, _
            ByVal hConv As Integer, _
            ByVal hszTopic As Integer, _
            ByVal hszItem As Integer, _
            ByVal hData As Integer, _
            ByVal dwData1 As Integer, _
            ByVal dwData2 As Integer _
            ) As Integer

Dim iRet As Integer
'System.Diagnostics.Debug.WriteLine("In client callback. uType: " & wType)

        '''''''''''''''''''''''''''''''''''''''''''conversation
        Select Case wType
            Case DDEML.XTYP_CONNECT
                'System.Diagnostics.Debug.WriteLine("XTYP_CONNECT")
                ' Just return a positive acknowledgement. If we don't the conversation will
                ' never be completed between us and the client.
                ' Client is trying to connect. Respond TRUE if we have what they want...(HDDEDATA)TRUE
                'At this, we can set condition that define when we pass connection.
                'They are topics and server we defined above.
                '检查主题和服务
                If CheckTopic(hszTopic) = False Or g_hszDDEServer <> hszItem Then
                    iRet = DDEML.DDE_FNOTPROCESSED
                End If

iRet = DDEML.DDE_FACK

            Case DDEML.XTYP_CONNECT_CONFIRM
                If Not CheckConn(hConv) And hConv <> 0 Then
                    ReDim Preserve g_hDDEConn(g_hDDEConn.Length)
                    g_hDDEConn(g_hDDEConn.Length - 1) = hConv
                End If

'System.Diagnostics.Debug.WriteLine("XTYP_CONNECT_CONFIRM")

            Case DDEML.XTYP_DISCONNECT
                If g_hDDEConn.Length > 0 Then
                    Array.Clear(g_hDDEConn, Array.IndexOf(g_hDDEConn, hConv), 1)
                End If
                System.Diagnostics.Debug.WriteLine("XTYP_DISCONNECT")

'advise loop begin
Case DDEML.XTYP_ADVSTART

                ' Client starting advisory loop.
                ' Say "ok" if we have what they are asking for...
                'System.Diagnostics.Debug.WriteLine("XTYP_ADVSTART")

                ' 建议启动事务,当有一个Item被改变时,它就会启动一个建议循环
                '我把它用作添加传递字符串子项的条件
                '这时候，hszItemName被从excel中返回,经过在vc中测试，千真万确。

                Dim topic As String
                Dim item As String
                topic = getStringFromHandle(hszTopic)
                item = getStringFromHandle(hszItem)

                If (Not item.Equals("StdDocumentName")) Then
                    If Not CheckTopicItem(hszTopic, hszItem) And CheckConn(hConv) Then
                        ReDim Preserve g_hDDETopicItem(g_hDDETopicItem.Length)
                        g_hDDETopicItem(g_hDDETopicItem.Length - 1) = hszTopic.ToString + "-" + hszItem.ToString
                    End If
                    AddItemToTansString(DDE_SERVER, topic, item)
                    iRet = DDEML.DDE_FACK
                End If

                'advise loop end
            Case DDEML.XTYP_ADVSTOP
                ' Client stopping advisory loop.
                ' Say "ok" if we have what they are asking for...
                'System.Diagnostics.Debug.WriteLine("XTYP_ADVSTOP")

                Dim topic As String
                Dim item As String
                topic = getStringFromHandle(hszTopic)
                item = getStringFromHandle(hszItem)

                If Not item.Equals("StdDocumentName") Then
                    ''    If g_hDDETopicItem.Length > 0 Then
                    ''        Array.Clear(g_hDDETopicItem, Array.IndexOf(g_hDDETopicItem, hszTopic.ToString + "-" + hszItem.ToString), 1)
                    ''    End If
                    '清空 g_hDDETopicItem
                    DelItemToTansString(DDE_SERVER, topic, item)
                    iRet = DDEML.DDE_FACK
                End If

'Case DDEML.XTYP_ERROR
' System.Diagnostics.Debug.WriteLine("XTYP_ERROR")

                'Case DDEML.XTYP_EXECUTE
                '        ' Process the execute transaction.
                '        System.Diagnostics.Debug.WriteLine("XTYP_EXECUTE")

'Case DDEML.XTYP_MASK
' System.Diagnostics.Debug.WriteLine("XTYP_MASK")

'Case DDEML.XTYP_MONITOR
' System.Diagnostics.Debug.WriteLine("XTYP_MONITOR")

                'Case DDEML.XTYP_POKE
                '        ' Process the poke request.
                '        System.Diagnostics.Debug.WriteLine("XTYP_POKE")

'Case DDEML.XTYP_REGISTER
' System.Diagnostics.Debug.WriteLine("XTYP_REGISTER")

                'Case DDEML.XTYP_REQUEST
                '        ' Process the request transaction.
                '        System.Diagnostics.Debug.WriteLine("XTYP_REQUEST")

'Case DDEML.XTYP_SHIFT
' System.Diagnostics.Debug.WriteLine("XTYP_SHIFT")

'Case DDEML.XTYP_UNREGISTER
' System.Diagnostics.Debug.WriteLine("XTYP_UNREGISTER")

                'Case DDEML.XTYP_WILDCONNECT
                '        '''wildconnect is inefficient,and I will use it laterly.
                '        System.Diagnostics.Debug.WriteLine("XTYP_WILDCONNECT")

                'Case DDEML.XTYP_XACT_COMPLETE
                '        System.Diagnostics.Debug.WriteLine("XTYP_XACT_COMPLETE")
            Case DDEML.XTYP_ADVREQ
                    'System.Diagnostics.Debug.WriteLine("XTYP_ADVREQ")
                    Dim strCellValue As String = ""
                    Dim iItemIndex As Integer
                    While iItemIndex < g_hDDETopicItem.Length
                        If g_hDDETopicItem(iItemIndex).StartsWith(hszTopic.ToString() + "-" + hszItem.ToString() + "&") Then
                            strCellValue = g_hDDETopicItem(iItemIndex).Substring(g_hDDETopicItem(iItemIndex).IndexOf("&") + 1).TrimEnd()
                            g_hDDETopicItem(iItemIndex) = g_hDDETopicItem(iItemIndex).Substring(0, g_hDDETopicItem(iItemIndex).IndexOf("&"))
                            Exit While
                        End If
                        iItemIndex += 1
                    End While

If strCellValue.Length > 0 Then

                        Dim strTrans As String = strCellValue
                        Dim iStrLen = System.Text.Encoding.GetEncoding("GB2312").GetByteCount(strTrans)
                        Dim xltableString As String = ""

                        'tdtTable record...
                        xltableString += Convert.ToChar(&H10) + Convert.ToChar(&H0) + Convert.ToChar(&H4) + Convert.ToChar(&H0) + _
                                         Convert.ToChar(&H1) + Convert.ToChar(&H0) + Convert.ToChar(&H1) + Convert.ToChar(&H0) + _
                                         Convert.ToChar(&H2) + Convert.ToChar(&H0) + Convert.ToChar(iStrLen) + Convert.ToChar(&H0) _
                                        + Convert.ToChar(iStrLen)

'tdtString record...
xltableString += strTrans

                        Dim encoding As System.Text.Encoding = System.Text.Encoding.UTF8
                        Dim encodedBytes() As Byte = encoding.GetBytes(xltableString)
                        xltableString = encoding.GetString(encodedBytes)

                        iRet = DDEML.DdeCreateDataHandle(g_lInstID, xltableString, 13 + iStrLen, 0, hszItem, wFmt, 0) 'wfmt=49772
                        'TranslateError()
                    End If
        End Select

' Set the final callback return.
DDECallBack = iRet

End Function

Private Sub TranslateError()

Dim iRet As Integer

iRet = DDEML.DdeGetLastError(g_lInstID)

        Select Case iRet
            Case DDEML.DMLERR_NO_ERROR
                System.Diagnostics.Debug.WriteLine("DMLERR_NO_ERROR")

Case DDEML.DMLERR_ADVACKTIMEOUT
System.Diagnostics.Debug.WriteLine("DMLERR_ADVACKTIMEOUT")

Case DDEML.DMLERR_BUSY
System.Diagnostics.Debug.WriteLine("DMLERR_BUSY")

Case DDEML.DMLERR_DATAACKTIMEOUT
System.Diagnostics.Debug.WriteLine("DMLERR_DATAACKTIMEOUT")

Case DDEML.DMLERR_DLL_NOT_INITIALIZED
System.Diagnostics.Debug.WriteLine("DMLERR_NOT_INITIALIZED")

Case DDEML.DMLERR_DLL_USAGE
System.Diagnostics.Debug.WriteLine("DMLERR_USAGE")

Case DDEML.DMLERR_EXECACKTIMEOUT
System.Diagnostics.Debug.WriteLine("DMLERR_EXECACKTIMEOUT")

Case DDEML.DMLERR_INVALIDPARAMETER
System.Diagnostics.Debug.WriteLine("DMLERR_INVALIDPARAMETER")

Case DDEML.DMLERR_LOW_MEMORY
System.Diagnostics.Debug.WriteLine("DMLERR_LOW_MEMORY")

Case DDEML.DMLERR_MEMORY_ERROR
System.Diagnostics.Debug.WriteLine("DMLERR_MEMORY_ERROR")

Case DDEML.DMLERR_NOTPROCESSED
System.Diagnostics.Debug.WriteLine("DMLERR_NOTPROCESSED")

Case DDEML.DMLERR_NO_CONV_ESTABLISHED
System.Diagnostics.Debug.WriteLine("DMLERR_NO_CONV_ESTABLISHED")

Case DDEML.DMLERR_POKEACKTIMEOUT
System.Diagnostics.Debug.WriteLine("DMLERR_POKEACKTIMEOUT")

Case DDEML.DMLERR_POSTMSG_FAILED
System.Diagnostics.Debug.WriteLine("DMLERR_POSTMSG_FAILED")

Case DDEML.DMLERR_REENTRANCY
System.Diagnostics.Debug.WriteLine("DMLERR_REENTRANCY")

Case DDEML.DMLERR_SERVER_DIED
System.Diagnostics.Debug.WriteLine("DMLERR_SERVER_DIED")

Case DDEML.DMLERR_SYS_ERROR
System.Diagnostics.Debug.WriteLine("DMLERR_SYS_ERROR")

Case DDEML.DMLERR_UNADVACKTIMEOUT
System.Diagnostics.Debug.WriteLine("DMLERR_UNADVACKTIMEOUT")

Case DDEML.DMLERR_UNFOUND_QUEUE_ID
System.Diagnostics.Debug.WriteLine("DMLERR_UNFOUND_QUEUE_ID")

End Select

End Sub

Private Sub DDEUninitialize()

        ' Tear down the initialized instance.
        If g_lInstID <> 0 Then
            If DDEML.DdeUninitialize(g_lInstID) Then
                System.Diagnostics.Debug.WriteLine("DDE Uninitialize Success.")
            Else
                System.Diagnostics.Debug.WriteLine("DDE Uninitialize Failure.")
                'TranslateError()
            End If

g_lInstID = 0
End If

'System.Diagnostics.Debug.WriteLine("-------------------- End DDE Test ------------------------")

End Sub

    Private Function getStringFromHandle(ByVal hData As Integer) As String
        '/*********************
        Dim iCount As Integer
        Dim sBuffer As String

        ' What's the size of the string?
        iCount = DDEML.DdeQueryString(g_lInstID, hData, vbNullString, 0, DDEML.CP_WINANSI)
        ' Allocate space for the string.
        sBuffer = Space(iCount)
        ' Grab the string.
        DDEML.DdeQueryString(g_lInstID, hData, sBuffer, iCount + 10, DDEML.CP_WINANSI)
        getStringFromHandle = sBuffer
        '/*********************

End Function

Private Sub DdePostAdv(ByVal idInst As Integer, ByVal hszTopicName As Integer, ByVal hszItem As Integer)

        If idInst <> 0 And hszTopicName > 0 And hszItem > 0 Then
            DDEML.DdePostAdvise(g_lInstID, hszTopicName, hszItem)
            'TranslateError()
        End If

End Sub

    Private Sub DDECreateStringHandles(Optional ByRef sTheService As String = "", Optional ByRef sTheTopic As String = "")
        ' Create the string handles for the service and topic. DDEML will not
        ' allow you to use standard strings. NOTE: Make sure to release the
        ' string handles once you are done with them.
        ' Now that the DDEML subsystem is initialized we create string handles for our
        ' server/topic name.

        If (g_lInstID <> 0) Then
            If (sTheService <> "") Then
                g_hszDDEServer = DDEML.DdeCreateStringHandle(g_lInstID, sTheService, DDEML.CP_WINANSI)
                If g_hszDDEServer = 0 Then
                    MsgBox("Creating serverName is failed!", MsgBoxStyle.OKOnly)
                End If
            End If

            If (sTheTopic <> "") Then
                Dim hTopicTemp As Integer = DDEML.DdeCreateStringHandle(g_lInstID, sTheTopic, DDEML.CP_WINANSI)
                If Not CheckTopic(hTopicTemp) And hTopicTemp <> 0 Then
                    ReDim Preserve g_hDDETopic(g_hDDETopic.Length)
                    g_hDDETopic(g_hDDETopic.Length - 1) = hTopicTemp
                Else
                    MsgBox("Creating topic is failed!", MsgBoxStyle.OKOnly) 'DdeCreateStringHandle(topicName) failed
                End If
            End If
        End If

End Sub

Private Sub DDEFreeStringHandles()

' We need to release our string handles.
' Release our string handles.

        If (g_hszDDEServer <> 0) Then
            DDEML.DdeFreeStringHandle(g_lInstID, g_hszDDEServer)
            g_hszDDEServer = 0
        End If

        Dim i As Integer = 0
        While i < g_hDDETopic.Length
            If g_hDDETopic(i) <> 0 Then
                DDEML.DdeFreeStringHandle(g_lInstID, g_hDDETopic(i))
                g_hDDETopic(i) = 0
            End If
            i += 1
        End While

End Sub

    Private Function CheckTopic(ByVal hTopic As Integer) As Boolean
        ' set current topic in "QUOTE, DES, ESTIMATES, FUNDA, HISTORY, FINET"
        Dim bRet As Boolean = False
        Dim oTopic As Object
        oTopic = hTopic

        If Array.BinarySearch(g_hDDETopic, oTopic) >= 0 Then
            bRet = True
        End If

CheckTopic = bRet
End Function

    Private Function CheckConn(ByVal hConn As Integer) As Boolean
        ' set current topic in "QUOTE, DES, ESTIMATES, FUNDA, HISTORY, FINET"
        Dim bRet As Boolean = False
        Dim oConn As Object
        oConn = hConn
        If Array.BinarySearch(g_hDDEConn, oConn) >= 0 Then
            bRet = True
        End If

CheckConn = bRet
End Function

    Private Function CheckTopicItem(ByVal hTopic As Integer, ByVal hItem As Integer) As Integer
        ' set current topic in "QUOTE, DES, ESTIMATES, FUNDA, HISTORY, FINET"
        Dim bRet As Boolean = False
        Dim strTopicItem As Object

        strTopicItem = hTopic.ToString() + "-" + hItem.ToString()
        If Array.BinarySearch(g_hDDETopicItem, strTopicItem) >= 0 Then
            bRet = True
        End If

CheckTopicItem = bRet
End Function

''''''invalid function ,bucause strTopic is string array first
Private Function GetTopicItemIndexFromString(ByRef strTopic As String, ByRef strItem As String) As Integer

Dim i As Integer = 0
Dim bRet As Integer

Dim hTopic As Integer = DDEML.DdeCreateStringHandle(g_lInstID, strTopic, DDEML.CP_WINANSI)
If hTopic = 0 Then Exit Function

'TranslateError() '参数无效
DDEML.DdeFreeStringHandle(g_lInstID, hTopic)

        Dim hItem As Integer = DDEML.DdeCreateStringHandle(g_lInstID, strItem, DDEML.CP_WINANSI)
        'TranslateError()
        DDEML.DdeFreeStringHandle(g_lInstID, hItem)

        If g_hDDETopicItem.Length > 0 And hTopic > 0 And hItem > 0 Then
            Dim strTopicItem As Object
            strTopicItem = hTopic.ToString() + "-" + hItem.ToString()
            bRet = Array.BinarySearch(g_hDDETopicItem, strTopicItem)
        End If

GetTopicItemIndexFromString = bRet

End Function

Private Sub AddItemToTansString(ByRef strServer As String, ByRef strTopic As String, ByRef strItem As String)

        '如果 m_strTanslate中含有strServer+strTopic+strItem,就直接返回.
        '如果m_strTanslate中不含有strServer+strTopic+strItem,则在m_strTanslate的后面追加 strServer+strTopic+strItem + vbCrLf
        Dim strItemTemp As String = strServer + "|" + strTopic + "!" + strItem
        If m_strTanslate.IndexOf(strItemTemp) = -1 Then
            m_strTanslate = m_strTanslate + strItemTemp + vbCrLf
        End If

End Sub

    Private Sub DelItemToTansString(ByRef strServer As String, ByRef strTopic As String, ByRef strItem As String)
        '如果 m_strTanslate中含有strServer+strTopic+strItem,则在m_strTanslate的里面减去strServer+strTopic+strItem + vbCrLf
        '如果m_strTanslate中不含有strServer+strTopic+strItem,就直接返回
        Dim strItemTemp As String = strServer + "|" + strTopic + "!" + strItem + vbCrLf
        If m_strTanslate.IndexOf(strItemTemp) > -1 Then
            m_strTanslate = m_strTanslate.Replace(strItemTemp, "")
        End If

End Sub

    Public Sub UpdateExcel()
        '使用新的返回值更新excel单元数据。
        If m_strTansWithValue.Length < 2 Or m_strTanslate.Length < 2 Then
            Exit Sub
        End If

Try
System.Threading.Monitor.TryEnter(Me, 1000)

            Dim strTopic As String
            Dim strItem As String
            Dim strTopicItem(1) As String
            Dim hTopic As Integer
            Dim hItem As Integer

            Dim iTopicItemIndex As Integer
            Dim istart As Integer
            Dim iend As Integer
            Dim iIndex As Integer

            Dim strTempArray() As String
            strTempArray = m_strTansWithValue.Split(Environment.NewLine) 'vbCrLf
            Array.Sort(g_hDDETopicItem)

            For iIndex = 0 To strTempArray.GetUpperBound(0)
                istart = strTempArray(iIndex).LastIndexOf("|")
                iend = strTempArray(iIndex).LastIndexOf("!")
                If iend = -1 Then Exit For
                strTopic = strTempArray(iIndex).Substring(istart + 1, iend - istart - 1)

                istart = iend
                iend = strTempArray(iIndex).LastIndexOf(":")
                If iend = -1 Then Exit For
                strItem = strTempArray(iIndex).Substring(istart + 1, iend - istart - 1)

                iTopicItemIndex = GetTopicItemIndexFromString(strTopic, strItem)
                ' iTopicItemIndex = iIndex 'test for
                strTopicItem = g_hDDETopicItem(iTopicItemIndex).Split("-")
                hTopic = Int32.Parse(strTopicItem(0))
                strTopicItem(1) = strTopicItem(1).Split("&")(0) ''新添加
                hItem = Int32.Parse(strTopicItem(1))

g_hDDETopicItem(iTopicItemIndex) = hTopic.ToString + "-" + hItem.ToString ''新添加
g_hDDETopicItem(iTopicItemIndex) += "&" + strTempArray(iIndex).Substring(iend + 1) '提取值

                If g_lInstID <> 0 And hTopic > 0 And hItem > 0 Then
                    DDEML.DdePostAdvise(g_lInstID, hTopic, hItem)
                    'TranslateError()
                End If

Catch e As Exception

        Finally
            m_strTansWithValue = ""
            System.Threading.Monitor.Pulse(Me)
            System.Threading.Monitor.Exit(Me)
        End Try

End Sub

Public ReadOnly Property TanslateString() As String

        Get
            Return m_strTanslate
        End Get

        'Set(ByVal Value As String)
        '    m_strTanslate = Value
        'End Set

End Property

Public Property TanslateStringWithValue() As String

        Get
            Return m_strTansWithValue
        End Get

        Set(ByVal Value As String)
            If m_strTansWithValue = "" Then '控制m_strTansWithValue必须被更新完毕
                m_strTansWithValue = Value
            End If
        End Set

End Property

Public ReadOnly Property DDE_ServerName() As String

        Get
            Return DDE_SERVER
        End Get

End Property

End Class

----------------

启动一个类获取数据

        '*************************************************************************
    '    created:    2005/08/03
    '    created:    3:8:2005   15:31
    '    filename:     D:/vbdde/DDEServer.vb
    '    file path:    D:/vbdde
    '    file base:    Win32
    '    file ext:    vb
    '    author:        Peter
    '
     '*************************************************************************

Imports System.Threading
Imports System.Math

Public Class ddeServer
Inherits System.Windows.Forms.Form

#Region " Windows Form Designer generated code "

Public Sub New()
MyBase.New()

'This call is required by the Windows Form Designer.
InitializeComponent()

'Add any initialization after the InitializeComponent() call

End Sub

    'Form overrides dispose to clean up the component list.
    Protected Overloads Overrides Sub Dispose(ByVal disposing As Boolean)
        If disposing Then
            If Not (components Is Nothing) Then
                components.Dispose()
            End If
        End If
        MyBase.Dispose(disposing)
    End Sub

'Required by the Windows Form Designer
Private components As System.ComponentModel.IContainer

    'NOTE: The following procedure is required by the Windows Form Designer
    'It can be modified using the Windows Form Designer.
    'Do not modify it using the code editor.
    Friend WithEvents btnRun As System.Windows.Forms.Button
    Friend WithEvents tbxOutput As System.Windows.Forms.TextBox
    Friend WithEvents tbxInput As System.Windows.Forms.TextBox
    Friend WithEvents ddeClient As PowerStation.ddeClient
    <System.Diagnostics.DebuggerStepThrough()> Private Sub InitializeComponent()
        Dim resources As System.Resources.ResourceManager = New System.Resources.ResourceManager(GetType(ddeServer))
        Me.btnRun = New System.Windows.Forms.Button
        Me.tbxOutput = New System.Windows.Forms.TextBox
        Me.tbxInput = New System.Windows.Forms.TextBox
        Me.ddeClient = New PowerStation.ddeClient
        Me.SuspendLayout()
        '
        'btnRun
        '
        Me.btnRun.Location = New System.Drawing.Point(317, 209)
        Me.btnRun.Name = "btnRun"
        Me.btnRun.Size = New System.Drawing.Size(192, 22)
        Me.btnRun.TabIndex = 5
        Me.btnRun.Text = "Run"
        '
        'tbxOutput
        '
        Me.tbxOutput.Location = New System.Drawing.Point(19, 246)
        Me.tbxOutput.Multiline = True
        Me.tbxOutput.Name = "tbxOutput"
        Me.tbxOutput.Size = New System.Drawing.Size(768, 180)
        Me.tbxOutput.TabIndex = 4
        Me.tbxOutput.Text = ""
        '
        'tbxInput
        '
        Me.tbxInput.Location = New System.Drawing.Point(19, 22)
        Me.tbxInput.Multiline = True
        Me.tbxInput.Name = "tbxInput"
        Me.tbxInput.Size = New System.Drawing.Size(768, 165)
        Me.tbxInput.TabIndex = 3
        Me.tbxInput.Text = ""
        '
        'ddeClient
        '
        Me.ddeClient.BackColor = System.Drawing.SystemColors.Desktop
        Me.ddeClient.Location = New System.Drawing.Point(0, 0)
        Me.ddeClient.Name = "ddeClient"
        Me.ddeClient.Size = New System.Drawing.Size(48, 24)
        Me.ddeClient.TabIndex = 0
        Me.ddeClient.Visible = False
        '
        'ddeServer
        '
        Me.AutoScale = False
        Me.AutoScaleBaseSize = New System.Drawing.Size(6, 14)
        Me.ClientSize = New System.Drawing.Size(806, 446)
        Me.Controls.Add(Me.btnRun)
        Me.Controls.Add(Me.tbxOutput)
        Me.Controls.Add(Me.tbxInput)
        Me.Controls.Add(Me.ddeClient)
        Me.Name = "ddeServer"
        Me.Text = "ddeServer"
        Me.ResumeLayout(False)

End Sub

#End Region

    ' Utilities and Tools
    Dim util As New Utilities()
    Dim pull As New Pull()
    Dim foap As New vbFOAP()

    ' Threads
    Dim tcpconnectThread As New Thread(New ThreadStart(AddressOf tcpconnect))
    Dim getdataThread As New Thread(New ThreadStart(AddressOf getdata))
    Dim displayThread As New Thread(New ThreadStart(AddressOf display))

    ' Display Properties Variables
    Dim myLanguage As Integer
    Dim myUIState As Integer
    Dim myFontSize As Integer
    Dim myFontSizeState As Integer
    Dim myWindowsStyle As Integer

    ' Own Variables
    Dim N As Integer
    Dim myString As String
    Dim Parameter As String
    Dim MdiParent_N As Integer = 0
    Dim InputRow() As String

' HealthCheckTimeCount
Dim HealthCheckTimeCount, HealthCheckTimeCount2 As Integer

' Labels Arrays
Dim lbaTitle() = {"", "", ""}

Private Sub onStart(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
On Error Resume Next

        ' Register the N th Teletext
        Teletext_N = Teletext_N + 1
        N = Teletext_N

        ' Increase array size by 1
        ReDim Preserve TeletextActiveCode(N)
        ReDim Preserve StreamString(N)

TeletextActiveCode(N) = "1:0000-HK"

        ' Intitialization Jobs
        setLanguage()
        setUI()

        ' Start threads
        tcpconnectThread.Start()
        getdataThread.Start()
        displayThread.Start()
    End Sub

    Private Sub onClose(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Closed
        ' Stop threads
        EngineState(N) = 911
        getdataThread.Abort()
        displayThread.Abort()

End Sub

#Region "TCP Connections and TCP Health Check"

    Private Sub tcpconnect()
        pull.connect(StreamingIP, StreamingPort2)
    End Sub

    Private Sub tcpestablish(ByVal ActiveCode As String)
        Dim tcpconnectThread As New Thread(New ThreadStart(AddressOf tcpconnect))
        myString = ""

        'Register the N th child
        Teletext_N = Teletext_N + 1
        N = Teletext_N

        ' Increase array size by 1
        ReDim Preserve TeletextActiveCode(N)
        ReDim Preserve StreamString(N)
        TeletextActiveCode(N) = ActiveCode

        ' Start Thread
        tcpconnectThread.Start()
    End Sub

    Private Sub tcpHealthCheck()
        On Error Resume Next
        ' Init Checking
        If tcpVerifyFailed() Then
            If HealthCheckTimeCount = 10 Then
                HealthCheckTimeCount = 0
                tcpReconnect()
            End If
            HealthCheckTimeCount += 1
        Else
            HealthCheckTimeCount = 0
        End If

        ' Cron Checking
        If HealthCheckTimeCount2 = TCPHealthInterval1 Then
            StreamString(N) = ""
            If InStr(TeletextActiveCode(N), " ") Then
                TeletextActiveCode(N) = Replace(TeletextActiveCode(N), " ", "")
            Else
                TeletextActiveCode(N) = TeletextActiveCode(N) & " "
            End If
        End If
        If HealthCheckTimeCount2 = TCPHealthInterval2 Then
            HealthCheckTimeCount2 = 0
            If StreamString(N) = "" Then
                tcpReconnect()
            End If
        End If
        HealthCheckTimeCount2 += 1

        ' Frontend Signal
        If StreamString(N) = "" Then
            tcpFailedAlert(1)
        Else
            tcpFailedAlert(0)
        End If
    End Sub

Private Sub tcpReconnect()
Console.WriteLine("Reconnecting...")

' Kill previous connection
EngineState(N) = 911

' Delete coordinate file
util.DeleteFile("data/windows" & MdiParent_N & "/current/" & Me.Name & "." & N)

        ' Re-establish TCP connection
        tcpestablish(TeletextActiveCode(N))
    End Sub

    Private Function tcpVerifyFailed()
        If 0 > 1 Then ' Set your criteria here!
            Return True
        Else
            Return False
        End If
    End Function

    Private Sub tcpFailedAlert(ByVal State As Integer)
        If State = 1 Then
            ' Some frontend notice for failed case
            Me.Text = Replace(Me.Text, ".", "")
            Me.Text = Me.Text & "."
        Else
            ' Some frontend notice for normal case
            Me.Text = Replace(Me.Text, ".", "")
        End If
    End Sub

#End Region

    ' Functions for threads for getdata, display & coordinates
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Private Sub getdata()
        Do While toShutDown = 0
            If myString <> StreamString(N) Then
                myString = StreamString(N)
                setData()
            End If
            Thread.Sleep(100)
        Loop
    End Sub

    Private Sub display()
        Do While toShutDown = 0
            If myLanguage <> Language Then
                setLanguage()
                myLanguage = Language
            End If
            If myUIState <> UIState Then
                setUI()
                myUIState = UIState
            End If

            ' Input handlings
            If ddeInput <> "" Then
                parseInput()
                Me.tbxInput.Text = ddeInput
                ddeInput = ""
            End If

            ' Temp Actions
            If ddeOutput <> "" Then
                Me.tbxOutput.Text = ddeOutput & vbCrLf
                ddeOutput = ""
            End If

            tcpHealthCheck()
            Thread.Sleep(500)
        Loop
    End Sub

    ' Below are UI realted functions
    ''''''''''''''''''''''''''''''''
    Private Sub setLanguage()
        ' Generated by GUI Generator - Start

' Generated by GUI Generator - End
End Sub

    Private Sub setUI()
        If myFontSizeState <> FontSizeState Then
            myFontSize = FontSize
            myFontSizeState = FontSizeState
        Else : myFontSize = 0
        End If

Try
' Generated by GUI Generator - Start

            ' Generated by GUI Generator - End
        Catch ex As Exception
        End Try
    End Sub

    ' parseInput
    Private Sub parseInput()
        On Error Resume Next
        ' Trim unnecessary characters
        'ddeInput = Replace(ddeInput, "'", "")          ' ** dde穦笆奔 ' 腹

' Set ddeInput into InputRow as array
InputRow = Split(ddeInput, vbCrLf)

        ' Init TeletextActiveCode
        '        TeletextActiveCode(N) = Language & ":"
        TeletextActiveCode(N) = 1 & ":"

        ' Parsing
        Dim i As Integer
        For i = 0 To InputRow.Length - 1
            ' QUOTE CASE
            If InStr(InputRow(i), "PS|QUOTE!") Then    ' ** Change From --> If InStr(InputRow(i), "PS|QUOTE!(") Then
                Dim Var = Split(InputRow(i).Substring(InputRow(i).IndexOf("!") + 1), ",")   ' ** Change From --> Dim Var() = Split(util.GetBetween(InputRow(i), "PS|QUOTE!(", ")"), ",")
                If InStr(TeletextActiveCode(N), Var(0)) = False Then TeletextActiveCode(N) &= Var(0) & "," ' ** Add --> If InStr(TeletextActiveCode(N), Var(0)) = False Then
            End If
        Next
    End Sub

    ' setData (Streaming)
    Private Sub setData()
        On Error Resume Next
        Dim ddeOutput_tmp As String

        ' Parsing
        Dim i As Integer
        For i = 0 To InputRow.Length - 1
            If InputRow(i) <> "" Then
                ' QUOTE CASE
                If InStr(InputRow(i), "PS|QUOTE!") Then     ' ** Change from --> If InStr(InputRow(i), "PS|QUOTE!(") Then
                    Dim Var = Split(InputRow(i).Substring(InputRow(i).IndexOf("!") + 1), ",")   ' ** Change from --> Dim Var() = Split(util.GetBetween(InputRow(i), "PS|QUOTE!(", ")"), ",")
                    Dim Value = getQuoteValue(Var(0), Var(1))
                    If Value <> "" Then
                        ddeOutput_tmp &= InputRow(i) & ":" & Value & vbCrLf
                    End If
                End If
            End If
        Next
        ddeOutput &= ddeOutput_tmp
    End Sub

    ' getQuoteValue
    Private Function getQuoteValue(ByVal Code As String, ByVal Type As String)
        On Error Resume Next

        ' Digiting
        Code = foap.Digiting(Code)
        Code = Replace(Code, "-HK", "")

        ' ** BY CHUNG
        If InStr(Code, "-CN") Then
            Code = Replace(Code, "SZ", "")
            Code = Replace(Code, "SH", "")
        End If

        ' Set myString to Row()
        If InStr(myString, "~") = False Then Exit Function
        Dim Row() = Split(myString, "~")

        ' Main processing
        Dim i As Integer
        For i = 0 To Row.Length - 1
            Dim Field() = Split(Row(i), ";")
            If Code = Field(0) Then
                If Type = "name" Then
                    Return Field(1)
                ElseIf Type = "open" Then
                    Return Field(3)
                ElseIf Type = "high" Then
                    Return Field(4)
                ElseIf Type = "low" Then
                    Return Field(5)
                ElseIf Type = "last" Then
                    Return Field(6)
                ElseIf Type = "chg" Then
                    Return Field(7)
                ElseIf Type = "bid" Then
                    Return Field(8)
                ElseIf Type = "ask" Then
                    Return Field(9)
                ElseIf Type = "vol" Then
                    Return Field(10)
                ElseIf Type = "turn" Then
                    Return Field(11)
                ElseIf Type = "pe" Then
                    Return Field(12)
                ElseIf Type = "yield" Then
                    Return Field(13)
                ElseIf Type = "pchg" Then
                    If (Val(Field(5)) - Val(Field(7))) > 0 Then
                        Return Round(Val(Field(7)) / (Val(Field(5)) - Val(Field(7))) * 100, 3)
                    End If
                End If
                Return "N/A"
            End If
        Next
    End Function

    ' Initial parameter
    Public Sub initParameter(ByVal Para As String)
        Parameter = Para
    End Sub

    ' Temp Actions
    Private Sub btnRun_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnRun.Click
        ddeInput = Me.tbxInput.Text
    End Sub

End Class

-------------

资源ddeServer.resx

<pre>

<?xml version="1.0" encoding="utf-8"?>
<root>
<!--
    Microsoft ResX Schema
    Version 1.3
    The primary goals of this format is to allow a simple XML format
    that is mostly human readable. The generation and parsing of the
    various data types are done through the TypeConverter classes
    associated with the data types.
    Example:
    ... ado.net/XML headers & schema ...
    <resheader name="resmimetype">text/microsoft-resx</resheader>
    <resheader name="version">1.3</resheader>
    <resheader name="reader">System.Resources.ResXResourceReader, System.Windows.Forms, ...</resheader>
    <resheader name="writer">System.Resources.ResXResourceWriter, System.Windows.Forms, ...</resheader>
    <data name="Name1">this is my long string</data>
    <data name="Color1" type="System.Drawing.Color, System.Drawing">Blue</data>
    <data name="Bitmap1" mimetype="application/x-microsoft.net.object.binary.base64">
        [base64 mime encoded serialized .NET Framework object]
    </data>
    <data name="Icon1" type="System.Drawing.Icon, System.Drawing" mimetype="application/x-microsoft.net.object.bytearray.base64">
        [base64 mime encoded string representing a byte array form of the .NET Framework object]
    </data>
    There are any number of "resheader" rows that contain simple
    name/value pairs.
    Each data row contains a name, and value. The row also contains a
    type or mimetype. Type corresponds to a .NET class that support
    text/value conversion through the TypeConverter architecture.
    Classes that don't support this are serialized and stored with the
    mimetype set.
    The mimetype is used forserialized objects, and tells the
    ResXResourceReader how to depersist the object. This is currently not
    extensible. For a given mimetype the value must be set accordingly:
    Note - application/x-microsoft.net.object.binary.base64 is the format
    that the ResXResourceWriter will generate, however the reader can
    read any of the formats listed below.
    mimetype: application/x-microsoft.net.object.binary.base64
    value   : The object must be serialized with
            : System.Serialization.Formatters.Binary.BinaryFormatter
            : and then encoded with base64 encoding.
    mimetype: application/x-microsoft.net.object.soap.base64
    value   : The object must be serialized with
            : System.Runtime.Serialization.Formatters.Soap.SoapFormatter
            : and then encoded with base64 encoding.

    mimetype: application/x-microsoft.net.object.bytearray.base64
    value   : The object must be serialized into a byte array
            : using a System.ComponentModel.TypeConverter
            : and then encoded with base64 encoding.
    -->
<xsd:schema id="root" xmlns="" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:msdata="urn:schemas-microsoft-com:xml-msdata">
    <xsd:element name="root" msdata:IsDataSet="true">
      <xsd:complexType>
        <xsd:choice maxOccurs="unbounded">
          <xsd:element name="data">
            <xsd:complexType>
              <xsd:sequence>
                <xsd:element name="value" type="xsd:string" minOccurs="0" msdata:Ordinal="1" />
                <xsd:element name="comment" type="xsd:string" minOccurs="0" msdata:Ordinal="2" />
              </xsd:sequence>
              <xsd:attribute name="name" type="xsd:string" msdata:Ordinal="1" />
              <xsd:attribute name="type" type="xsd:string" msdata:Ordinal="3" />
              <xsd:attribute name="mimetype" type="xsd:string" msdata:Ordinal="4" />
            </xsd:complexType>
          </xsd:element>
          <xsd:element name="resheader">
            <xsd:complexType>
              <xsd:sequence>
                <xsd:element name="value" type="xsd:string" minOccurs="0" msdata:Ordinal="1" />
              </xsd:sequence>
              <xsd:attribute name="name" type="xsd:string" use="required" />
            </xsd:complexType>
          </xsd:element>
        </xsd:choice>
      </xsd:complexType>
    </xsd:element>
</xsd:schema>
<resheader name="resmimetype">
    <value>text/microsoft-resx</value>
</resheader>
<resheader name="version">
    <value>1.3</value>
</resheader>
<resheader name="reader">
    <value>System.Resources.ResXResourceReader, System.Windows.Forms, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
</resheader>
<resheader name="writer">
    <value>System.Resources.ResXResourceWriter, System.Windows.Forms, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
</resheader>
<data name="btnRun.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
    <value>False</value>
</data>
<data name="btnRun.DefaultModifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
    <value>Assembly</value>
</data>
<data name="btnRun.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
    <value>Assembly</value>
</data>
<data name="tbxOutput.DefaultModifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
    <value>Assembly</value>
</data>
<data name="tbxOutput.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
    <value>False</value>
</data>
<data name="tbxOutput.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
    <value>Assembly</value>
</data>
<data name="tbxInput.DefaultModifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
    <value>Assembly</value>
</data>
<data name="tbxInput.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
    <value>False</value>
</data>
<data name="tbxInput.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
    <value>Assembly</value>
</data>
<data name="ddeClient.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
    <value>Assembly</value>
</data>
<data name="ddeClient.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
    <value>False</value>
</data>
<data name="ddeClient.DefaultModifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
    <value>Assembly</value>
</data>
<data name="$this.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
    <value>False</value>
</data>
<data name="$this.Language" type="System.Globalization.CultureInfo, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
    <value>(Default)</value>
</data>
<data name="$this.TrayLargeIcon" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
    <value>False</value>
</data>
<data name="$this.Localizable" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
    <value>False</value>
</data>
<data name="$this.GridSize" type="System.Drawing.Size, System.Drawing, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a">
    <value>8, 8</value>
</data>
<data name="$this.Name">
    <value>ddeServer</value>
</data>
<data name="$this.DrawGrid" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
    <value>True</value>
</data>
<data name="$this.TrayHeight" type="System.Int32, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
    <value>25</value>
</data>
<data name="$this.SnapToGrid" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
    <value>True</value>
</data>
<data name="$this.DefaultModifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
    <value>Assembly</value>
</data>
<data name="$this.Icon" type="System.Drawing.Icon, System.Drawing, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a" mimetype="application/x-microsoft.net.object.bytearray.base64">
    <value>
        AAABAAEAICAAAAAAAACoCAAAFgAAACgAAAAgAAAAQAAAAAEACAAAAAAAgAQAAAAAAAAAAAAAAAEAAAAA
        AABZo0gAaqlcAE+fPQBWokUA2dnZANDQ0ADOz84AV6JGAOXl5QDr6+sAfrxwAFGlPwDKzckA1NTUAJq7
        kgB5r24A09PTALTFsQD09PQApb+gAOLi4gCKtYAAaKhZADiXIwDDysEAu9y0APj4+ACXyYwAPZooAF+l
        UABeq00Anr2XAI63hQBsql4ASp03AOHh4QBSoEEAr8OqAOXx4gDX19cAda9nAN3d3QBRoD8AOJgjALnb
        sgDU6dAASZ02AFSmQgD39/cAf71xAIm1fwB9sHIAcLVgAO727ADx8fEA3NzcAPD37gDByr8Aw+C8ALPX
        qwDS09IAeq9uAIKydwC7x7gA4fDeAJDFhABvq2IA6OjoALDJqgDy+PEAl7qPAGaoVwDV1dUA1+rSAKbR
        nABGnzIAgLF1AOz16gC4xrUAxuLAAHuwcADHzMYA7fTrAGmpWwA7mSYAmLuRADOVHQBwrGMAVaFEAPb7
        9gDY2NgAhbR6AK/DqwCww6wA4ODgAP7//gD9/f0A5OTkAJC7hwBjp1QAiLV/AHmvbQBEnjAAssSvAPLy
        8gCnz50A9vb2APPz8wDw8PAAUKQ9AO7u7gDR0tEA7e3tANbq0gCKtYEAbKpfAH2wcQB/sXQAkLeHAM/P
        zwBuq2AAqcGjAHauagCUx4kAbrRfAI22gwBUoUMA5ubmALLXqgA1liAAS545AKO/nQDR0dEAsdGqAPv7
        +wDc7dkAQpovAP///wAxlBsAz8/PAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
        AAAAAAAA////////////////////////////////////////////////////////////////////////
        ////////////////////////////////////////////////////////////////////////////////
        //////////8/PVz///////////////////////////////////8MUIGKH/////////////////8RAAAA
        AAAAAGT/////EYKKiopG/////////////////4OKioqKioqKU///BhUXioqKinb/////////////////
        VYqKioqKiop0//8hioqKioqKTP////////////////8VioqKioqKijIMFoqKioqKiop1////////////
        /////1uKioqKioqKPn6KioqKioqKijP///////8QN38JaxJqUkAtT4B7NEuKioqKioqKioqKZf////8N
        bomJiYmJiYlZNTiJiYmJiSZKL4qKioqKiop6////WoaJiRoJXgSE/yiKioocC3xBO4dfcRttioqKikL/
        //9siWAp////////AYqKioqKioqKimYxLEU6HoqKAf///xSJcP////////8BioqKioqKioqKioqKKwpJ
        GQtH/////2gw/////////wGKioqKioqKioqKioqKiooKTYX/////EBJD////////AYqKioqKioqKioqK
        ioqKiopUaQh3////BQg2BP////9XioqKioqKioqKioqKioqKiooAbxQF/////wUjYUj//w+KioqKioqK
        ioqKioqKioqKigf//w3/////////JwQ8YoqKioqKioqKioqKioqKioqKA/////////////////9EioqK
        ioqKioqKioqKioqKiooD/////////////////w6KioqKioqKioqKioqKioqKiiT/////////////////
        E4qKioqKioqKeCCKioqKioqKAv////////////////9nioqKioqKY07/E4qKioqKiooC////////////
        /////1GKioqKVn3///8lioqKioqKiiL/////////////////BoqKioh5/////xiKioqKioqKKv//////
        ////////////LoodOf///////1gCAgNzcl0G//////////////////8HD///////////////////////
        /////////////////w7/////////////////////////////////////////////////////////////
        ////////////////////////////////////////////////////////////////////////////////
        /////////////////////////////////8f///8H/8AeB//AGAf/wBgH/8AAB//AAAfgAAAHgAAABwBA
        AAcPwAAHH8AAB5/AAAePwAABw8AAAPDAAAb+AAAH/8AAB//AAAf/wAAH/8AQB//AcAf/wPAH/+H4B//n
        ////7///////////////////
</value>
</data>
</root>

</pre>

--------------

最后写一个类，启动dde服务，把接收到的数据，放置到excel中。

启动和结束代码

Public Sub BeginDDEServer()

System.Diagnostics.Debug.WriteLine("-------------- Begin DDE Server Test --------------")

ClearVariable()

' Initialize the DDE subsystem. This only needs to be done once.
If g_lInstID <> 0 Then EndDDEServer()

DDEInitial()

'TranslateError()

    ' set topics in "QUOTE, DES, ESTIMATES, FUNDA, HISTORY, FINET"
    DDECreateStringHandles("PS")
    CreateDDETopic("QUOTE") ',('EUR-FX','last')
    CreateDDETopic("DES")
    CreateDDETopic("ESTIMATES")
    CreateDDETopic("FUNDA")
    CreateDDETopic("HISTORY")
    CreateDDETopic("FINET")

'TranslateError()
DDEServerRegister(g_lInstID, g_hszDDEServer)

'TranslateError()

End Sub

Public Sub CreateDDETopic(ByRef strTopic As String)
DDECreateStringHandles("", strTopic)
End Sub

Public Sub EndDDEServer()
'TranslateError()

DDEFreeStringHandles()
'TranslateError()

DDEServerUnregister()
'TranslateError()

    ' Break down the link with the DDE subsystem.
    DDEUninitialize()
    'TranslateError()

ClearVariable()
System.Diagnostics.Debug.WriteLine("------------------- end DDE Server Test -----------------------")

End Sub

原文如下

Public Class ddeClient
    '*************************************************************************
    '    created:    2005/08/03
    '    created:    3:8:2005   15:31
    '    filename:     D:/vbdde/ddeClient.vb
    '    file path:    D:/vbdde
    '    file base:    Win32
    '    file ext:    vb
    '    author:        Peter
    '
    '*************************************************************************
    Inherits System.Windows.Forms.UserControl

Private newExcelDDE As Object
Private oldTanslateString As String

#Region " Windows 窗体设计器生成的代码 "

Public Sub New()
MyBase.New()

'该调用是 Windows 窗体设计器所必需的。
InitializeComponent()

'在 InitializeComponent() 调用之后添加任何初始化
oldTanslateString = ""

        newExcelDDE = New ExcelDDE
        ' Start DDE Server (By Peter)
        newExcelDDE.BeginDDEServer()
        'Timer1.Enabled = True
        DDETimer.Enabled = True
        DDETimer.Interval = 400
        DDETimer.Start()

End Sub

    'UserControl 重写 dispose 以清理组件列表。
    Protected Overloads Overrides Sub Dispose(ByVal disposing As Boolean)
        If disposing Then
            If Not (components Is Nothing) Then
                components.Dispose()
            End If

            ' Stop DDEServer (By Peter)
            ddeInput = ""
            ddeOutput = ""
            oldTanslateString = ""
            newExcelDDE.EndDDEServer()
        End If
        MyBase.Dispose(disposing)
    End Sub

'Windows 窗体设计器所必需的
Private components As System.ComponentModel.IContainer

    '注意: 以下过程是 Windows 窗体设计器所必需的
    '可以使用 Windows 窗体设计器修改此过程。
    '不要使用代码编辑器修改它。
    Public WithEvents CtrlName As System.Windows.Forms.Label
    Public WithEvents DDETimer As System.Windows.Forms.Timer
    <System.Diagnostics.DebuggerStepThrough()> Private Sub InitializeComponent()
        Me.components = New System.ComponentModel.Container
        Me.DDETimer = New System.Windows.Forms.Timer(Me.components)
        Me.CtrlName = New System.Windows.Forms.Label
        Me.SuspendLayout()
        '
        'DDETimer
        '
        Me.DDETimer.Interval = 1000
        '
        'CtrlName
        '
        Me.CtrlName.Font = New System.Drawing.Font("宋体", 18.0!, System.Drawing.FontStyle.Regular, System.Drawing.GraphicsUnit.Point, CType(134, Byte))
        Me.CtrlName.ForeColor = System.Drawing.SystemColors.ControlLight
        Me.CtrlName.Location = New System.Drawing.Point(0, 0)
        Me.CtrlName.Name = "CtrlName"
        Me.CtrlName.Size = New System.Drawing.Size(48, 24)
        Me.CtrlName.TabIndex = 0
        Me.CtrlName.Text = "DDE"
        '
        'PSDde
        '
        Me.BackColor = System.Drawing.SystemColors.Desktop
        Me.Controls.Add(Me.CtrlName)
        Me.Name = "PSDde"
        Me.Size = New System.Drawing.Size(48, 24)
        Me.ResumeLayout(False)

End Sub

#End Region

    Private Sub DDETimer_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles DDETimer.Tick
        ' Input handlings
        If newExcelDDE.TanslateString.ToString().Trim.Equals("") Then
            ddeInput = ""
            ddeOutput = ""
            oldTanslateString = ""
            Exit Sub
        End If
        If Not oldTanslateString.Equals(newExcelDDE.TanslateString.ToString()) Then '修改20050922
            oldTanslateString = newExcelDDE.TanslateString.ToString()
            ddeInput = newExcelDDE.TanslateString.ToString()
        End If

If ReferenceEquals(ddeOutput, Nothing) Then Exit Sub
If ddeOutput.Trim.Equals("") Then Exit Sub

        newExcelDDE.TanslateStringWithValue = ddeOutput
        newExcelDDE.UpdateExcel()
        '''添加的语句
        ddeOutput = ""
    End Sub
End Class

----资源文件ddeclient.resx

<pre>

</pre>

----------------------

粘贴结束，dde说起来不是什么难以理解的东西，也许大家都一样，困在了那么一点上，花费了好久，才知道原来如此。

能够把自己多年以前的东西分享出来，有幸被人借鉴，也算是一种幸运。