8_ExcelVBE/getRTD.bas at master · AlignmentSystems/8_ExcelVBE · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
Attribute VB_Name = "getRTD"
Option Explicit
Option Compare Text
Option Base 0
'============================================================================================================================
'
'
'   Author      :       John Greenan
'   Email       :       john.greenan@alignment-systems.com
'   Company     :       Alignment Systems Limited
'   Date        :       3rd April 2014
'
'   Purpose     :       Matching Engine in Excel VBA for Alignment Systems Limited
'
'   References  :       See VB Module FL for list extracted from VBE
'   References  :
'============================================================================================================================
Dim mCollection As VBA.Collection
Dim oShell As IWshRuntimeLibrary.WshShell

Function GetRTDServersUsedByActiveWorkbook()
'============================================================================================================================
'
'
'   Author      :       John Greenan
'   Email       :       john.greenan@alignment-systems.com
'   Company     :       Alignment Systems Limited
'   Date        :       3rd April 2014
'
'   Purpose     :       Matching Engine in Excel VBA for Alignment Systems Limited
'
'   References  :       See VB Module FL for list extracted from VBE
'   References  :
'============================================================================================================================
'Constants
Const strMethodName As String = "getRTD.GetRTDServersUsedByActiveWorkbook "
Const strRTDSignature = "=RTD("""
'Variables
Dim oWorkbook As Excel.Workbook
Dim oWorkSheet As Excel.Worksheet
Dim oCell As Excel.Range
Dim strRTDProgID As String
Dim lngCount As Long
Dim strRTDServerFileLocation As String
Dim strClassIDFromProgID As String
Dim strCodeBase As String

Set oWorkbook = ThisWorkbook

For Each oWorkSheet In oWorkbook.Worksheets
    For Each oCell In oWorkSheet.UsedRange.Cells
        If StrComp(strRTDSignature, Left(oCell.Formula, Len(strRTDSignature)), vbTextCompare) = 0 Then
            strRTDProgID = Mid(oCell.Formula, (Len(strRTDSignature) + 1), InStr(Len(strRTDSignature) + 1, oCell.Formula, """", vbTextCompare) - (Len(strRTDSignature) + 1))
            'Debug.Print "[" & oCell.Address & "]" & oCell.Formula & "{" & strRTDProgID & "}"
            AddToCollection (strRTDProgID)
        End If
    Next
Next

'We have a collection of RTD ProgIDs now...
Set oShell = New IWshRuntimeLibrary.WshShell

For lngCount = 1 To mCollection.count
    strRTDServerFileLocation = GetCodeBase(mCollection(lngCount))
    If Len(strRTDServerFileLocation) <> 0 Then
        Debug.Print "RTD Server Codebase located at:" & GetCodeBase(mCollection(lngCount))
    End If
Next

End Function

Function GetCodeBase(ProgID As String) As String
'============================================================================================================================
'
'
'   Author      :       John Greenan
'   Email       :       john.greenan@alignment-systems.com
'   Company     :       Alignment Systems Limited
'   Date        :       3rd April 2014
'
'   Purpose     :       Matching Engine in Excel VBA for Alignment Systems Limited
'
'   References  :       See VB Module FL for list extracted from VBE
'   References  :
'============================================================================================================================
'Constants
Const strMethodName As String = "getRTD.GetCodeBase "
Const strRegRoot As String = "HKEY_CLASSES_ROOT\"
Const strRegClsId As String = "CLSID\"
Const strRegInprocServerCodeBase As String = "\InprocServer32\Codebase"
'Variables
Dim strCodeBase As String
Dim strClassIDFromProgID As String

'HKEY_CLASSES_ROOT\alignmentsystems.node2rtd2\CLSID
'HKEY_CLASSES_ROOT\CLSID\{B856EB46-BCA3-4A44-9DC9-8995C37680CB}

'-----------------------------------
On Error GoTo ErrHandler1
strClassIDFromProgID = oShell.RegRead(strRegRoot & ProgID & "\" & strRegClsId)
'Debug.Print strClassIDFromProgID

On Error GoTo 0


'-----------------------------------
On Error GoTo ErrHandler2
strCodeBase = oShell.RegRead(strRegRoot & strRegClsId & strClassIDFromProgID & strRegInprocServerCodeBase)
'Debug.Print strCodeBase

GetCodeBase = strCodeBase

Exit Function
ErrHandler1:
'We failed to get the HKEY_CLASSES_ROOT\progid\CLSID
GetCodeBase = ""
Exit Function

ErrHandler2:
'We failed to get the HKEY_CLASSES_ROOT\CLSID
GetCodeBase = ""
Exit Function


End Function

Function AddToCollection(RTDStringOfProgID As String)
'============================================================================================================================
'
'
'   Author      :       John Greenan
'   Email       :       john.greenan@alignment-systems.com
'   Company     :       Alignment Systems Limited
'   Date        :       3rd April 2014
'
'   Purpose     :       Matching Engine in Excel VBA for Alignment Systems Limited
'
'   References  :       See VB Module FL for list extracted from VBE
'   References  :
'============================================================================================================================
'Constants
Const strMethodName As String = "getRTD.RTDStringOfProgID "

If mCollection Is Nothing Then
    Set mCollection = New Collection
End If

On Error Resume Next
mCollection.Add RTDStringOfProgID, RTDStringOfProgID
On Error GoTo 0

End Function