赞
踩
李国帅
(对以前的文件做些补充,顺便编辑一下。)
随便罗嗦几句,自己已经好几年没有写什么东西了,而自己已经从事这一行好久了,希望能提供一些东西给大家,好与坏无所谓。 很早的时候做过DDE方面的程序,那是在2005年刚来深圳的时候,公司的一个产品需要在excel中动态显示数据,临时做了这么个东西,
那个产品是vb.net做的,因此就现在vc下面测试后移到vb中应用,还真的成功了。但是时间不经意间已经过去6年时间了,
自己早已经不再涉及vb的东西,看到有个朋友提到这方面的东西向我咨询,于是有了把自己的那个程序拿出来,希望能够对需要的人一点帮助。
其中ddeTerminal.vb包含核心类ExcelDDE,作用如下:
1从excel中生成的字符串,我要把这个字符串交给ps程序 2、ps返回的字符串,我要解析这个字符串, 3、取出与item值相互对应的值,放回excel的对应cell
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 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
----------------
启动一个类获取数据
'************************************************************************* ' 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
-------------
<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>
--------------
最后写一个类,启动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
----
<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说起来不是什么难以理解的东西,也许大家都一样,困在了那么一点上,花费了好久,才知道原来如此。
能够把自己多年以前的东西分享出来,有幸被人借鉴,也算是一种幸运。
Copyright © 2003-2013 www.wpsshop.cn 版权所有,并保留所有权利。