Extract EagleML via Excel - VBA Module Code
- Natalie Gesin (Deactivated)
- Dmitry Donosiyan (Unlicensed)
Owned by Natalie Gesin (Deactivated)
The following code is used to prepare and generate the extract of EagleML object data.
Attribute VB_Name = "Module1"
Option Explicit
'Prepares parameters for the extract using a feed type of the object type, being extracted
Function PrepareExtractParams(feedType As String) As Object
Dim ExtractParams As Object
Dim SecAlias, FromDate, ToDate, FromEffectiveDate, ToEffectiveDate, Ticker, PrimaryAssetId, SourceName, OnlyHeld, HeldPositionSources, EntitySelectionType, EntitySelectionValue, EntityXrefType, MaxRows
Set ExtractParams = CreateObject("scripting.dictionary")
ExtractParams.Add "FeedType", feedType
If StrComp(feedType, "SMFEXTRACT", vbTextCompare) = 0 Then
SecAlias = Range("F15").Text
FromDate = Range("F17").Text
ToDate = Range("F19").Text
OnlyHeld = Range("F21").Text
HeldPositionSources = Range("F23").Text
MaxRows = Range("F25").Text
If SecAlias <> "" Then
ExtractParams.Add "securityalias", SecAlias
End If
If FromDate <> "" Then
ExtractParams.Add "fromdate", Replace(FromDate, ":", "-")
End If
If ToDate <> "" Then
ExtractParams.Add "todate", Replace(ToDate, ":", "-")
End If
If StrComp(OnlyHeld, "yes", vbTextCompare) = 0 Then
ExtractParams.Add "onlyheld", "Y"
Else
ExtractParams.Add "onlyheld", "N"
End If
If HeldPositionSources <> "" Then
ExtractParams.Add "heldpositionsources", HeldPositionSources
End If
If MaxRows <> "" Then
ExtractParams.Add "maxrows", MaxRows
End If
Set PrepareExtractParams = ExtractParams
End If
If StrComp(feedType, "WRHSPOSITIONEXTRACT", vbTextCompare) = 0 Or StrComp(feedType, "WRHSTRADEEXTRACT", vbTextCompare) = 0 Then
SecAlias = Range("F15").Text
FromDate = Range("F17").Text
ToDate = Range("F19").Text
FromEffectiveDate = Range("F21").Text
ToEffectiveDate = Range("F23").Text
PrimaryAssetId = Range("F25").Text
Ticker = Range("F27").Text
SourceName = Range("F29").Text
EntitySelectionType = Range("F31").Text
EntitySelectionValue = Range("F33").Text
EntityXrefType = Range("F35").Text
MaxRows = Range("F37").Text
If SecAlias <> "" Then
ExtractParams.Add "securityalias", SecAlias
End If
If FromDate <> "" Then
ExtractParams.Add "fromdate", Replace(FromDate, ":", "-")
End If
If ToDate <> "" Then
ExtractParams.Add "todate", Replace(ToDate, ":", "-")
End If
If FromEffectiveDate <> "" Then
ExtractParams.Add "FromEffectiveDate", Replace(FromEffectiveDate, ":", "-")
End If
If ToEffectiveDate <> "" Then
ExtractParams.Add "ToEffectiveDate", Replace(ToEffectiveDate, ":", "-")
End If
If PrimaryAssetId <> "" Then
ExtractParams.Add "primaryassetid", PrimaryAssetId
End If
If Ticker <> "" Then
ExtractParams.Add "ticker", Ticker
End If
If SourceName <> "" Then
ExtractParams.Add "sourcename", SourceName
End If
If EntitySelectionType <> "" Then
ExtractParams.Add "entityselectiontype", EntitySelectionType
ExtractParams.Add "entityselectionvalue", EntitySelectionValue
End If
If StrComp(EntitySelectionType, "EntityXrefId", vbTextCompare) = 0 And EntityXrefType <> "" Then
ExtractParams.Add "EntityXrefType", EntityXrefType
End If
If MaxRows <> "" Then
ExtractParams.Add "maxrows", MaxRows
End If
Set PrepareExtractParams = ExtractParams
End If
If StrComp(feedType, "ENTITYEXTRACT", vbTextCompare) = 0 Then
FromDate = Range("F15").Text
ToDate = Range("F17").Text
EntitySelectionType = Range("F19").Text
EntitySelectionValue = Range("F21").Text
EntityXrefType = Range("F23").Text
MaxRows = Range("F25").Text
If FromDate <> "" Then
ExtractParams.Add "fromdate", Replace(FromDate, ":", "-")
End If
If ToDate <> "" Then
ExtractParams.Add "todate", Replace(ToDate, ":", "-")
End If
If EntitySelectionType <> "" Then
ExtractParams.Add "entityselectiontype", EntitySelectionType
ExtractParams.Add "entityselectionvalue", EntitySelectionValue
End If
If StrComp(EntitySelectionType, "EntityXrefId", vbTextCompare) = 0 And EntityXrefType <> "" Then
ExtractParams.Add "EntityXrefType", EntityXrefType
End If
If MaxRows <> "" Then
ExtractParams.Add "maxrows", MaxRows
End If
Set PrepareExtractParams = ExtractParams
End If
If StrComp(feedType, "REFTIMESERIESEXTRACT", vbTextCompare) = 0 Then
FromDate = Range("F15").Text
ToDate = Range("F17").Text
MaxRows = Range("F19").Text
If FromDate <> "" Then
ExtractParams.Add "fromdate", Replace(FromDate, ":", "-")
End If
If ToDate <> "" Then
ExtractParams.Add "todate", Replace(ToDate, ":", "-")
End If
If MaxRows <> "" Then
ExtractParams.Add "maxrows", MaxRows
End If
Set PrepareExtractParams = ExtractParams
End If
If StrComp(feedType, "SCHEDULEEXTRACT", vbTextCompare) = 0 Then
SecAlias = Range("F15").Text
FromDate = Range("F17").Text
ToDate = Range("F19").Text
FromEffectiveDate = Range("F21").Text
ToEffectiveDate = Range("F23").Text
PrimaryAssetId = Range("F25").Text
Ticker = Range("F27").Text
SourceName = Range("F29").Text
OnlyHeld = Range("F31").Text
HeldPositionSources = Range("F33").Text
MaxRows = Range("F35").Text
If SecAlias <> "" Then
ExtractParams.Add "securityalias", SecAlias
End If
If FromDate <> "" Then
ExtractParams.Add "fromdate", Replace(FromDate, ":", "-")
End If
If ToDate <> "" Then
ExtractParams.Add "todate", Replace(ToDate, ":", "-")
End If
If FromEffectiveDate <> "" Then
ExtractParams.Add "fromeffectivedate", FromEffectiveDate
End If
If ToEffectiveDate <> "" Then
ExtractParams.Add "toeffectivedate", ToEffectiveDate
End If
If PrimaryAssetId <> "" Then
ExtractParams.Add "primaryassetid", PrimaryAssetId
End If
If Ticker <> "" Then
ExtractParams.Add "ticker", Ticker
End If
If SourceName <> "" Then
ExtractParams.Add "sourcename", SourceName
End If
If StrComp(OnlyHeld, "yes", vbTextCompare) = 0 Then
ExtractParams.Add "onlyheld", "Y"
Else
ExtractParams.Add "onlyheld", "N"
End If
If HeldPositionSources <> "" Then
ExtractParams.Add "heldpositionsources", HeldPositionSources
End If
If MaxRows <> "" Then
ExtractParams.Add "maxrows", MaxRows
End If
Set PrepareExtractParams = ExtractParams
End If
If StrComp(feedType, "GENISSUEREXTRACT", vbTextCompare) = 0 Then
FromDate = Range("F15").Text
ToDate = Range("F17").Text
MaxRows = Range("F19").Text
If FromDate <> "" Then
ExtractParams.Add "fromdate", Replace(FromDate, ":", "-")
End If
If ToDate <> "" Then
ExtractParams.Add "todate", Replace(ToDate, ":", "-")
End If
If MaxRows <> "" Then
ExtractParams.Add "maxrows", MaxRows
End If
Set PrepareExtractParams = ExtractParams
End If
End Function
'Launches the extract process for a specified feed type
Sub Extract_Data(feedType As String)
Dim Login As String
Dim Pass As String
Dim ParamString As String
Dim ParamName As String
Dim ParamValue As String
Dim i As Integer
Dim Params As Object
Set Params = PrepareExtractParams(feedType)
Login = Range("F7").Text
Pass = ActiveSheet.TextBox1.Text
ParamString = ""
'Wrap the extract parameters, generated by the PrepareExtractParams method into the <taskParameter> nodes
For i = 0 To UBound(Params.Keys())
ParamName = Params.Keys()(i)
ParamValue = Replace(Params(ParamName), ":", "")
ParamString = ParamString & "<taskParameter><name>" & ParamName & "</name><dataType>S</dataType><value>" & ParamValue & "</value></taskParameter>"
Next
'Start an extract using the wrapped parameters
If Login <> "" And Pass <> "" Then
Extract_TSR "https://eagleeccprod1.eagleaccess.com", Login, Pass, ParamString, feedType
Else
MsgBox "Invalid authorization!"
End If
End Sub
'Makes an http request to the specified web-service with specified credentials using a specified request message, parses the result and imports it to a 'Extract result' list of the currently active workbook
Sub ExtractAndSave(data As String, url As String, Login As String, Pass As String, feedType As String)
Dim StrXML As String
Dim DirPathToXML As String
Dim xmlHtp As Object
Set xmlHtp = CreateObject("Microsoft.XmlHttp")
Dim xDoc As Object
Set xDoc = CreateObject("Microsoft.XMLDOM")
DirPathToXML = CurDir() & "\extract_file.xml"
'Make an HTTP POST reqeust to the web-service
With xmlHtp
.Open "POST", url & "/EagleMLWebService20", False, Login, Pass
.setRequestHeader "Content-Type", "text/xml; charset=utf-8"
.setRequestHeader "Host", Replace(url, "http://", "")
.setRequestHeader "Content-Encoding", "gzip, deflate"
.setRequestHeader "soapAction", "/EagleMLWebService/RunTaskRequestSync"
.send "" & data
xDoc.LoadXML .responseText
End With
'Parse the result
If xDoc.Text <> "" And InStr(xDoc.Text, "NO DATA") <= 0 And InStr(xDoc.Text, "NO_DATA") <= 0 Then
If InStr(xDoc.Text, "ERROR") > 0 Or InStr(xDoc.Text, "Failed") > 0 Then
MsgBox Replace(xDoc.Text, Left(xDoc.Text, InStr(xDoc.Text, "ERROR1") + 5), ""), vbCritical, "Error extrat"
Else
StrXML = Replace(xDoc.Text, Left(xDoc.Text, InStr(xDoc.Text, "<EagleML") - 1), "")
StrXML = Left(StrXML, InStr(StrXML, "</EagleML>") - 1)
If StrComp(feedType, "WRHSPOSITIONEXTRACT", vbTextCompare) = 0 Or StrComp(feedType, "WRHSTRADEEXTRACT", vbTextCompare) = 0 Then
StrXML = StrXML & "<warehouseTransaction></warehouseTransaction></EagleML>"
End If
If StrComp(feedType, "ENTITYEXTRACT", vbTextCompare) = 0 Then
StrXML = StrXML & "<entityTransaction></entityTransaction></EagleML>"
End If
If StrComp(feedType, "REFTIMESERIESEXTRACT", vbTextCompare) = 0 Or StrComp(feedType, "SCHEDULEEXTRACT", vbTextCompare) = 0 Or StrComp(feedType, "GENISSUEREXTRACT", vbTextCompare) = 0 Or StrComp(feedType, "SMFEXTRACT", vbTextCompare) = 0 Then
StrXML = StrXML & "<referenceTransaction></referenceTransaction></EagleML>"
End If
Shell "cmd.exe /c cd. > " & DirPathToXML
Open DirPathToXML For Output As #1
Print #1, StrXML
Reset
'Import the extract result to the 'Extract result' sheet
ImportXMLtoList DirPathToXML, feedType
End If
Else
MsgBox "NO DATA"
End If
Set xmlHtp = Nothing
Set xDoc = Nothing
End Sub
'Generates a SOAP request to the specified web-service using specified in the StrToEnv parameters, wrapped in the <taskParameter> nodes
Sub Extract_TSR(url As String, Login As String, Pass As String, StrToEnv As String, feedType As String)
Dim sEnv As String
Dim sRTR As String
sRTR = "<EagleML xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"" xsi:type=""RunTaskRequest"" eaglemlVersion=""2-0"" actualBuild=""1"" xmlns=""http://www.eagleinvsys.com/2011/EagleML-2-0"">"
sRTR = sRTR & "<header xmlns=""http://www.eagleinvsys.com/2011/EagleML-2-0"">"
sRTR = sRTR & "<messageId>" & Format(Now(), "yyyymmddThhmmss") & "</messageId>"
sRTR = sRTR & "<sentBy>user</sentBy>"
sRTR = sRTR & "<sendTo>http://www.eagleinvsys.com/eagle_ml-2-0_default_cm_control_message</sendTo>"
sRTR = sRTR & "</header>"
sRTR = sRTR & "<taskIdentifier>"
sRTR = sRTR & "<correlationId>" & Format(Now(), "yyyymmddThhmmss") & "</correlationId>"
sRTR = sRTR & "<businessTaskId>" + feedType + "</businessTaskId>"
sRTR = sRTR & "</taskIdentifier>"
sRTR = sRTR & "<taskTypeEnum>NEW</taskTypeEnum>"
sRTR = sRTR & "<synchronousExecution>yes</synchronousExecution>"
sRTR = sRTR & "<taskParameters>"
sRTR = sRTR & "<taskParameter>"
sRTR = sRTR & "<name>ActionType</name>"
sRTR = sRTR & "<dataType>S</dataType>"
sRTR = sRTR & "<value>EXTRACT</value>"
sRTR = sRTR & "</taskParameter>"
sRTR = sRTR & "<taskParameter>"
sRTR = sRTR & "<name>StreamName</name>"
sRTR = sRTR & "<dataType>S</dataType>"
sRTR = sRTR & "<value>eagle_ml-2-0_default_out_q</value>"
sRTR = sRTR & "</taskParameter>"
sRTR = sRTR & StrToEnv
sRTR = sRTR & "</taskParameters>"
sRTR = sRTR & "</EagleML>"
sEnv = "<?xml version=""1.0"" encoding=""utf-8""?>"
sEnv = sEnv & "<s:Envelope xmlns:s=""http://schemas.xmlsoap.org/soap/envelope/"">"
sEnv = sEnv & " <s:Body xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"" xmlns:xsd=""http://www.w3.org/2001/XMLSchema"">"
sEnv = sEnv & " <runTaskRequest xmlns=""http://www.eagleinvsys.com/2011/wsdl/EagleML-2-0"">"
sEnv = sEnv & sRTR
sEnv = sEnv & " </runTaskRequest>"
sEnv = sEnv & " </s:Body>"
sEnv = sEnv & "</s:Envelope>"
'Make a request to the web-service and import the result
ExtractAndSave sEnv, url, Login, Pass, feedType
End Sub
'Imports the xml from the path, specified in the PathToXML variable to the 'Extract result' sheet of the last created workbook
Sub ImportXMLtoList(PathToXML As String, feedType As String)
Dim wb As Workbook
Dim WorkbookToWrite As Workbook
Set WorkbookToWrite = Workbooks(Workbooks.Count)
'Prevent screen updates and alerts
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Import XML as table
Set wb = Workbooks.OpenXML(Filename:=PathToXML, LoadOption:=xlXmlLoadImportToList)
Application.DisplayAlerts = True
Dim resultSheet As Object
On Error Resume Next
'Create Extract result sheet if it does not exist and clear it, if it already exists
Set resultSheet = WorkbookToWrite.Sheets("Extract result")
If resultSheet Is Nothing Then
Set resultSheet = WorkbookToWrite.Sheets.Add(After:=WorkbookToWrite.Sheets(WorkbookToWrite.Sheets.Count))
resultSheet.Name = "Extract result"
Else
resultSheet.Cells.Clear
End If
wb.Sheets(1).UsedRange.Copy resultSheet.Range("A1")
wb.Close False
resultSheet.Activate
'Fix for the extracts, containing exaclty one row being displayed without headers in the table, when imported from XML
With ActiveSheet.UsedRange
ActiveSheet.Rows(.Rows.Count).Delete
End With
Application.ScreenUpdating = True
'Remove the namespaces from the column headers from Extract result and then remove the columns, which are not checked in the corresponing Profile list
Dim lastColumn As Long
lastColumn = resultSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Dim i As Integer
Dim j As Integer
Dim profileSheet As Object
Set profileSheet = WorkbookToWrite.Sheets(2)
Dim lastFilterRow As Long
lastFilterRow = profileSheet.Cells(Rows.Count, 2).End(xlUp).Row
Dim chosenFileNames As Object
Set chosenFileNames = CreateObject("scripting.dictionary")
For i = 1 To lastFilterRow - 2
If profileSheet.CheckBoxes("filterCheckBox" & i).Value = xlOn Then
chosenFileNames.Add profileSheet.Cells(i + 2, 2).Value, i
End If
Next i
For i = 1 To lastColumn
Dim curName As String
Dim firstColon As Integer
curName = resultSheet.Cells(1, i).Value
firstColon = 0
For j = 1 To Len(curName)
If StrComp(Mid(curName, j, 1), ":", vbTextCompare) = 0 Then
firstColon = j
Exit For
End If
Next j
curName = Right(curName, Len(curName) - firstColon)
resultSheet.Cells(1, i).Value = curName
Next i
For i = 1 To lastColumn
curName = resultSheet.Cells(1, i).Value
If StrComp(curName, "", vbTextCompare) = 0 Then
Exit For
End If
Dim lastNum As Integer
lastNum = 0
For j = Len(curName) To 1 Step -1
If IsNumeric(Mid(curName, j, 1)) Then
lastNum = j
Else
Exit For
End If
Next j
curName = Left(curName, lastNum - 1)
If Not chosenFileNames.Exists(curName) Then
resultSheet.Columns(i).EntireColumn.Delete
i = i - 1
End If
Next i
End Sub
'Selects all of the checkboxes on the currently active worksheet
Sub selectAll()
Dim checkBox As Object
For Each checkBox In ActiveSheet.CheckBoxes
checkBox.Value = xlOn
Next
End Sub
'Clears the selection from all of the checkboxes on the currently active worksheet
Sub unselectall()
Dim checkBox As Object
For Each checkBox In ActiveSheet.CheckBoxes
checkBox.Value = xlOff
Next
End Sub
Sub GenerateSMF()
CreateNewWorkbook ("SMFEXTRACT")
End Sub
Sub ClickSMF()
Extract_Data ("SMFEXTRACT")
End Sub
Sub GenerateWarehousePosition()
CreateNewWorkbook ("WRHSPOSITIONEXTRACT")
End Sub
Sub ClickWarehousePosition()
Extract_Data ("WRHSPOSITIONEXTRACT")
End Sub
Sub GenerateWarehouseTrade()
CreateNewWorkbook ("WRHSTRADEEXTRACT")
End Sub
Sub ClickWarehouseTrade()
Extract_Data ("WRHSTRADEEXTRACT")
End Sub
Sub GenerateGenericEntity()
CreateNewWorkbook ("ENTITYEXTRACT")
End Sub
Sub ClickGenericEntity()
Extract_Data ("ENTITYEXTRACT")
End Sub
Sub GenerateTimeSeries()
CreateNewWorkbook ("REFTIMESERIESEXTRACT")
End Sub
Sub ClickTimeSeries()
Extract_Data ("REFTIMESERIESEXTRACT")
End Sub
Sub GenerateSchedule()
CreateNewWorkbook ("SCHEDULEEXTRACT")
End Sub
Sub ClickSchedule()
Extract_Data ("SCHEDULEEXTRACT")
End Sub
Sub GenerateIssuer()
CreateNewWorkbook ("GENISSUEREXTRACT")
End Sub
Sub ClickIssuer()
Extract_Data ("GENISSUEREXTRACT")
End Sub
'Creates a new workbook, imports the current VBA module into it, asigns the macro to the button in the new workbook and launches it from withing the new workbook for a specified feed type
Sub CreateNewWorkbook(feedType As String)
Dim macroName As String
Dim sheetName As String
Dim x As Worksheet
Dim y As Worksheet
If StrComp(feedType, "WRHSPOSITIONEXTRACT", vbTextCompare) = 0 Then
macroName = "ClickWarehousePosition"
sheetName = "Extract WarehousePosition"
End If
If StrComp(feedType, "WRHSTRADEEXTRACT", vbTextCompare) = 0 Then
macroName = "ClickWarehouseTrade"
sheetName = "Extract WarehouseTrade"
End If
If StrComp(feedType, "ENTITYEXTRACT", vbTextCompare) = 0 Then
macroName = "ClickGenericEntity"
sheetName = "Extract GenericEntity"
End If
If StrComp(feedType, "REFTIMESERIESEXTRACT", vbTextCompare) = 0 Then
macroName = "ClickTimeSeries"
sheetName = "Extract TimeSeries"
End If
If StrComp(feedType, "SCHEDULEEXTRACT", vbTextCompare) = 0 Then
macroName = "ClickSchedule"
sheetName = "Extract Schedule"
End If
If StrComp(feedType, "GENISSUEREXTRACT", vbTextCompare) = 0 Then
macroName = "ClickIssuer"
sheetName = "Extract GenericIssuer"
End If
If StrComp(feedType, "SMFEXTRACT", vbTextCompare) = 0 Then
macroName = "ClickSMF"
sheetName = "Extract SMF"
End If
On Error Resume Next
Kill (CurDir() & "\MrXL1.bas")
'Export VBA module
ActiveWorkbook.VBProject.VBComponents("Module1").Export (CurDir() & "\MrXL1.bas")
Set x = Sheets(sheetName)
Sheets(Array(sheetName)).Copy
Workbooks(Workbooks.Count).Activate
'Copy the Profile on the second sheet and delete it from the main (first) sheet
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Profile"
fix_profile x, Sheets("Profile"), Sheets(sheetName)
Sheets(sheetName).Select
ActiveWorkbook.VBProject.VBComponents.Import (CurDir() & "\MrXL1.bas")
Workbook_BeforeSave True, False
Workbooks(Workbooks.Count).Activate
'Assign macro to the button on the main sheet of the new workbook
With Sheets(sheetName)
.Shapes("Button 1").OnAction = "'" & ActiveWorkbook.Name & "'!" & macroName
.Shapes("Button1").OnAction = "'" & ActiveWorkbook.Name & "'!" & macroName
.Buttons("Button1").Caption = "Refresh"
.Buttons("Button 1").Caption = "Refresh"
End With
Kill (CurDir() & "MrXL1.bas")
'Launch the assigned macro
Extract_Data (feedType)
ActiveWorkbook.Save
End Sub
'Prompt the user with a SaveAs dialog for a newly created workbook
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim FileNameVal As String
If SaveAsUI Then
FileNameVal = Application.GetSaveAsFilename(, "Excel Macro-Enabled Workbook (*.xlsm), *.xlsm")
Cancel = True
If FileNameVal = "False" Then 'User pressed cancel
Exit Sub
End If
Application.EnableEvents = False
ActiveWorkbook.SaveAs Filename:=FileNameVal, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.EnableEvents = True
End If
End Sub
'Remove a Profile section from the specified worksheet
Sub fix_profile(x As Worksheet, y As Worksheet, z As Worksheet)
x.Columns("M:S").Copy Destination:=y.Range("A1")
z.Columns("M:S").Clear
Dim checkBox As Object
For Each checkBox In z.CheckBoxes
checkBox.Delete
Next
z.Buttons("ButtonUnselectAll").Delete
z.Buttons("ButtonSelectAll").Delete
End Sub