אופיס 365 קבלת שער הדולר באקסס באמצעות פונקציה

[יאיר משה]

תודה רבה!
אבל בגירסה הזאת הוא מציג את שער הדולר כך - 3486 במקום 3.486.
מה עושים?

 

[moishy]

תוקן במקור.

 

[יאיר משה]

שוב הפונקציה לא עובדת, אולי בנק ישראל שינה משהו?
מוישי אודה לך אם תבדוק.

 

[כוכב מאיר]

אצלי יש תוכנה שיושבת על אקסס (APTׂׂ) ולאחרונה ברוב המקרים הוא לא נותן את שער הדולר באופן אוטומטי, כנראה יש בעיות באתר של בנק ישראל

 

[moishy]

הליצנים בבנק ישרא שוב שינו את פורמט התאריך הנדרש.

להלן הקוד התקין לגחמה הנוכחית:

Option Explicit

Public Declare Function InternetGetConnectedState Lib "wininet.dll" (lpdwFlags As Long, ByVal dwReserved As Long) As Boolean

Public Function GetNISExchangeRate(Optional dtDate As Date = #1/1/1900#, Optional strCurr As String = "01") As Double

    Dim strURL As String
    Dim strResult As String
    Dim pos As Long
    Dim strSearch As String
    Dim dtPreviousDate As Date
    Dim i As Integer

    strSearch = Chr(60) & "RATE" & Chr(62)

    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 = "http://www.boi.org.il/currency.xml?rdate=" & Format(IIf(dtPreviousDate > 1, dtPreviousDate, dtDate), "YYYYMMDD") & "&curr=" & strCurr
        strResult = GetHTML(strURL)
        If InStr(1, strResult, strSearch) < 1 Then
            For i = 1 To 6
                dtPreviousDate = dtDate - i
                strURL = "http://www.boi.org.il/currency.xml?rdate=" & Format(dtPreviousDate, "YYYYMMDD") & "&curr=" & strCurr
                strResult = GetHTML(strURL)
                If InStr(1, strResult, strSearch) > 0 Then Exit For
            Next i
        End If
    Else
        MsgBox "לא זוהה חיבור לאינטרמת!", vbCritical + vbMsgBoxRtlReading + vbMsgBoxRight
    End If

    If Len(strResult) > 0 Then
        pos = InStr(1, strResult, strSearch, vbTextCompare)
        If pos > -1 Then
            GetNISExchangeRate = ExtractNumber(Mid(strResult, pos + Len(strSearch), 5))    ' / 1000
        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.XMLHTTP")
        .Open "GET", strURL, False
        .Send
        GetHTML = .ResponseText
    End With
End Function

Function ExtractNumber(strText As String)
    Dim iCount As Integer, i As Integer
    Dim lNum As String

    For iCount = Len(strText) To 1 Step -1
        If IsNumeric(Mid(strText, iCount, 1)) Then
            i = i + 1
            lNum = Mid(strText, iCount, 1) & lNum
        Else
            If Mid(strText, iCount, 1) = Chr(46) Then
                i = i + 1
                lNum = Mid(strText, iCount, 1) & lNum
            End If
        End If
        If i = 1 Then lNum = CDbl(Mid(lNum, 1, 1))
    Next iCount

    ExtractNumber = CDbl(lNum)
End Function

 

[יאיר משה]

תודה מוישי, אבל זה עף אם אותה שגיאה.

 

[moishy]

מה השגיאה? (אצלי הוא עובד, בדוק.)

להבא עשה טובה אנחנו מנסים לסייע, כיצד נוכל לסייע אם לא נדע מה הבעיה היכן ומתי היא מתרחשת. חוס נא על זמן המתנדבים להשיב, וספק פרטים בסיסיים אלו מיד בעת הדיווח על התקלה.

 

[יאיר משה]

סליחה שלא הוספתי קבצים מצורפים.

מצורפות השגיאות
תודה

 

[moishy]

הליצנים בבנק ישראל החליטו להצדיק את התואר ליצנים, הם שוב שינו את הפורמט, הפעם החזירו אותו לצורתו המקורית.

הקוד המקורי עובד עכשיו.

בהצלחה.

 

[יאיר משה]

מוישי סליחה שאני מטריד אותך, אבל גם בקוד הישן הוא עף לי אם אותה שגיאה, אולי הבעיה היא אצלי?
תודה

 

[HUBHCBH]

שגיאה 13 זה לא קשור לערך הנתונים (מספר)?

 

[moishy]

העלה בבקשה את הקוד שאתה משתמש בו.

 

[יאיר משה]

הקוד מצורף, תודה רבה

Option Explicit

Public Declare Function InternetGetConnectedState Lib "wininet.dll" (lpdwFlags As Long, ByVal dwReserved As Long) As Boolean

Public Function GetNISExchangeRate(Optional dtDate As Date = #1/1/1900#, Optional strCurr As String = "01") As Double

    Dim strURL As String
    Dim strResult As String
    Dim pos As Long
    Dim strSearch As String
    Dim dtPreviousDate As Date
    Dim i As Integer

    strSearch = Chr(60) & "RATE" & Chr(62)

    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 = "http://www.boi.org.il/currency.xml?rdate=" & Format(IIf(dtPreviousDate > 1, dtPreviousDate, dtDate), "YYYYMMDD") & "&curr=" & strCurr
        strResult = GetHTML(strURL)
        If InStr(1, strResult, strSearch) < 1 Then
            For i = 1 To 6
                dtPreviousDate = dtDate - i
                strURL = "http://www.boi.org.il/currency.xml?rdate=" & Format(dtPreviousDate, "YYYYMMDD") & "&curr=" & strCurr
                strResult = GetHTML(strURL)
                If InStr(1, strResult, strSearch) > 0 Then Exit For
            Next i
        End If
    Else
        MsgBox "לא זוהה חיבור לאינטרנט!", vbCritical + vbMsgBoxRtlReading + vbMsgBoxRight
    End If

    If Len(strResult) > 0 Then
        pos = InStr(1, strResult, strSearch, vbTextCompare)
        If pos > -1 Then
            GetNISExchangeRate = ExtractNumber(Mid(strResult, pos + Len(strSearch), 5))    ' / 1000
        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.XMLHTTP")
        .Open "GET", strURL, False
        .Send
        GetHTML = .ResponseText
    End With
End Function

Function ExtractNumber(strText As String)
    Dim iCount As Integer, i As Integer
    Dim lNum As String

    For iCount = Len(strText) To 1 Step -1
        If IsNumeric(Mid(strText, iCount, 1)) Then
            i = i + 1
            lNum = Mid(strText, iCount, 1) & lNum
        Else
            If Mid(strText, iCount, 1) = Chr(46) Then
                i = i + 1
                lNum = Mid(strText, iCount, 1) & lNum
            End If
        End If
        If i = 1 Then lNum = CDbl(Mid(lNum, 1, 1))
    Next iCount

    ExtractNumber = CDbl(lNum)
End Function

 

[moishy]

אצלי זה עובד.

 

[moishy]

מבדיקות שערכתי על מחשבים נוספים מתברר ש...

הקוד מתחיל לעבוד כראוי לאחר פתיחת הקישור באופן ידני בדפדפן. נכון לרגע זה אין לי הסבר לתופעה.

 

[שמח לעזור]

מבדיקות שערכתי על מחשבים נוספים מתברר ש...

הקוד מתחיל לעבוד כראוי לאחר פתיחת הקישור באופן ידני בדפדפן. נכון לרגע זה אין לי הסבר לתופעה.

אם זה ככה זה כנראה קשור לקוקיס או משהו כזה.

אבל אני לא מבין מוישי למה אתה לא עובד עם כלים מובנים לXML, משהו כזה:

Function GetRate(AtDate As String, curr As String) As Double
    Dim doc As New MSXML2.DOMDocument60
    doc.async = False
  
    doc.Load ("http://www.boi.org.il/currency.xml?rdate=" & AtDate & "&curr=" & curr)
    GetRate = doc.SelectSingleNode(".//RATE").Text
End Function

 

[moishy]

בהתאם להצעתו (הצודקת!) של ר' שמח, הנני להציע את הקוד הבא:

Option Explicit

Public Declare Function InternetGetConnectedState Lib "wininet.dll" (lpdwFlags As Long, ByVal dwReserved As Long) As Boolean

Function GetNISExchangeRate(Optional dtDate As Date = #1/1/1900#, Optional strCurr As String = "01") As Double

    Dim objXMLDoc As Object
    Dim objNode As Object
    Dim strUrl As String
    Dim dtPreviousDate As Date
    Dim i As Long

    Set objXMLDoc = CreateObject("MSXML2.DOMDocument.6.0")

    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 = "http://www.boi.org.il/currency.xml?rdate=" & Format(IIf(dtPreviousDate > 1, dtPreviousDate, dtDate), "YYYYMMDD") & "&curr=" & strCurr
        objXMLDoc.async = False
        objXMLDoc.Load strUrl

    Set objNode = objXMLDoc.SelectSingleNode("//RATE")

        Do Until Not objNode Is Nothing
            dtPreviousDate = dtDate - i
            strUrl = "http://www.boi.org.il/currency.xml?rdate=" & Format(dtPreviousDate, "YYYYMMDD") & "&curr=" & strCurr
            objXMLDoc.Load strUrl
            Set objNode = objXMLDoc.SelectSingleNode("//RATE")
            i = i + 1
        Loop
    Else
        MsgBox "לא זוהה חיבור לאינטרנט!", vbCritical + vbMsgBoxRtlReading + vbMsgBoxRight
    End If

    GetNISExchangeRate = objXMLDoc.SelectSingleNode("//RATE").Text

End Function

Function IsConnected() As Boolean
    Dim Stat As Long
    IsConnected = (InternetGetConnectedState(Stat, 0&) <> 0)
End Function

 

[יאיר משה]

תודה רבה למוישי ולשמח לעזור.
לצערי הפקודה תוקעת את האקסס.

 

[moishy]

כל ערום יעשה בדעת...

תנסה את זה.

Option Explicit

Public Declare Function InternetGetConnectedState Lib "wininet.dll" (lpdwFlags As Long, ByVal dwReserved As Long) As Boolean

Function GetNISExchangeRate(Optional dtDate As Date = #1/1/1900#, Optional strCurr As String = "01") As Double

    Dim objXMLDoc As Object
    Dim objNode As Object
    Dim strUrl As String
    Dim dtPreviousDate As Date
    Dim i As Long

    Set objXMLDoc = CreateObject("MSXML2.DOMDocument.6.0")

    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 = "http://www.boi.org.il/currency.xml?rdate=" & Format(IIf(dtPreviousDate > 1, dtPreviousDate, dtDate), "YYYYMMDD") & "&curr=" & strCurr
        
        With CreateObject("InternetExplorer.Application")
            .Visible = False
            .Navigate strUrl
            Do Until .Busy = False And .ReadyState = 4
                DoEvents
            Loop
            .Quit
        End With

        objXMLDoc.async = False
        objXMLDoc.Load strUrl

    Set objNode = objXMLDoc.SelectSingleNode("//RATE")

        Do Until Not objNode Is Nothing
            dtPreviousDate = dtDate - i
            strUrl = "http://www.boi.org.il/currency.xml?rdate=" & Format(dtPreviousDate, "YYYYMMDD") & "&curr=" & strCurr
            objXMLDoc.Load strUrl
            Set objNode = objXMLDoc.SelectSingleNode("//RATE")
            i = i + 1
        Loop
    Else
        MsgBox "ìà æåää çéáåø ìàéðèøðè!", vbCritical + vbMsgBoxRtlReading + vbMsgBoxRight
    End If

    GetNISExchangeRate = objXMLDoc.SelectSingleNode("//RATE").Text

End Function

Function IsConnected() As Boolean
    Dim Stat As Long
    IsConnected = (InternetGetConnectedState(Stat, 0&) <> 0)
End Function

 

[יאיר משה]

עובד!!!
תודה רבה מאוד.