Extract EagleML via Excel - VBA Module Code
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