李国帅
（对以前的文件做些补充，顺便编辑一下。）
随便罗嗦几句，自己已经好几年没有写什么东西了，而自己已经从事这一行好久了，希望能提供一些东西给大家，好与坏无所谓。 很早的时候做过DDE方面的程序，那是在2005年刚来深圳的时候，公司的一个产品需要在excel中动态显示数据，临时做了这么个东西，
那个产品是vb.net做的，因此就现在vc下面测试后移到vb中应用，还真的成功了。但是时间不经意间已经过去6年时间了，
自己早已经不再涉及vb的东西，看到有个朋友提到这方面的东西向我咨询，于是有了把自己的那个程序拿出来，希望能够对需要的人一点帮助。
逻辑流程
相关文件
其中ddeTerminal.vb包含核心类ExcelDDE,作用如下:
1从excel中生成的字符串，我要把这个字符串交给ps程序 2、ps返回的字符串，我要解析这个字符串， 3、取出与item值相互对应的值，放回excel的对应cell
相关代码详情
DDE 的步骤就不用列出了，网上很多，也能从代码中了解到。用到的函数如下
ddeWin32.vb
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
--------------
打包到一个类中
ddeTerminal.vb
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
Next
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
----------------
启动一个类获取数据
ddeServer.vb
'*************************************************************************
' 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//8hioqKioqKTP8VioqKioqKijIMFoqKioqKiop1
/1uKioqKioqKPn6KioqKioqKijP///8QN38JaxJqUkAtT4B7NEuKioqKioqKioqKZf8N
bomJiYmJiYlZNTiJiYmJiSZKL4qKioqKiop6WoaJiRoJXgSE/yiKioocC3xBO4dfcRttioqKikL/
//9siWApAYqKioqKioqKimYxLEU6HoqKAf///xSJcP8BioqKioqKioqKioqKKwpJ
GQtH/2gw/wGKioqKioqKioqKioqKiooKTYX/EBJDAYqKioqKioqKioqK
ioqKiopUaQh3BQg2BP9XioqKioqKioqKioqKioqKiooAbxQF/wUjYUj//w+KioqKioqK
ioqKioqKioqKigf//w3/JwQ8YoqKioqKioqKioqKioqKioqKA/9EioqK
ioqKioqKioqKioqKiooD/w6KioqKioqKioqKioqKioqKiiT/
E4qKioqKioqKeCCKioqKioqKAv9nioqKioqKY07/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>
--------------
ddeClient.vb
最后写一个类，启动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>
<?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="DDETimer.DefaultModifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
<value>Assembly</value>
</data>
<data name="DDETimer.Location" type="System.Drawing.Point, System.Drawing, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a">
<value>17, 17</value>
</data>
<data name="DDETimer.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
<value>Public</value>
</data>
<data name="CtrlName.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
<value>False</value>
</data>
<data name="CtrlName.DefaultModifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
<value>Assembly</value>
</data>
<data name="CtrlName.Modifiers" type="System.CodeDom.MemberAttributes, System, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
<value>Public</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.Locked" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
<value>False</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.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>80</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.Localizable" type="System.Boolean, mscorlib, Version=1.0.5000.0, Culture=neutral, PublicKeyToken=b77a5c561934e089">
<value>False</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.Name">
<value>PSDde</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>
</root>
</pre>
----------------------
粘贴结束，dde说起来不是什么难以理解的东西，也许大家都一样，困在了那么一点上，花费了好久，才知道原来如此。
能够把自己多年以前的东西分享出来，有幸被人借鉴，也算是一种幸运。
