corrected the all button so it properly populates all plants

This commit is contained in:
2025-05-21 19:38:37 -05:00
parent 16578d7c45
commit eb609e9a47
6 changed files with 1664 additions and 0 deletions

140
GetAvalibleQuerys.bas Normal file
View File

@@ -0,0 +1,140 @@
Attribute VB_Name = "GetAvalibleQuerys"
Sub queryAvi()
On Error GoTo ErrorHandler ' Enable error handling
Dim req As New WinHttpRequest
Dim reqUrl As String
Dim plantSelect As String
Dim staticData As Worksheet
Dim jsonResponse As String
Dim json As Object
Dim sheetVersion As Object
Dim server As String
'where is our plant data to match too?
Dim plantData As Range
Set plantData = Sheet2.Range("A1:B30")
' clear the data if any is there
'Sheet1.Range("A8:C8").Clear
'get the plant server based on the selection
plantSelect = Sheets("Data").Range("E1").Value
' Check if we have a match before moving forward
Dim cell As Range
Dim plantFound As Boolean
plantFound = False
For Each cell In plantData
If cell.Value = plantSelect Then
' Found the server
If cell.Value = "All" Then
'Debug.Print "all servers were selected"
Exit For
Else
'Debug.Print "Server that was selected : " & cell.Offset(0, 1).Value
server = cell.Offset(0, 1).Value
Exit For
End If
Exit For
End If
Next cell
'if all is selected it will point to the test server.
If plantSelect = "All" Then
reqUrl = "http://usmcd1vms036:3000/api/datamart/getavalibleaquerys"
Else
' as iowa pet is on a differnt port we want to grab keep everything the same
If plantSelect = "Iowa ISBM, Iowa" Then
reqUrl = "http://" & server & ":3001/api/datamart/getavalibleaquerys"
Else
reqUrl = "http://" & server & ":3000/api/datamart/getavalibleaquerys"
End If
End If
'double checking the url
Debug.Print "Url to pull the querys form it " & reqUrl
'set the static data sheet
Set staticData = Sheet2
'clear the content so its always fresh
staticData.Range("D1:E20").ClearContents
' get the data
req.Open "GET", reqUrl, False
req.Send
If req.Status <> 200 Then
MsgBox req.Status & " - " & req.StatusText
End If
' Get the response text (JSON)
jsonResponse = req.ResponseText
' crtl + g to pull up the debut
' Debug print the raw JSON response
' Debug.Print jsonResponse
' Parse the JSON response using JsonConverter
Set json = JsonConverter.ParseJson(jsonResponse)
'Debug.Print json("sheetVersion")
Set dataArray = json("data")
' Set up the headers in the first row just for a reference
Set headerRow = Sheet2.Range("D1")
' Dump the querys into the table so we can use it in our list :)
If json("success") Then
'add the headers
' Loop through the first item to get the keys (name, endpoint)
h = 1
For Each Item In dataArray(1).Keys
' Debug.Print Item
headerRow.Cells(1, h).Value = Item ' Place the key as a header
h = h + 1
Next Item
' Populate the data below the headers
For j = 1 To dataArray.Count
i = 1
For Each Item In dataArray(j).Keys
headerRow.Offset(j, i - 1).Value = dataArray(j)(Item) ' Populate data under the headers
i = i + 1
Next Item
Next j
Else
MsgBox "Error: " & json("message")
End If
If json("sheetVersion") <> Sheet2.Range("I1").Value Then
MsgBox "There is a new version of the sheet please download the new version to get all the fixes, you do not need to but errors will not be supported on older versions! You can get a new sheet from NOAM logistics > plant mgt files"
Exit Sub
End If
Exit Sub
ErrorHandler:
' Handle specific error for connection issues
If Err.Number = -2147012867 Then
MsgBox "Please make sure you are connected to vpn, and or make sure the server is online.", vbCritical
Else
' Handle other errors
MsgBox "An unexpected error occurred: " & Err.Description, vbCritical
End If
End Sub

228
GetData.bas Normal file
View File

@@ -0,0 +1,228 @@
Attribute VB_Name = "GetData"
Sub getData()
On Error GoTo ErrorHandler ' Enable error handling
Dim plantSelect As String
Dim req As New WinHttpRequest
Dim reqUrl As String
Dim cell As Range
Dim plantFound As Boolean
Dim plantData As Range
Dim queryData As Range
Dim server As String
Dim queryToRun As String
Dim ws As Worksheet
Dim lastColumn As Integer
Dim dataRange As Variant
Dim json As Object
Dim dataArray As Object
Dim headerRow As Range
'where is our plant data to match too?
Set plantData = Sheet2.Range("A1:B30")
Set queryData = Sheet2.Range("D2:E100")
' what plant is selected
plantSelect = Sheets("Data").Range("E1").Value
'until the all function is created send a message box to check the server
'If plantSelect = "All" Then
' MsgBox "The ""All"" function is not fully operational please select a plant to move forward"
' Exit Sub
'End If
'if we are missing the query we want to warn everyone too
If Sheets("Data").Range("G1").Value = "" Then
MsgBox "Please select a query you want to pull before pressing the ""Get data"" button."
End If
'check if the data sheet was removed or changed and recreate it it was changed and then clear the data
On Error Resume Next
Set ws = Sheets("Data")
If ws Is Nothing Then
Set ws = Sheets.Add
ws.Name = "Data"
Else
'ws.Cells.Clear ' Clear existing data if the sheet already exists
Sheets("Data").Range("A5:BB50000").ClearContents
End If
On Error GoTo 0
'go back to the setup data sheet maybe :P
Sheets("Data").Select
' Sheets("Data").Range("A5:BB50000").ClearContents
' create the url from the plan
plantFound = False
For Each cell In plantData
If cell.Value = plantSelect Then
' Found the server
If cell.Value = "All" Then
Debug.Print "all servers were selected"
Exit For
Else
'Debug.Print "Server that was selected : " & cell.Offset(0, 1).Value
server = cell.Offset(0, 1).Value
Exit For
End If
Exit For
End If
Next cell
'get the query endpoint
For Each cell In queryData
If cell.Value = Sheets("Data").Range("G1").Value Then
'Debug.Print "Server that was selected : " & cell.Offset(0, 1).Value
queryToRun = cell.Offset(0, 1).Value
Exit For
End If
Next cell
' if the query would have extra parameters add them here
For Each cell In queryData
If cell.Value = Sheets("Data").Range("G1").Value Then
'Debug.Print "Server that was selected : " & cell.Offset(0, 1).Value
'queryToRun = queryToRun + cell.Offset(0, 2).Value
'add the first part of the additional critiera to the query
If Sheets("Data").Range("D2").Value <> "" Then
If Trim(Sheets("Data").Range("D2").Value) <> "" And Trim(Sheets("Data").Range("D3").Value) <> "" Then
queryToRun = queryToRun & "?" & Sheets("Data").Range("D2").Value & "=" & Sheets("Data").Range("D3").Value
If Sheets("Data").Range("E2").Value <> "" And Sheets("Data").Range("E3").Value <> "" Then
queryToRun = queryToRun & "&" & Sheets("Data").Range("E2").Value & "=" & Sheets("Data").Range("E3").Value
If Sheets("Data").Range("F2").Value <> "" And Sheets("Data").Range("F3").Value <> "" Then
queryToRun = queryToRun & "&" & Sheets("Data").Range("F2").Value & "=" & Sheets("Data").Range("F3").Value
End If
End If
ElseIf Trim(Sheets("Data").Range("E2").Value) <> "" And Trim(Sheets("Data").Range("E3").Value) <> "" Then
queryToRun = queryToRun & "?" & Sheets("Data").Range("E2").Value & "=" & Sheets("Data").Range("E3").Value
End If
End If
Exit For
End If
Next cell
'Debug.Print queryToRun
If plantSelect = "All" Then
'reqUrl = "http://localhost:4000" & queryToRun
getAllPlants queryToRun
Exit Sub
Else
' as iowa pet is on a differnt port we want to grab keep everything the same
If plantSelect = "Iowa ISBM, Iowa" Then
reqUrl = "http://" & server & ":3001" & queryToRun
Else
reqUrl = "http://" & server & ":3000" & queryToRun
End If
End If
Debug.Print reqUrl
'url is created get the request going.
req.Open "GET", reqUrl, False
req.Send
If req.Status <> 200 Then
MsgBox req.Status & " - " & req.StatusText & " - " & req.ResponseText
Exit Sub
End If
' Get the response text (JSON)
jsonResponse = req.ResponseText
' crtl + g to pull up the debut
' Debug print the raw JSON response
'Debug.Print jsonResponse
Set json = JsonConverter.ParseJson(jsonResponse)
Set dataArray = json("data")
'Debug.Print dataArray
' Check if dataArray is empty
If dataArray.Count = 0 Then
MsgBox "There is no data if you this is an error please try again, if repeats please constact support.", vbExclamation, "No Data"
Exit Sub 'just stop doing anything else
End If
' Set up the headers in the first row just for a reference
Set headerRow = Sheets("Data").Range("A1")
' Dump the querys into the table so we can use it in our list :)
If json("success") Then
'add the headers
' Loop through the first item to get the keys (name, endpoint)
h = 1
For Each Item In dataArray(1).Keys
' Debug.Print Item
headerRow.Cells(5, h).Value = Item ' Place the key as a header
h = h + 1
Next Item
' Disable screen updating and calculations for faster execution
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Debug.Print "Column count " & h
' Populate data row by row
Dim cellValue As Variant
Dim rowIndex As Integer
rowIndex = 6 ' Start from row 6
For j = 1 To dataArray.Count ' Iterate from the first element of dataArray
For x = 1 To h
'ws.Cells(rowIndex, x).Value = dataArray(j)(headerRow.Cells(5, x).Value)
cellValue = dataArray(j)(headerRow.Cells(5, x).Value)
If VarType(cellValue) = vbString Then
ws.Cells(rowIndex, x).Value = "'" & cellValue ' Prefixing with apostrophe forces Excel to treat it as text
Else
ws.Cells(rowIndex, x).Value = cellValue
End If
Next x
rowIndex = rowIndex + 1 ' Move to the next row
Next j
' Re-enable screen updating and calculations
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
' Determine the last column used based on the number of headers
lastColumn = h
' Automatically adjust the width of all used columns
ws.Columns(1).Resize(, lastColumn).AutoFit ' Adjust based on last column
Sheets("Data").Select
MsgBox "Data processing successful!"
Else
MsgBox "Error: " & json("message")
End If
Exit Sub
ErrorHandler:
' Handle specific error for connection issues
If Err.Number = -2147012867 Then
MsgBox "Please make sure you are connected to vpn, and or make sure the server is online.", vbCritical
ElseIf Err.Number = -2147012894 Then
MsgBox "Server is not reachable please try again later."
' Handle other errors
MsgBox "An unexpected error occurred: " & Err.Description, vbCritical
End If
End Sub

170
GetDataAllPlants.bas Normal file
View File

@@ -0,0 +1,170 @@
Attribute VB_Name = "GetDataAllPlants"
Sub getAllPlants(ByVal query As String)
Dim req As New WinHttpRequest
Dim json As Object
Dim dataArray As Object
Dim headerRow As Range
Dim plantData As Range
Dim reqUrl As String
Dim firstRound As Boolean
Dim lastRow As Long
'where is our plant data to match too?
Set plantData = Sheet2.Range("A2:A30")
Debug.Print "All plants running and the endpoint that will be hit: " & query
'check if the data sheet was removed or changed and recreate it it was changed and then clear the data
On Error Resume Next
Set ws = Sheets("Data")
If ws Is Nothing Then
Set ws = Sheets.Add
ws.Name = "Data"
Else
'ws.Cells.Clear ' Clear existing data if the sheet already exists
End If
On Error GoTo 0
firstRound = False
For Each cell In plantData
'Debug.Print "Server that was selected : " & cell.Offset(0, 1).Value
If cell.Value <> "" Then
' we dont want to try and get localhost
If cell.Value = "Dev Server" Then
GoTo SkipIteration
End If
' skip the test server too
If cell.Value = "TestServer" Then
GoTo SkipIteration
End If
' as iowa pet is on a differnt port we want to grab keep everything the same
If cell.Value = "Iowa ISBM, Iowa" Then
reqUrl = "http://" & cell.Offset(0, 1).Value & ":3001" & query
Else
reqUrl = "http://" & cell.Offset(0, 1).Value & ":3000" & query
End If
Debug.Print reqUrl
On Error Resume Next ' Ignore errors and continue execution
'url is created get the request going.
req.Open "GET", reqUrl, False
req.Send
If Err.Number <> 0 Then
Debug.Print "An error occurred: " & Err.Description
Else
'Debug.Print req.StatusText
On Error GoTo 0 ' Reset error handling to default
If req.Status <> 200 Then
Debug.Print req.Status & " - " & req.StatusText
Else
' Get the response text (JSON)
jsonResponse = req.ResponseText
Set json = JsonConverter.ParseJson(jsonResponse)
Set dataArray = json("data")
'how many we got
Debug.Print dataArray.Count
' Check if dataArray is empty
If dataArray.Count = 0 Then
'MsgBox "There is no data for " & cell.Value & ", if you this is an error please try again, if repeats please constact support.", vbExclamation, "No Data"
'Exit Sub 'just stop doing anything else
End If
'if we have over 15k lines just exit and direct the user to get the data from lst
If dataArray.Count > 15000 Then
MsgBox "There is more than 15,000 lines of data please, export the data from LST\n for perforance reasons no data will be loaded", vbExclamation, "No Data"
'Exit Sub 'just stop doing anything else
End If
'for the first plant we want to add the headers and then not do it again.
' Set up the headers in the first row just for a reference
Set headerRow = Sheets("Data").Range("A1")
' Dump the querys into the table so we can use it in our list :)
If json("success") Then
'Debug.Print "First plant"
If Not firstRound Then
'add the headers
Debug.Print "Running as first plant"
Sheets("Data").Range("A5:BB50000").ClearContents
' Loop through the first item to get the keys (name, endpoint)
h = 1
For Each Item In dataArray(1).Keys
'Debug.Print Item
headerRow.Cells(5, h).Value = Item ' Place the key as a header
h = h + 1
Next Item
firstRound = True
End If
'add the rows in.
' Disable screen updating and calculations for faster execution
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Debug.Print "Column count " & h
' Populate data row by row
'For j = 1 To dataArray.Count
' For x = 1 To h
' 'Debug.Print dataArray(j)(headerRow.Cells(1, i).Value)
' ws.Cells(j + 1, x).Value = dataArray(j)(headerRow.Cells(1, x).Value)
' Next x
'Next j
'Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
lastRow = Application.Max(4, lastRow)
' Populate data row by row, starting from the lastRow + 1
For j = 1 To dataArray.Count
For x = 1 To h
ws.Cells(lastRow + j, x).Value = dataArray(j)(headerRow.Cells(5, x).Value)
Next x
Next j
' Re-enable screen updating and calculations
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
' Determine the last column used based on the number of headers
lastColumn = h
' Automatically adjust the width of all used columns
ws.Columns(1).Resize(, lastColumn).AutoFit ' Adjust based on last column
End If
End If
End If
End If
SkipIteration: ' Label to jump to the next iteration
Next cell
MsgBox "Data processing successful!"
End Sub

1123
JsonConverter.bas Normal file

File diff suppressed because it is too large Load Diff

Binary file not shown.

3
ThisWorkbook.cls Normal file
View File

@@ -0,0 +1,3 @@
Private Sub Workbook_Open()
Call queryAvi
End Sub