Option Explicit
#If Win64 Or VBA7 Then
Public Declare PtrSafe Function InternetGetConnectedState Lib "wininet.dll" (lpdwFlags As Long, ByVal dwReserved As Long) As Boolean
#Else
Public Declare Function InternetGetConnectedState Lib "wininet.dll" (lpdwFlags As Long, ByVal dwReserved As Long) As Boolean
#End If
Public Function GetNISExchangeRate2(Optional dtDate As Date = #1/1/1900#, Optional strCurr As String = "01") As Double
Dim strURL As String
Dim strResult As String
Dim lngStartPosition As Long
Dim lngEndPosition As Long
Dim strFirstSearch As String
Dim strLastSearch As String
Dim dtPreviousDate As Date
Dim i As Integer
strFirstSearch = "<RATE>"
strLastSearch = "</RATE>"
If dtDate = #1/1/1900# Then
dtDate = Date
End If
Select Case strCurr
Case "01", "02", "03", "05", "06", "12", "17", "18", "27", "28", "31", "69", "70", "79"
Case Else
MsgBox "÷åã îèáò ìà çå÷é!", vbCritical + vbMsgBoxRtlReading + vbMsgBoxRight
Exit Function
End Select
If IsConnected Then
strURL = "https://www.boi.org.il/currency.xml?rdate=" & Format(IIf(dtPreviousDate > 1, dtPreviousDate, dtDate), "YYYYMMDD") & "&curr=" & strCurr
strResult = GetHTML(strURL)
If InStr(1, strResult, strFirstSearch) < 1 Then
For i = 1 To 6
dtPreviousDate = dtDate - i
strURL = "https://www.boi.org.il/currency.xml?rdate=" & Format(dtPreviousDate, "YYYYMMDD") & "&curr=" & strCurr
strResult = GetHTML(strURL)
If InStr(1, strResult, strFirstSearch) > 0 Then Exit For
Next i
End If
Else
MsgBox "ìà æåää çéáåø ìàéðèøðè!", vbCritical + vbMsgBoxRtlReading + vbMsgBoxRight
End If
If Len(strResult) > 0 Then
lngStartPosition = InStr(1, strResult, strFirstSearch, vbTextCompare)
lngEndPosition = CLng(InStr(1, strResult, strLastSearch, vbTextCompare))
If lngStartPosition > -1 Then
GetNISExchangeRate2 = mid(strResult, lngStartPosition + Len(strFirstSearch), lngEndPosition - CLng(lngStartPosition + Len(strFirstSearch)))
End If
End If
End Function
Function IsConnected() As Boolean
Dim Stat As Long
IsConnected = (InternetGetConnectedState(Stat, 0&) <> 0)
End Function
Function GetHTML(strURL As String) As String
Dim HTML As String
With CreateObject("MSXML2.ServerXMLHTTP.6.0")
.Open "GET", strURL, False
.Send
GetHTML = .ResponseText
End With
End Function
הנושאים החמים
הנושאים החמים
