The Excel Development Platform: January 2019

Monday, 28 January 2019

VBA - Accessibility Meta Code

So I had some code to generate an illustrative tree of Excel window handles as a by-product for some code to get a pointer to Excel via its window handle using the Accessibility API. On StackOverflow, a questioner wanted something similar for Word. One can also imagine a future question wanted similar for PowerPoint. Code to reach all those three applications via their windows handles are in the previous post. However, I wanted to share the meta code because yet another use case may turn up in the future.

Option Explicit
Option Private Module

'******************************************************************************************************
'* Windows API function to traverse windows and grab attributes
'******************************************************************************************************
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hwnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _
(ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long

'******************************************************************************************************
'* Windows API function to get IDispatch COM pointer via Accessibility interface
'******************************************************************************************************
Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc.dll" ( _
  ByVal hwnd As LongPtr, ByVal dwId As Long, ByRef riid As Any, ByRef ppvObject As Object) As Long

'******************************************************************************************************
'* Entry Points
'******************************************************************************************************
Private Sub TestGetAccessibleOfficeObjects()
    Dim shtExcelReport As Excel.Worksheet
    Set shtExcelReport = ThisWorkbook.Worksheets.Item("Sheet2")
    Dim shtWordReport As Excel.Worksheet
    Set shtWordReport = ThisWorkbook.Worksheets.Item("Sheet3")
    
    Dim shtPowerPointReport As Excel.Worksheet
    Set shtPowerPointReport = ThisWorkbook.Worksheets.Item("Sheet4")
    
    'Dim shtOneNoteReport As Excel.Worksheet
    'Set shtOneNoteReport = ThisWorkbook.Worksheets.Item("Sheet5")
    
    
    GetAccessibleOfficeObjects shtExcelReport, "Excel"
    GetAccessibleOfficeObjects shtWordReport, "Word"
    GetAccessibleOfficeObjects shtPowerPointReport, "PowerPoint"
    'OneNote not accessible GetAccessibleOfficeObjects shtOneNoteReport, "OneNote"

End Sub

'******************************************************************************************************
'******************************************************************************************************
'* Main Controlling code
'******************************************************************************************************
'******************************************************************************************************
Private Function GetAccessibleOfficeObjects(ByVal shOutputSheet As Excel.Worksheet, ByVal sApplication As String)

    Dim sApplicationRootClass As String
    
    sApplicationRootClass = VBA.IIf(sApplication = "Excel", "XLMAIN", VBA.IIf(sApplication = "Word", "OpusApp", "Not yet implemented"))
    sApplicationRootClass = VBA.Switch(sApplication = "Excel", "XLMAIN", sApplication = "Word", "OpusApp", _
                sApplication = "PowerPoint", "PPTFrameClass", sApplication = "OneNote", "Framework::CFrame")
    
    Dim xmlHandlesReport As MSXML2.DOMDocument60
    Set xmlHandlesReport = GetWindows(sApplicationRootClass, True, shOutputSheet)
    
    WriteToSheetStart shOutputSheet, xmlHandlesReport.DocumentElement
    
    QueryInterfaceForAccessibility xmlHandlesReport
    
    UpdateCastableHandles xmlHandlesReport
     
    WriteCodeToGetAppObject xmlHandlesReport, sApplication, sApplicationRootClass
End Function

Private Function WriteCodeToGetAppObject(ByVal xmlHandlesReport As MSXML2.DOMDocument60, _
            ByVal sApplication As String, ByVal sApplicationRootClass As String)

    Dim xmlAppNode As MSXML2.IXMLDOMElement
    Set xmlAppNode = xmlHandlesReport.SelectSingleNode("//*[@obj_Application_Name]")
        
    '******************************************************************************************************
    '* Traverse up the tree to the root node, recording the window class
    '******************************************************************************************************
    Dim dicPathUp As Scripting.Dictionary
    Set dicPathUp = New Scripting.Dictionary
    
    Dim xmlTraverser As MSXML2.IXMLDOMElement
    Set xmlTraverser = xmlAppNode
    
    While Not xmlTraverser Is xmlHandlesReport.DocumentElement
        dicPathUp.Add xmlTraverser.getAttribute("class"), 0
        Set xmlTraverser = xmlTraverser.ParentNode
    Wend
    
    '******************************************************************************************************
    '* Reverse the path
    '******************************************************************************************************
    Dim dicPathDown As Scripting.Dictionary
    Set dicPathDown = New Scripting.Dictionary
    Dim lLoop As Long, lLoop2 As Long
    For lLoop = dicPathUp.Count - 1 To 0 Step -1
        
        dicPathDown.Add dicPathUp.Keys()(lLoop), 0
    Next lLoop
    
    '******************************************************************************************************
    '* Now write the code
    '******************************************************************************************************
    Dim dicCode As Scripting.Dictionary
    Set dicCode = New Scripting.Dictionary
    
    Dim sFuncName As String
    sFuncName = "Get" & sApplication & "AppObjectByIAccessible"
    
    dicCode.Add dicCode.Count, "Private Declare PtrSafe Function AccessibleObjectFromWindow Lib ""oleacc.dll"" ( _"
    dicCode.Add dicCode.Count, "    ByVal hwnd As LongPtr, ByVal dwId As Long, ByRef riid As Any, ByRef ppvObject As Object) As Long" & vbNewLine

    dicCode.Add dicCode.Count, "Private Declare Function FindWindowEx Lib ""user32"" Alias ""FindWindowExA"" _"
    dicCode.Add dicCode.Count, "    (ByVal hWnd1 As Long, ByVal hwnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long" & vbNewLine
    
    dicCode.Add dicCode.Count, "Public Function " & sFuncName & "() As Object"
    dicCode.Add dicCode.Count, "    Dim guid(0 To 3) As Long, acc As Object"
    dicCode.Add dicCode.Count, "    guid(0) = &H20400: guid(1) = &H0: guid(2) = &HC0: guid(3) = &H46000000"
    dicCode.Add dicCode.Count, ""
    dicCode.Add dicCode.Count, "    Dim alHandles(0 to " & dicPathUp.Count & ") As Long"
    
    dicCode.Add dicCode.Count, "    alHandles(0) = FindWindowEx(0, 0, """ & sApplicationRootClass & """, vbNullString)"
    For lLoop = 0 To dicPathDown.Count - 1
        Dim sInputHandle As String
        If lLoop = 0 Then sInputHandle = "lTopHandle" Else sInputHandle = "alHandles(" & lLoop & ")"
        sInputHandle = "alHandles(" & lLoop & ")"
        
        Dim sClass As String
        sClass = dicPathDown.Keys()(lLoop)
        dicCode.Add dicCode.Count, "    alHandles(" & lLoop + 1 & ") = FindWindowEx(" & sInputHandle & ",0,""" & sClass & """,vbNullString) "
    Next
    
    dicCode.Add dicCode.Count, "    If AccessibleObjectFromWindow(alHandles(" & dicPathDown.Count & "), -16&, guid(0), acc) = 0 Then"
    dicCode.Add dicCode.Count, "        Set " & sFuncName & " = acc.Application"
    dicCode.Add dicCode.Count, "    End If"
    dicCode.Add dicCode.Count, "End Function " & vbNewLine
    dicCode.Add dicCode.Count, "Sub Test" & sFuncName
    dicCode.Add dicCode.Count, "    Dim obj As Object"
    dicCode.Add dicCode.Count, "    Set obj = " & sFuncName & "()"
    dicCode.Add dicCode.Count, "    Debug.Print obj.Name"
    dicCode.Add dicCode.Count, "End Sub "
    
    Debug.Print VBA.Join(dicCode.Items, vbNewLine)
End Function

'******************************************************************************************************
'* Global functions
'******************************************************************************************************
Public Function PadHex(ByVal l32Bit As Long) As String
    PadHex = Right$("00000000" & Hex$(l32Bit), 8)
End Function

'******************************************************************************************************
'******************************************************************************************************
'* Windows Recursion Code
'******************************************************************************************************
'******************************************************************************************************
Private Function GetWindows(ByVal sRootClass As String, ByVal bWriteToSheet As Boolean, ByVal ws As Excel.Worksheet) As MSXML2.DOMDocument60
    Debug.Assert Not ws Is Nothing
    
    Dim xmlDocument As MSXML2.DOMDocument60
    Set xmlDocument = New MSXML2.DOMDocument60
    xmlDocument.LoadXML ""
    Debug.Assert xmlDocument.parseError = 0
    
    Dim xmlRoot As MSXML2.IXMLDOMElement
    Set xmlRoot = xmlDocument.DocumentElement
     
    Dim hwnd As Long
    hwnd = FindWindowEx(0, 0, sRootClass, vbNullString)
    
    AdornAttributes hwnd, xmlRoot
    GetWinInfo hwnd&, xmlRoot
    
    Set GetWindows = xmlDocument
End Function

Private Function AdornAttributes(ByVal hwnd As Long, xmlEle As MSXML2.IXMLDOMElement)
    If Not xmlEle Is Nothing Then
        Call xmlEle.setAttribute("hWndHex", PadHex(hwnd))
        Call xmlEle.setAttribute("hWnd", hwnd)
        Call xmlEle.setAttribute("title", GetTitle(hwnd))
        Call xmlEle.setAttribute("class", GetClassName2(hwnd))
    End If
End Function

Private Sub GetWinInfo(hParent As Long, ByVal xmlEle As MSXML2.IXMLDOMElement)
    '* Sub to recursively obtain window handles, classes and text
    '* given a parent window to search
    '* Based on code written by Mark Rowlinson - www.markrowlinson.co.uk - The Programming Emporium
    '* modified to write to Xml document instead of a worksheet
    Dim hwnd As Long
    
    hwnd = FindWindowEx(hParent, 0&, vbNullString, vbNullString)
    While hwnd <> 0
        
        Dim xmlChild As MSXML2.IXMLDOMElement
        Set xmlChild = xmlEle.OwnerDocument.createElement("Window")
        xmlEle.appendChild xmlChild
        
        AdornAttributes hwnd, xmlChild
        
        GetWinInfo hwnd, xmlChild
        
        hwnd = FindWindowEx(hParent, hwnd, vbNullString, vbNullString)
    Wend
End Sub

Private Function GetTitle(ByVal hwnd As Long, Optional ByVal bReportNa As Boolean) As String
    Dim lngRet As Long
    Dim strText As String
    
    strText = String$(100, Chr$(0))
    lngRet = GetWindowText(hwnd, strText, 100)
    If lngRet > 0 Then
        GetTitle = Left$(strText, lngRet)
    Else
        If bReportNa Then
            GetTitle = "N/A"
        End If
    End If
End Function

Private Function GetClassName2(ByVal hwnd As Long)
    Dim lngRet As Long
    Dim strText As String
    
    strText = String$(100, Chr$(0))
    lngRet = GetClassName(hwnd, strText, 100)
    GetClassName2 = Left$(strText, lngRet)
End Function

'******************************************************************************************************
'******************************************************************************************************
'* Write Report To Worksheet code
'******************************************************************************************************
'******************************************************************************************************
Private Function WriteToSheetStart(ByVal ws As Excel.Worksheet, ByVal xmlEle As MSXML2.IXMLDOMElement)
    ws.Cells.Clear
    ws.Activate
    ws.Cells(1, 1).Activate
    WriteToSheet ws, 1, 1, xmlEle
End Function

Private Function WriteToSheet(ByVal ws As Excel.Worksheet, ByVal lRow As Long, ByVal lColumn As Long, ByVal xmlEle As MSXML2.IXMLDOMElement) As Long
    
    Dim hwnd As Long
    hwnd = xmlEle.getAttribute("hWnd")
    
    
    Call xmlEle.setAttribute("rangeAnchor", "'" & ws.Name & "'!" & ws.Cells(lRow, lColumn).AddressLocal)
    Dim rngTest As Excel.Range
    Set rngTest = Application.Range(xmlEle.getAttribute("rangeAnchor"))
    Debug.Assert Not rngTest Is Nothing
    
    
    ws.Cells(lRow, lColumn).Formula = "'" & PadHex(hwnd) & " (" & CStr(hwnd) & ")"
    ws.Cells(lRow, lColumn + 1).Value = xmlEle.getAttribute("title")
    ws.Cells(lRow, lColumn + 2).Value = xmlEle.getAttribute("class")
    
    If xmlEle.ChildNodes.Length > 0 Then
    
        Dim xmlChildWindows As MSXML2.IXMLDOMNodeList
        Set xmlChildWindows = xmlEle.ChildNodes
        
        Dim lLength As Long
        lLength = xmlEle.ChildNodes.Length
        
        Dim lLoop As Long
        For lLoop = 0 To lLength - 1
            
            Dim xmlChild As MSXML2.IXMLDOMElement
            Set xmlChild = xmlEle.ChildNodes.Item(lLoop)
    
            lRow = WriteToSheet(ws, lRow + 1, lColumn + 3, xmlChild)
            
        Next lLoop
    End If
    
    WriteToSheet = lRow
End Function

Private Sub UpdateCastableHandles(ByVal xmlHandlesReport As MSXML2.DOMDocument60)
    Dim rngCastable As Excel.Range
    
    Dim xmlCastable As MSXML2.IXMLDOMNodeList
    Set xmlCastable = xmlHandlesReport.SelectNodes("//*[@ComInterface]")
    Debug.Assert xmlCastable.Length > 0
    
    Dim xmlCastableLoop As MSXML2.IXMLDOMElement
    For Each xmlCastableLoop In xmlCastable
        Set rngCastable = Application.Range(xmlCastableLoop.getAttribute("rangeAnchor"))
        rngCastable.Resize(1, 3).Interior.Color = rgbYellow
        
        rngCastable.EntireColumn.AutoFit
        rngCastable.Offset(0, 1).EntireColumn.AutoFit
        rngCastable.Offset(0, 2).EntireColumn.AutoFit
        
'        Dim rngAutoFitLoop As Excel.Range
'        For Each rngAutoFitLoop In rngCastable.Cells
'            rngAutoFitLoop.EntireColumn.AutoFit
'        Next
        
        rngCastable.AddComment
        rngCastable.Comment.Visible = True
        rngCastable.Comment.Text Text:=xmlCastableLoop.getAttribute("ComInterface")
        
        Dim shp As Shape
        Set shp = rngCastable.Comment.Shape
        
        shp.ScaleWidth 1.07, msoFalse, msoScaleFromTopLeft
        shp.ScaleHeight 0.29, msoFalse, msoScaleFromTopLeft
        shp.IncrementTop -20
        
    Next
    
    Dim xmlApp As MSXML2.IXMLDOMElement
    Set xmlApp = xmlHandlesReport.SelectSingleNode("//*[@obj_Application_Name]")
    
    Debug.Assert Not xmlApp Is Nothing

    Dim rngApp As Excel.Range
    Set rngApp = Application.Range(xmlApp.getAttribute("rangeAnchor"))
    rngApp.Resize(1, 3).Interior.Color = rgbLightGreen
    Debug.Assert Not rngApp Is Nothing
End Sub

'******************************************************************************************************
'******************************************************************************************************
'* Accessibility QueryInterface code
'******************************************************************************************************
'******************************************************************************************************
Private Sub QueryInterfaceForAccessibility(ByVal xmlHandlesReport As MSXML2.DOMDocument60)

    Dim dicHandles As Scripting.Dictionary
    Set dicHandles = AllHandles(xmlHandlesReport.DocumentElement)

    Dim guid(0 To 3) As Long, acc As Object
    guid(0) = &H20400
    guid(1) = &H0
    guid(2) = &HC0
    guid(3) = &H46000000
    
    Dim vHandleLoop As Variant
    For Each vHandleLoop In dicHandles.Keys
        
        Dim xmlNode As MSXML2.IXMLDOMElement
        Set xmlNode = xmlHandlesReport.SelectSingleNode("//Window[@hWnd='" & vHandleLoop & "']")
        
        If Not xmlNode Is Nothing Then
        
            Set acc = Nothing
            
            DoEvents
            Dim lReturnIDisp As Long
            lReturnIDisp = AccessibleObjectFromWindow(vHandleLoop, -16&, guid(0), acc)
            DoEvents
    
            If lReturnIDisp = 0 Then
                Call xmlNode.setAttribute("ComInterface", TypeName(acc))
                
                'Debug.Print PadHex(vHandleLoop), TypeName(acc)
                
                Dim sAppName As String
                sAppName = ""
                
                Dim objApp As Object
                Set objApp = Nothing
                On Error Resume Next
                sAppName = acc.Application.Name
                On Error GoTo 0
                If Len(sAppName) > 0 Then
                    Call xmlNode.setAttribute("obj_Application_Name", sAppName)
                End If
            End If
           
        End If
        Set acc = Nothing
    Next

End Sub

Private Function AllHandles(ByVal xmlEle As MSXML2.IXMLDOMElement) As Scripting.Dictionary
    
    Dim dicHandles As Scripting.Dictionary
    Set dicHandles = New Scripting.Dictionary

    Dim xmlHandlesList As MSXML2.IXMLDOMNodeList
    Set xmlHandlesList = xmlEle.SelectNodes("//*[@hWnd]")

    Dim vLoop As MSXML2.IXMLDOMElement
    For Each vLoop In xmlHandlesList
        dicHandles.Add CLng(vLoop.getAttribute("hWnd")), 0
    Next

    Set AllHandles = dicHandles
End Function

VBA - Code to get Excel, Word, PowerPoint from window handle

The following code shows three Office applications accessible from their windows handle (please ensure you have them running before testing). They work via the Accessibility API. I had some fun writing code to find the general pattern and that generic code follows in the next post.

Option Explicit
Option Private Module
Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc.dll" ( _
ByVal hwnd As LongPtr, ByVal dwId As Long, ByRef riid As Any, ByRef ppvObject As Object) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hwnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Public Function GetExcelAppObjectByIAccessible() As Object
Dim guid(0 To 3) As Long, acc As Object
guid(0) = &H20400 : guid(1) = &H0 : guid(2) = &HC0 : guid(3) = &H46000000
Dim alHandles(0 To 2) As Long
alHandles(0) = FindWindowEx(0, 0, "XLMAIN", vbNullString)
alHandles(1) = FindWindowEx(alHandles(0), 0, "XLDESK", vbNullString)
alHandles(2) = FindWindowEx(alHandles(1), 0, "EXCEL7", vbNullString)
If AccessibleObjectFromWindow(alHandles(2), -16&, guid(0), acc) = 0 Then
Set GetExcelAppObjectByIAccessible = acc.Application
End If
End Function
Public Function GetWordAppObjectByIAccessible() As Object
Dim guid(0 To 3) As Long, acc As Object
guid(0) = &H20400 : guid(1) = &H0 : guid(2) = &HC0 : guid(3) = &H46000000
Dim alHandles(0 To 3) As Long
alHandles(0) = FindWindowEx(0, 0, "OpusApp", vbNullString)
alHandles(1) = FindWindowEx(alHandles(0), 0, "_WwF", vbNullString)
alHandles(2) = FindWindowEx(alHandles(1), 0, "_WwB", vbNullString)
alHandles(3) = FindWindowEx(alHandles(2), 0, "_WwG", vbNullString)
If AccessibleObjectFromWindow(alHandles(3), -16&, guid(0), acc) = 0 Then
Set GetWordAppObjectByIAccessible = acc.Application
End If
End Function
Public Function GetPowerPointAppObjectByIAccessible() As Object
Dim guid(0 To 3) As Long, acc As Object
guid(0) = &H20400 : guid(1) = &H0 : guid(2) = &HC0 : guid(3) = &H46000000
Dim alHandles(0 To 2) As Long
alHandles(0) = FindWindowEx(0, 0, "PPTFrameClass", vbNullString)
alHandles(1) = FindWindowEx(alHandles(0), 0, "MDIClient", vbNullString)
alHandles(2) = FindWindowEx(alHandles(1), 0, "mdiClass", vbNullString)
If AccessibleObjectFromWindow(alHandles(2), -16&, guid(0), acc) = 0 Then
Set GetPowerPointAppObjectByIAccessible = acc.Application
End If
End Function
Sub TestGetExcelAppObjectByIAccessible()
Dim obj As Object
Set obj = GetExcelAppObjectByIAccessible()
Debug.Print obj.Name
End Sub
Sub TestGetWordAppObjectByIAccessible()
Dim obj As Object
Set obj = GetWordAppObjectByIAccessible()
Debug.Print obj.Name
End Sub
Sub TestGetPowerPointAppObjectByIAccessible()
Dim obj As Object
Set obj = GetPowerPointAppObjectByIAccessible()
Debug.Print obj.Name
End Sub

We can visualise what is going on with the following output reports, first the Excel windows handles report ...

Next the Word windows handles report ...

Finally the PowerPoint windows handles report ...

Tuesday, 22 January 2019

VBA - Sockets - Ruby - Java - Interop Nirvana with Sockets!

I hope you have noticed that inter-operability features large on this blog. Interop is easy with C# because it has an excellent COM interop library. Python and other languages also have COM APIs (not always as comprehensive as C#). But Java and Ruby do not have COM APIs callable from VBA. But this month we have shown that it is possible to use Sockets to connect with other processes (in the demos on the same machine but in real life potentially on remote machines). Thus, using sockets Excel VBA call anything, literally anything (so long the target langauge has a sockets API).

In the previous two articles I wrote sockets servers in Ruby then Java which ran simple calculations. They were just warm-up and test-beds to be honest. What I really wanted to show was VBA calling Ruby and Java.

So in the code below if you run the procedure TestWS2SendAndReceive() at line 159 then you can see the code will attempt to call the Java and Ruby servers, make sure you have these running. If all works then you should get output in the Immediate window

1+3 = 4.0
6*7 = 42.0

modVBASocketsClient Standard Module

Option Explicit
Option Private Module
'reference Windows Sockets 2 - Windows applications _ Microsoft Docs
'http://msdn.microsoft.com/en-us/library/windows/desktop/ms740673(v=vs.85).aspx
Private Const INVALID_SOCKET = -1
Private Const WSADESCRIPTION_LEN = 256
Private Const SOCKET_ERROR As Long = -1 'const #define SOCKET_ERROR (-1)
Private Enum AF
AF_UNSPEC = 0
AF_INET = 2
AF_IPX = 6
AF_APPLETALK = 16
AF_NETBIOS = 17
AF_INET6 = 23
AF_IRDA = 26
AF_BTH = 32
End Enum
Private Enum sock_type
SOCK_STREAM = 1
SOCK_DGRAM = 2
SOCK_RAW = 3
SOCK_RDM = 4
SOCK_SEQPACKET = 5
End Enum
Private Enum Protocol
IPPROTO_ICMP = 1
IPPROTO_IGMP = 2
BTHPROTO_RFCOMM = 3
IPPROTO_TCP = 6
IPPROTO_UDP = 17
IPPROTO_ICMPV6 = 58
IPPROTO_RM = 113
End Enum
'Private Type sockaddr
' sa_family As Integer
' sa_data(0 To 13) As Byte
'End Type
Private Type sockaddr_in
sin_family As Integer
sin_port(0 To 1) As Byte
sin_addr(0 To 3) As Byte
sin_zero(0 To 7) As Byte
End Type
'typedef UINT_PTR SOCKET;
Private Type udtSOCKET
pointer As Long
End Type
' typedef struct WSAData {
' WORD wVersion;
' WORD wHighVersion;
' char szDescription[WSADESCRIPTION_LEN+1];
' char szSystemStatus[WSASYS_STATUS_LEN+1];
' unsigned short iMaxSockets;
' unsigned short iMaxUdpDg;
' char FAR *lpVendorInfo;
'} WSADATA, *LPWSADATA;
Private Type udtWSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To WSADESCRIPTION_LEN) As Byte
szSystemStatus(0 To WSADESCRIPTION_LEN) As Byte
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As Long
End Type
'int errorno = WSAGetLastError()
Private Declare Function WSAGetLastError Lib "Ws2_32" () As Integer
' int WSAStartup(
' __in WORD wVersionRequested,
' __out LPWSADATA lpWSAData
');
Private Declare Function WSAStartup Lib "Ws2_32" _
(ByVal wVersionRequested As Integer, ByRef lpWSAData As udtWSADATA) As Long 'winsockErrorCodes2
' SOCKET WSAAPI socket(
' __in int af,
' __in int type,
' __in int protocol
');
Private Declare Function ws2_socket Lib "Ws2_32" Alias "socket" _
(ByVal AF As Long, ByVal stype As Long, ByVal Protocol As Long) As LongPtr
Private Declare Function ws2_closesocket Lib "Ws2_32" Alias "closesocket" _
(ByVal socket As Long) As Long
'int recv(
' SOCKET s,
' char *buf,
' int len,
' int flags
');
Private Declare Function ws2_recv Lib "Ws2_32" Alias "recv" _
(ByVal socket As Long, ByVal buf As LongPtr,
ByVal length As Long, ByVal flags As Long) As Long
'int WSAAPI connect(
' SOCKET s,
' const sockaddr *name,
' int namelen
');
Private Declare Function ws2_connect Lib "Ws2_32" Alias "connect" _
(ByVal S As LongPtr, ByRef name As sockaddr_in, ByVal namelen As Long) As Long
'int WSAAPI send(
' SOCKET s,
' const char *buf,
' int len,
' int flags
');
Private Declare Function ws2_send Lib "Ws2_32" Alias "send" _
(ByVal S As LongPtr, ByVal buf As LongPtr, ByVal buflen As Long, ByVal flags As Long) As Long
Private Declare Function ws2_shutdown Lib "Ws2_32" Alias "shutdown" _
(ByVal S As Long, ByVal how As Long) As Long
Private Declare Sub WSACleanup Lib "Ws2_32" ()
Private Enum eShutdownConstants
SD_RECEIVE = 0 '#define SD_RECEIVE 0x00
SD_SEND = 1 '#define SD_SEND 0x01
SD_BOTH = 2 '#define SD_BOTH 0x02
End Enum
Sub TestPortLongToBytes()
'redis is on port number 6379
Dim abytPortAsBytes() As Byte
abytPortAsBytes() = PortLongToBytes(6379)
Debug.Assert abytPortAsBytes(0) = 24
Debug.Assert abytPortAsBytes(1) = 235
End Sub
Private Function PortLongToBytes(ByVal lPort As Integer) As Byte()
ReDim abytReturn(0 To 1) As Byte
abytReturn(0) = lPort \ 256
abytReturn(1) = lPort Mod 256
PortLongToBytes = abytReturn()
End Function
Private Sub TestWS2SendAndReceive()
Dim sResponse As String
Const clJavaPort As Long = 6666
Const clRubyPort As Long = 3000
If WS2SendAndReceive(clJavaPort, "1+3" & vbCrLf, sResponse) Then
Debug.Print sResponse
End If
If WS2SendAndReceive(clRubyPort, "6*7" & vbCrLf, sResponse) Then
Debug.Print sResponse
End If
End Sub
Public Function WS2SendAndReceive(ByVal lPort As Long,
ByVal sText As String, ByRef psResponse As String) As Boolean
'https://docs.microsoft.com/en-gb/windows/desktop/api/winsock/nf-winsock-recv
If Right$(sText, 2) <> vbCrLf Then Err.Raise vbObjectError, , "Best suffix your sends with a new line (vbCrLf)"
psResponse = ""
'//----------------------
'// Declare and initialize variables.
Dim iResult As Integer : iResult = 0
Dim wsaData As udtWSADATA
Dim ConnectSocket As LongPtr
Dim clientService As sockaddr_in
Dim sendBuf() As Byte
sendBuf = StrConv(sText, vbFromUnicode)
Const recvbuflen As Long = 512
Dim recvbuf(0 To recvbuflen - 1) As Byte
'//----------------------
'// Initialize Winsock
Dim eResult As Long 'winsockErrorCodes2
eResult = WSAStartup(&H202, wsaData)
If eResult <> 0 Then
Debug.Print "WSAStartup failed with error: " & eResult
WS2SendAndReceive = False
GoTo SingleExit
End If
'//----------------------
'// Create a SOCKET for connecting to server
ConnectSocket = ws2_socket(AF_INET, SOCK_STREAM, IPPROTO_TCP)
If ConnectSocket = INVALID_SOCKET Then
Dim eLastError As Long 'winsockErrorCodes2
eLastError = WSAGetLastError()
Debug.Print "socket failed with error: " & eLastError
Call WSACleanup
WS2SendAndReceive = False
GoTo SingleExit
End If
'//----------------------
'// The sockaddr_in structure specifies the address family,
'// IP address, and port of the server to be connected to.
clientService.sin_family = AF_INET
clientService.sin_addr(0) = 127
clientService.sin_addr(1) = 0
clientService.sin_addr(2) = 0
clientService.sin_addr(3) = 1
Dim abytPortAsBytes() As Byte
abytPortAsBytes() = PortLongToBytes(lPort)
clientService.sin_port(1) = 235 '* 6379
clientService.sin_port(0) = 24
clientService.sin_port(1) = abytPortAsBytes(1)
clientService.sin_port(0) = abytPortAsBytes(0)
'//----------------------
'// Connect to server.
iResult = ws2_connect(ConnectSocket, clientService, LenB(clientService))
If (iResult = SOCKET_ERROR) Then
eLastError = WSAGetLastError()
Debug.Print "connect failed with error: " & eLastError
Call ws2_closesocket(ConnectSocket)
Call WSACleanup
WS2SendAndReceive = False
GoTo SingleExit
End If
'//----------------------
'// Send an initial buffer
Dim sendbuflen As Long
sendbuflen = UBound(sendBuf) - LBound(sendBuf) + 1
iResult = ws2_send(ConnectSocket, VarPtr(sendBuf(0)), sendbuflen, 0)
If (iResult = SOCKET_ERROR) Then
eLastError = WSAGetLastError()
Debug.Print "send failed with error: " & eLastError
Call ws2_closesocket(ConnectSocket)
Call WSACleanup
WS2SendAndReceive = False
GoTo SingleExit
End If
'Debug.Print "Bytes Sent: ", iResult
'// shutdown the connection since no more data will be sent
iResult = ws2_shutdown(ConnectSocket, SD_SEND)
If (iResult = SOCKET_ERROR) Then
eLastError = WSAGetLastError()
Debug.Print "shutdown failed with error: " & eLastError
Call ws2_closesocket(ConnectSocket)
Call WSACleanup
WS2SendAndReceive = False
GoTo SingleExit
End If
' receive only one message (TODO handle when buffer is not large enough)
iResult = ws2_recv(ConnectSocket, VarPtr(recvbuf(0)), recvbuflen, 0)
If (iResult > 0) Then
'Debug.Print "Bytes received: ", iResult
ElseIf (iResult = 0) Then
Debug.Print "Connection closed"
WS2SendAndReceive = False
Call ws2_closesocket(ConnectSocket)
Call WSACleanup
GoTo SingleExit
Else
eLastError = WSAGetLastError()
Debug.Print "recv failed with error: " & eLastError
End If
psResponse = Left$(StrConv(recvbuf, vbUnicode), iResult)
'Debug.Print psResponse
'// close the socket
iResult = ws2_closesocket(ConnectSocket)
If (iResult = SOCKET_ERROR) Then
eLastError = WSAGetLastError()
Debug.Print "close failed with error: " & eLastError
Call WSACleanup
WS2SendAndReceive = False
GoTo SingleExit
End If
Call WSACleanup
WS2SendAndReceive = True
SingleExit:
Exit Function
ErrHand:
End Function

Sockets - Java to Java - Sockets programming

Like most great languages Java has the ability open and read/write from/to sockets, a TCP/IP programming protocol lower than HTTP. This month I have been demonstrating Excel VBA acting as one endpoint for a Sockets connection (specifically communicating to Redis). That Excel VBA can talk to sockets means we can get VBA to talk to Java. I will write an VBA to Java article shortly but first it is better to write a Java to Java sockets application to see what is involved.

(And the more attentive amongst you will spot that I have just written a Ruby to Ruby sockets application so let's see if its true than Java is more verbose.)

The following code is a simple single-thread app (if you want multi-threaded, see the original article as we are here to demonstrate the sockets only.

JavaSocketsCalcClient.java

So this is the client code which simply reads a line of input in the form of a sum like "1+3" (actually you can do subtraction, divide and multiply), calls the server via sockets and then prints the return.

Here is the code for the file JavaSocketsCalcClient.java

//With thanks to https://www.baeldung.com/a-guide-to-java-sockets
import java.net.*;
import java.io.*;

public class JavaSocketsCalcClient {
    private Socket clientSocket;
    private PrintWriter out;
    private BufferedReader in;

    public void startConnection(String ip, int port) {
        try {
            clientSocket = new Socket(ip, port);
            out = new PrintWriter(clientSocket.getOutputStream(), true);
            in = new BufferedReader(new InputStreamReader(clientSocket.getInputStream()));
        } catch (Exception exc) {
            System.out.println(exc.getMessage());
        }
    }

    public String sendMessage(String msg) {
        try {
            out.println(msg);
            String resp = in.readLine();
            return resp;
        } catch (Exception exc) {
            System.out.println(exc.getMessage());
            return "";
        }
    }

    public void stopConnection() {
        try {
            in.close();
            out.close();
            clientSocket.close();
        } catch (Exception exc) {
            System.out.println(exc.getMessage());
        }
    }

    public static void main(String[] args) {
        try {
            GreetClient client = new GreetClient();
            client.startConnection("127.0.0.1", 6666);
            InputStreamReader reader = new InputStreamReader(System.in);
            BufferedReader in = new BufferedReader(reader);
            while (true) {
                System.out.println(client.sendMessage(in.readLine()));
            }
        } catch (Exception exc) {
            System.out.println(exc.getMessage());
        }
    }
}

So compile and run you need the following commands (and I'm surprised we do not use the .class suffix in the second to be honest).

N:\java\javaSockets>javac JavaSocketsCalcClient.java
N:\java\javaSockets>java JavaSocketsCalcClient

JavaSocketsCalcServer.java

This is the server which takes the sum string e.g. "1+3" and then parses it with a regular expression before calculating and returning the answer to the client.

//With thanks to https://www.baeldung.com/a-guide-to-java-sockets
import java.net.*;
import java.io.*;
import java.util.regex.Matcher;
import java.util.regex.Pattern;

public class JavaSocketsCalcServer {
    private ServerSocket serverSocket;
    private Socket clientSocket;
    private PrintWriter out;
    private BufferedReader in;

    public void start(int port) {
        try {
            serverSocket = new ServerSocket(port);
            System.out.println("Running on port " + port);

            String pattern = "(\\d+)\\s*(\\+|\\*|-|\\/)\\s*(\\d+)";

            // Create a Pattern object
            Pattern r = Pattern.compile(pattern);

            while (true) {

                clientSocket = serverSocket.accept();
                out = new PrintWriter(clientSocket.getOutputStream(), true);
                in = new BufferedReader(new InputStreamReader(clientSocket.getInputStream()));

                try {
                    System.out.println("waiting to read line ...");
                    String sum = in.readLine();
                    System.out.println("Received text:" + sum);
                    // Now create matcher object.
                    Matcher m = r.matcher(sum);
                    if (m.find()) {
                        Float arg0 = Float.parseFloat(m.group(1));
                        String op = m.group(2);
                        Float arg1 = Float.parseFloat(m.group(3));
                        String resp = "";
                        if (op.equals("+")) {
                            resp = String.valueOf(arg0 + arg1);
                        } else if (op.equals("-")) {
                            resp = String.valueOf(arg0 - arg1);
                        } else if (op.equals("*")) {
                            resp = String.valueOf(arg0 * arg1);
                        } else if (op.equals("/")) {
                            resp = String.valueOf(arg0 / arg1);
                        } else {
                            out.println("could not match operand");
                        }

                        out.println(sum + " = " + resp);
                    } else {
                        out.println("does not look calculable");
                    }
                } catch (Exception exc) {
                    System.out.println(exc.getMessage());
                }
            }
        } catch (Exception exc) {
            System.out.println(exc.getMessage());
        }
    }

    public void stop() {
        try {
            in.close();
            out.close();
            clientSocket.close();
            serverSocket.close();
        } catch (Exception exc) {
            System.out.println(exc.getMessage());
        }
    }

    public static void main(String[] args) {
        GreetServer server = new GreetServer();
        server.start(6666);
    }
}

So in a separate console window, do the following

N:\java\javaSockets>javac JavaSocketsCalcServer.java
N:\java\javaSockets>java JavaSocketsCalcServer

Here is a screenshot of the two consoles running and communicating

Keen observers of the code will realise they both run in endless loops. Never mind about that, I simply wanted to get the servers running and demonstrable.

What's Next?

So what's next is some code which shows VBA calling this Java server and also the Ruby server from the previous article to illustrate VBA can call Java and Ruby despite them not having a COM APIs.

Saturday, 19 January 2019

Sockets - Ruby to Ruby - Starting Ruby Sockets programming with a simple calculator app

Like most great languages Ruby has the ability open and read/write from/to sockets, a TCP/IP programming protocol lower than HTTP. This month I have been demonstrating Excel VBA acting as one endpoint for a Sockets connection (specifically communicating to Redis). That Excel VBA can talk to sockets means we can get VBA to talk to Ruby. I will write an VBA to Ruby article shortly but first it is better to write a Ruby to Ruby sockets application to see what is involved.

The application will be a simple calculator app. The client will pass a string such as "2*7" to the server, the server will parse the string into operands and operator, calculate the result and return the answer.

Ruby Development Preparation

I've not done any serious Ruby development. So I give a section which highlights some prep work to get an Ruby development environment up and running. First, a tip to see if Ruby is already installed. After that I will give some screenshots of the Ruby extensions that I installed into Microsoft Visual Studio Code.

How do you know if Ruby is Installed?

So I thought I had installed Ruby some time ago. So just taking my Ruby installation for a spin from the command line...

N:\>ruby -v
ruby 2.5.1p57 (2018-03-29 revision 63029) [x64-mingw32]

N:\>gem --version
2.7.6

N:\>mkdir ruby

N:\>cd ruby

N:\ruby>mkdir socketsServer

N:\ruby>cd socketsServer

N:\ruby\socketsServer>notepad "RubyHelloWorld.rb"

N:\ruby\socketsServer>type "RubyHelloWorld.rb"
puts "Hello World"

N:\ruby\socketsServer>ruby  "RubyHelloWorld.rb"
Hello World

This looks installed. Also above I have created some directories because I want to open a folder using Visual Studio Code.

Installing Visual Studio Code Ruby Extensions

I know Visual Studio Code is multi-language in that there is an ecosystem of language extensions. So I was confident in picking VS Code for my source code editor. I just needed some extensions. First up was to find from the list of extensions. To view extensions go to menu View->Extensions (that's intuitive!) and then select this one...

Once installed the extension's page should look like this ...

Then during development I wanted my code to be indented for me so I chose this Ruby Formatter extensions as well one as well.

Sockets Calculator

So I started with the code from this great article Socket Programming in Ruby – Code Like A Girl but the code only sends text messages to and fro. I wanted to up the functionality a little so I wrote a calculator app.

socketServer.rb

So here is the source code for the socketServer.rb

#With thanks to https://code.likeagirl.io/socket-programming-in-ruby-f714131336fd

require "socket"

puts "Starting the Server..................."
server = TCPServer.open(3000) # Server would listen on port 3000
loop { # Servers run forever
  client_connection = server.accept # Establish client connect connection
  begin
    clientText = client_connection.gets.chomp
    puts "clientText:" + clientText
    resp = ""

    #With thanks to https://regex101.com/
    parsed = /(\d+)\s*(\+|\*|-|\/)\s*(\d+)/.match(clientText)
    if parsed
      arg0 = Float(parsed[1])
      op = parsed[2]
      arg1 = Float(parsed[3])
      if op == "+"
        resp = arg0 + arg1
      elsif op == "-"
        resp = arg0 - arg1
      elsif op == "*"
        resp = arg0 * arg1
      elsif op == "/"
        resp = arg0 / arg1
      end
    else
      resp = "does not look calculable"
    end

    client_connection.puts("#{clientText}" + " = " + "#{resp}") # Send the answer to the client
    client_connection.puts("Closing the connection with #{client_connection}")
  rescue Exception => getException
    puts "#{getException}"
  end
  client_connection.close      # Disconnect from the client
}

socketClient.rb

So here is the source code for the socketClient.rb

#With thanks to https://code.likeagirl.io/socket-programming-in-ruby-f714131336fd
require "socket"

while sum = $stdin.gets.chomp # Read lines from the socket
  socket = TCPSocket.open("localhost", 3000)

  #puts "Starting the Client..................."

  socket.puts sum
  while message = socket.gets # Read lines from the socket
    puts message.chomp
  end
  socket.close                    # Close the socket
end

#puts "Closing the Client..................."

Running the program

So run each program in their own console and in the client and then start typing sums ...

Let regular Expressions do the heavy lifting

If you do decide to write a sockets application then you have a lot of string parsing ahead of you. I'd recommend regular expressions. I have found a superb online regular expressions tester, regex101.com. This site gives not just testing panel and quick reference but also it gives an explanation which is a feature that makes this website by far better than any other I have come across. Enjoy!