DDE never die

DDE is something you come across when you're using a brokerage firm's HTS, and it's a fairly old technology. But I still love it because it's a simple way to get real-time data. There is a DDE replacement called RTD, but for some reason it doesn't seem to be widely used. I made it so that the data is saved as a CSV file instead of stacked in a worksheet.

Sub startDDE()
  Dim aLinks, i As Long, strCode As String, Procedure As String
  
  aLinks = ThisWorkbook.LinkSources(xlOLELinks)
  aLinks = Filter(aLinks, ";시간", True)
  
  If IsEmpty(aLinks) Then
    Debug.Print "Error: DDE LinkSource Empty"
    Exit Sub
  End If
  For i = LBound(aLinks) To UBound(aLinks)
      strCode = Right(split(aLinks(i), ";")(0), 8)
      Procedure = "'onData " & Chr(34) & strCode & Chr(34) & "'"
      ThisWorkbook.SetLinkOnData aLinks(i), Procedure
  Next
  Call openFiles
  Debug.Print "Starting DDE Recording..."
End Sub

The Procedure variable stores the onData function and parameters that are called each time data is received.

Procedure = "'onData " & Chr(34) & strCode & Chr(34) & "'"

We have coded the onData() procedure to pass the ticker code as a parameter. The startDDE() procedure will run only the first time, and the onData() procedure will run every few thousand DDE link updates. To keep the code as short and fast as possible, we used worksheet functions frequently.

Sub onData(strCode As String)
  Dim rng As Range
  Dim str As String
  Dim idx As Long

  Call CheckFutures
  On Error GoTo ErrHandler
  
  If GetQueueStatus(QS_INPUT) <> 0 Then DoEvents
  
  idx = WorksheetFunction.Match(strCode, Main.Range(Main.[C1], Main.[C1].End(xlDown)), 0)
  Set rng = Main.Range(Main.Cells(idx, 2), Main.Cells(idx, 2).End(xlToRight))
  str = Join(Application.Transpose(Application.Transpose(rng.Value)), ",")
  
  Select Case Left(strCode, 3)
  Case "101": flFutures.WriteLine str: Debug.Print "onData: " & str
  Case "201": flCallOptions.WriteLine str
  Case "301": flPutoptions.WriteLine str
  End Select
  flAll.WriteLine str
  
  Set rng = Nothing
  Exit Sub
  
ErrHandler:
  Debug.Print "Error: " & Err.Description
  Err.Clear
  Call closeFiles
  Call stopDDE
End Sub

The parameter strCode that comes into the onData() procedure is the entry in the DDElink that was just updated, and the idea is to find this entry in the worksheet and save all of its rows to a CSV.

The worksheet will have futures and calls/puts together, and will save three CSV files, one for futures, one for calls, and one for puts. Futures, calls, and puts have ticker codes that start with 101~, 201~, 301~, and so on, so we can use this to separate the three. The Select Case syntax does just that.

  Select Case Left(strCode, 3)
  Case "101": flFutures.WriteLine str
  Case "201": flCallOptions.WriteLine str
  Case "301": flPutoptions.WriteLine str
  End Select

We extract only the first three characters from the string (str) to be output to a file and save them separately. However, it is inconvenient to save each of the three to a separate CSV, so we use flAll.WriteLine str to save them all without distinguishing between futures, calls, and puts.

The stopDDE() procedure is responsible for releasing the procedure from the DDE link and closing the CSV file it was writing to.

Sub stopDDE()
    Dim aLinks, i As Long

    aLinks = ThisWorkbook.LinkSources(xlOLELinks)
    If IsEmpty(aLinks) Then Exit Sub
    For i = LBound(aLinks) To UBound(aLinks)
        ThisWorkbook.SetLinkOnData aLinks(i), ""
    Next
    Call closeFiles
    Debug.Print "Ending DDE Recording..."
    End
End Sub

This time it is a procedure to open and close a CSV file. We use the scripting library instead of VB's legacy syntax. Since file handling is done in the two procedures below as well as in onData(), we use the following file objects as global variables

Dim fso As Object, flCallOptions, flPutoptions, flFutures, flAll
Sub openFiles()
  Dim fnCallOptions As String, fnPutOptions As String, fnFutures As String, fnAll As String
  Dim str As String
  
  fnFutures = ThisWorkbook.Path & "\" & Date & "_futures.csv"
  fnCallOptions = ThisWorkbook.Path & "\" & Date & "_calloptions.csv"
  fnPutOptions = ThisWorkbook.Path & "\" & Date & "_putoptions.csv"
  fnAll = ThisWorkbook.Path & "\" & Date & "_all.csv"
   
  Set fso = CreateObject("scripting.filesystemobject")
  
  '신규파일이면 컬럼명 추가, 기존파일이면 생략
  If Len(Dir(fnFutures)) = 0 Then str = "종목명,종목코드,시간,현재가,잔존일"
  Set flFutures = fso.OpenTextFile(fnFutures, 8, True)
  If Len(str) <> 0 Then flFutures.WriteLine str: str = ""
  
  If Len(Dir(fnCallOptions)) = 0 Then str = "종목명,종목코드,시간,현재가,잔존일,미결제약정,이론가,행사가격,델타,감마,베가,세타,로,내재변동성,역사적변동성,CD금리"
  Set flCallOptions = fso.OpenTextFile(fnCallOptions, 8, True)
  If Len(str) <> 0 Then flCallOptions.WriteLine str: str = ""
  
  If Len(Dir(fnPutOptions)) = 0 Then str = "종목명,종목코드,시간,현재가,잔존일,미결제약정,이론가,행사가격,델타,감마,베가,세타,로,내재변동성,역사적변동성,CD금리"
  Set flPutoptions = fso.OpenTextFile(fnPutOptions, 8, True)
  If Len(str) <> 0 Then flPutoptions.WriteLine str: str = ""
  
  If Len(Dir(fnAll)) = 0 Then str = "종목명,종목코드,시간,현재가,잔존일,미결제약정,이론가,행사가격,델타,감마,베가,세타,로,내재변동성,역사적변동성,CD금리"
  Set flAll = fso.OpenTextFile(fnAll, 8, True)
  If Len(str) <> 0 Then flAll.WriteLine str
End Sub

Sub closeFiles()
  On Error Resume Next
  flFutures.Close
  flCallOptions.Close
  flPutoptions.Close
  flAll.Close
  Set flFutures = Nothing
  Set flCallOptions = Nothing
  Set flPutoptions = Nothing
  Set flAll = Nothing
  Set fso = Nothing
End Sub

You may also need to close a chapter and email a CSV file of the day's work. The following is a common mailing procedure that you can find if you search for it. There are several ways to send emails, but I chose this one because it's the one I'm most familiar with. You'll need to set up your mail settings in Outlook beforehand.

(I haven't solved the problem yet, you have to press the [Allow] button, I think Outlook's security should fix it...)
(Update) As expected, there is a solution in Outlook Options, as shown below.

Sub sendMail()
  Dim OutApp As Object, OutMail As Object, BodyText As String
  Dim file_fut As String, file_cal As String, file_put As String
  Set OutApp = CreateObject("Outlook.Application")
  Set OutMail = OutApp.CreateItem(0)
  
  BodyText = _
    "Please do not reply to this email, as this inbox is not monitored." & Chr(13) & _
    "Best," & Chr(13) & _
    "Seungjoo from Seoul"
  
  On Error Resume Next
  With OutMail
    .To = "********@gmail.com"
    .CC = ""
    .BCC = ""
    .Subject = "KOSPI200 Futures and Options(" & Date & ")"
    .Body = BodyText
    file_fut = ThisWorkbook.Path & "\" & Date & "_futures.csv"
    file_cal = ThisWorkbook.Path & "\" & Date & "_calloptions.csv"
    file_put = ThisWorkbook.Path & "\" & Date & "_putoptions.csv"
    If Len(Dir(file_fut)) <> 0 Then .Attachments.Add file_fut
    If Len(Dir(file_cal)) <> 0 Then .Attachments.Add file_cal
    If Len(Dir(file_put)) <> 0 Then .Attachments.Add file_put
    .Send   'or use .Display
  End With
  On Error GoTo 0
  Set OutMail = Nothing
  Set OutApp = Nothing
  Debug.Print "Sent the data using e-mail..."
End Sub

However, there is one issue that I haven't seen when dealing with just one instrument, and I don't know if it's a memory leak due to the high number of DDE link updates, but sometimes the DDE link updates for futures stop updating (for OTM options, it may be the quotes as there is almost no trading, but not the futures quotes).

In my experience, this happens once in the morning and once in the afternoon. Initially, I used the last resort of quitting excel and reopening the file, but if I press F2 in the cell with the stuck DDE link to enter cell edit mode and then press ENTER to exit without modifying anything, it works fine.

So, as a last resort, I compared the time of the DDE link of the gift and the time of the computer, and if the difference was more than 3 minutes, I judged that the DDE link of the gift was stuck and sent F2 and ENTER. However, the DDE link was not revived at once, so the time difference of more than 3 minutes remained, causing dozens of F2 and ENTER key presses.

Naturally, the screen flashes, and my heart sinks. So to ensure that it only runs once, I stored the stuck DDElink time entry in the registry, and when it runs, I pull out the stuck time from the registry and compare it to the current DDElink time (If CDate(GetSetting("DDE20", "FUT", "F2")) = CDate(ts1) Then Exit Sub)

The procedure that does this is CheckFutures().

Sub CheckFutures()
  Dim ts0 As Date, ts1 As Date
  
  On Error Resume Next
  ts1 = RetTime(Main.[D2].Value2): ts0 = Time()
  If Err.Number <> 0 Then Exit Sub
  If CDate(GetSetting("DDE20", "FUT", "F2")) = CDate(ts1) Then Exit Sub
  
  If Abs(DateDiff("n", ts0, ts1)) > 3 Then
    Main.[D2].Activate
    With Application
      AppActivate .Caption: .SendKeys "{F2}": .SendKeys "{ENTER}": End With
    Call SaveSetting("DDE20", "FUT", "F2", ts1)
  End If
End Sub

'// DDE링크 시간포맷이 hhmmss이므로 이를 오늘자 시간으로 만들어주는 함수
Function RetTime(IntTime As Long) As Date
  RetTime = TimeSerial(Int(IntTime / 10000), Int((IntTime Mod 10000) / 100), (IntTime Mod 100))
End Function

Finally, we need to have it run automatically when the market opens in the morning and closes in the afternoon. We want to run startDDE at the opening of the day, stopDDE at the closing of the day to stop DDE recording, email the CSV file one minute later, and exit Excel one minute later.

This can be done in the _Open() event procedure that is fired when the workbook is opened.

Private Sub Workbook_Open()
  With Application
    On Error Resume Next
    .OnTime TimeValue("09:00:00"), "startDDE", , False
    .OnTime TimeValue("15:40:00"), "stopDDE", , False
    .OnTime TimeValue("15:41:00"), "sendMail", , False
    .OnTime TimeValue("15:42:00"), "shutDownThis", , False
  
    .OnTime TimeValue("09:00:00"), "startDDE"
    .OnTime TimeValue("15:40:00"), "stopDDE"
    .OnTime TimeValue("15:41:00"), "sendMail"
    .OnTime TimeValue("15:42:00"), "shutDownThis"
  End With
End Sub

The following is a procedure to exit Excel. Note that it saves on exit.

Sub shutDownThis()
  ThisWorkbook.Save
  Application.Quit
End Sub

Here's the full source code.

Option Explicit
'시스템큐
Declare Function GetQueueStatus Lib "user32" (ByVal fuFlags As Long) As Long
Public Const QS_KEY = &H1
Public Const QS_MOUSEMOVE = &H2
Public Const QS_MOUSEBUTTON = &H4
Public Const QS_MOUSE = (QS_MOUSEMOVE Or QS_MOUSEBUTTON)
Public Const QS_INPUT = (QS_MOUSE Or QS_KEY)

Dim fso As Object, flCallOptions, flPutoptions, flFutures, flAll

Sub startDDE()
  Dim aLinks, i As Long, strCode As String, Procedure As String
  
  aLinks = ThisWorkbook.LinkSources(xlOLELinks)
  aLinks = Filter(aLinks, ";시간", True)
  
  If IsEmpty(aLinks) Then
    Debug.Print "Error: DDE LinkSource Empty"
    Exit Sub
  End If
  For i = LBound(aLinks) To UBound(aLinks)
      strCode = Right(split(aLinks(i), ";")(0), 8)
      Procedure = "'onData " & Chr(34) & strCode & Chr(34) & "'"
      ThisWorkbook.SetLinkOnData aLinks(i), Procedure
  Next
  Call openFiles
  Debug.Print "Starting DDE Recording..."
End Sub

Sub onData(strCode As String)
  Dim rng As Range
  Dim str As String
  Dim idx As Long

  Call CheckFutures
  On Error GoTo ErrHandler
  
  If GetQueueStatus(QS_INPUT) <> 0 Then DoEvents
  
  idx = WorksheetFunction.Match(strCode, Main.Range(Main.[C1], Main.[C1].End(xlDown)), 0)
  Set rng = Main.Range(Main.Cells(idx, 2), Main.Cells(idx, 2).End(xlToRight))
  str = Join(Application.Transpose(Application.Transpose(rng.Value)), ",")
  
  Select Case Left(strCode, 3)
  Case "101": flFutures.WriteLine str: Debug.Print "onData: " & str
  Case "201": flCallOptions.WriteLine str
  Case "301": flPutoptions.WriteLine str
  End Select
  flAll.WriteLine str
  
  Set rng = Nothing
  Exit Sub
  
ErrHandler:
  Debug.Print "Error: " & Err.Description
  Err.Clear
  Call closeFiles
  Call stopDDE
End Sub

Sub stopDDE()
    Dim aLinks, i As Long

    aLinks = ThisWorkbook.LinkSources(xlOLELinks)
    If IsEmpty(aLinks) Then Exit Sub
    For i = LBound(aLinks) To UBound(aLinks)
        ThisWorkbook.SetLinkOnData aLinks(i), ""
    Next
    Call closeFiles
    Debug.Print "Ending DDE Recording..."
    End
End Sub

Sub openFiles()
  Dim fnCallOptions As String, fnPutOptions As String, fnFutures As String, fnAll As String
  Dim str As String
  
  fnFutures = ThisWorkbook.Path & "\" & Date & "_futures.csv"
  fnCallOptions = ThisWorkbook.Path & "\" & Date & "_calloptions.csv"
  fnPutOptions = ThisWorkbook.Path & "\" & Date & "_putoptions.csv"
  fnAll = ThisWorkbook.Path & "\" & Date & "_all.csv"
   
  Set fso = CreateObject("scripting.filesystemobject")
  
  '신규파일이면 컬럼명 추가, 기존파일이면 생략
  If Len(Dir(fnFutures)) = 0 Then str = "종목명,종목코드,시간,현재가,잔존일"
  Set flFutures = fso.OpenTextFile(fnFutures, 8, True)
  If Len(str) <> 0 Then flFutures.WriteLine str: str = ""
  
  If Len(Dir(fnCallOptions)) = 0 Then _
str = "종목명,종목코드,시간,현재가,잔존일,미결제약정,이론가,행사가격,델타,감마,베가,세타,로,내재변동성,역사적변동성,CD금리"
  Set flCallOptions = fso.OpenTextFile(fnCallOptions, 8, True)
  If Len(str) <> 0 Then flCallOptions.WriteLine str: str = ""
  
  If Len(Dir(fnPutOptions)) = 0 Then _
str = "종목명,종목코드,시간,현재가,잔존일,미결제약정,이론가,행사가격,델타,감마,베가,세타,로,내재변동성,역사적변동성,CD금리"
  Set flPutoptions = fso.OpenTextFile(fnPutOptions, 8, True)
  If Len(str) <> 0 Then flPutoptions.WriteLine str: str = ""
  
  If Len(Dir(fnAll)) = 0 Then _
str = "종목명,종목코드,시간,현재가,잔존일,미결제약정,이론가,행사가격,델타,감마,베가,세타,로,내재변동성,역사적변동성,CD금리"
  Set flAll = fso.OpenTextFile(fnAll, 8, True)
  If Len(str) <> 0 Then flAll.WriteLine str
End Sub

Sub closeFiles()
  On Error Resume Next
  flFutures.Close
  flCallOptions.Close
  flPutoptions.Close
  flAll.Close
  Set flFutures = Nothing
  Set flCallOptions = Nothing
  Set flPutoptions = Nothing
  Set flAll = Nothing
  Set fso = Nothing
End Sub

Sub sendMail()
  Dim OutApp As Object, OutMail As Object, BodyText As String
  Dim file_fut As String, file_cal As String, file_put As String
  Set OutApp = CreateObject("Outlook.Application")
  Set OutMail = OutApp.CreateItem(0)
  
  BodyText = _
    "Please do not reply to this email, as this inbox is not monitored." & Chr(13) & _
    "Best," & Chr(13) & _
    "Seungjoo from Seoul"
  
  On Error Resume Next
  With OutMail
    .To = "*******@gmail.com"
    .CC = ""
    .BCC = ""
    .Subject = "KOSPI200 Futures and Options(" & Date & ")"
    .Body = BodyText
    file_fut = ThisWorkbook.Path & "\" & Date & "_futures.csv"
    file_cal = ThisWorkbook.Path & "\" & Date & "_calloptions.csv"
    file_put = ThisWorkbook.Path & "\" & Date & "_putoptions.csv"
    If Len(Dir(file_fut)) <> 0 Then .Attachments.Add file_fut
    If Len(Dir(file_cal)) <> 0 Then .Attachments.Add file_cal
    If Len(Dir(file_put)) <> 0 Then .Attachments.Add file_put
    .Send   'or use .Display
  End With
  On Error GoTo 0
  Set OutMail = Nothing
  Set OutApp = Nothing
  Debug.Print "Sent the data using e-mail..."
End Sub

Sub shutDownThis()
  ThisWorkbook.Save
  Application.Quit
End Sub

Sub CheckFutures()
  Dim ts0 As Date, ts1 As Date
  
  On Error Resume Next
  ts1 = RetTime(Main.[D2].Value2): ts0 = Time()
  If Err.Number <> 0 Then Exit Sub
  If CDate(GetSetting("DDE20", "FUT", "F2")) = CDate(ts1) Then Exit Sub
  
  If Abs(DateDiff("n", ts0, ts1)) > 3 Then
    Main.[D2].Activate
    With Application
      AppActivate .Caption: .SendKeys "{F2}": .SendKeys "{ENTER}": End With
    Call SaveSetting("DDE20", "FUT", "F2", ts1)
  End If
End Sub

Function RetTime(IntTime As Long) As Date
  RetTime = TimeSerial(Int(IntTime / 10000), Int((IntTime Mod 10000) / 100), (IntTime Mod 100))
End Function