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

[FullTime]

יש כאן קוד.

דבר ראשון, תודה רבה מוישי.
אני משתמש עם הפונקציה הזאת GetBankOfIsraelExchangeRate ?


הוא מחזיר שגיאה 13 של אי התאמת סוג והפונקציה הנ"ל מקבלת ערך 0
איך אני אמור להשתמש איתו, אולי הבעיה בי....

 

[moishy]

תוקן במקור.

 

[FullTime]

תודה רבה רבה, עובד מצויין

 

[יאיר משה]

איך משתמשים בפונקציה זאת?
תודה

 

[FullTime]

דוגמה:
לחצן 'קבל שער הדולר'
תיבת טקסט 'טקסט0'

הגדרת הלחצן 'בעת לחיצה'

טקסט0 = GetBankOfIsraelExchangeRate()

 

[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 = Mid(strResult, pos + Len(strSearch), 5)
        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

 

[FullTime]

מה השדרוג שלו, לפי מה שנראה לי, לפני נסיון, אפשר לבחור מטבע?

 

[moishy]

גם בגירסא הקודמת אפשר לבחור תאריך ומטבע.

להלן השינויים:

1. בדיקה שקוד המטבע תקין, אם לא - יציאה מהפוקציה.
2. dtPreviousDate > 1 במקום Not IsNothing(dtPreviousDate).
3. הוספת vbMsgBoxRtlReading + vbMsgBoxRight לMsgBox

 

[HUBHCBH]

למה לא מסתדר לי?

 

[moishy]

תוקן.

 

[HUBHCBH]

איך אני קורא לפונקציה של דולר?

 

[moishy]

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

 

[יאיר משה]

תודה רבה

עובד נהדר, כל הכבוד!!

 

[יאיר משה]

בכל מחשב שאני פותח את הפונקציה הזאת יש הודעת שגיאה.
אולי מישהו יודע למה?
תודה

 

[moishy]

מה הודעת השגיאה?

 

[יאיר משה]

צרפתי
תודה.

 

[moishy]

תשנה את הספרה 5 בסוף השורה ל 4.

 

[יאיר משה]

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

 

[moishy]

כנראה שלא היתה זו בעיה בבנק ישראל אלא בפונקציה, הפונקציה בנויה למשוך את השער שהוא בדר"כ 5 תווים (שלם, נקודה עשרונית ושלש מקומות לאחר הנקודה), במקרה והשער מכיל פחות ממספר תוים זה, נתקל בבעיה שמצאת.
לפתור את זה, מומלץ למחוק את ה As Double מסוף השורה הראשונה של הפונקציה, כך יתכן שערך המוחזר לא יהיה רק מספר, אבל לא נתקל בשגיאה.

 

[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