'Функция для получения курса валюты по коду на определенную дату
'c интернет-ресурса http://www.cbr.ru/scripts/XML_daily.asp?date_req=
'использует MS Msxml.dll
Public Function GetCourse(CURRENCYID As Long, onDate As Date) As Double
  On Error GoTo ErrGetCourse
    Dim xmlDoc As MSXML2.DOMDocument
    Dim xmlNode As MSXML2.IXMLDOMNode
    'если не стоит в ссылках MicroSoft XML, ver.5 то используйте тип Object
    'Dim xmlDoc As Object
    'Dim xmlNode As Object
    
    Dim i As Integer, j As Integer
    Dim strSQL As String, strVal As String, strCourse As String
    
    DoCmd.Hourglass True
    If onDate > Date +  1  Then
        DoCmd.Hourglass False
        'MsgBox "Слишком рано, вы не получите достоверного курса валюты!!!", , "Опрерация преостановленна."
        GetCourse = - 3  'Слишком рано, вы не получите достоверного курса валюты
        Exit Function
    End If
    'Выбор валюты
    If CURRENCYID = GetUSDID Then     'Доллар
        strVal = "USD"
    ElseIf CURRENCYID = GetEURID Then 'Евро
        strVal = "EUR"
    ElseIf CURRENCYID = GetUEID Then  'У.Е.
        GetCourse =  35 
        Exit Function
    ElseIf CURRENCYID = GetRUSID Then 'Рубль
        GetCourse =  1 
        Exit Function
    Else
        GetCourse = - 2                 'неверный код валюты
        Exit Function
    End If
    Set xmlDoc = CreateObject("MSXML2.DOMDocument")
    xmlDoc.async = False ' флаг асинхронной загрузки документа
    ' загружаем документ по url
    If Not xmlDoc.Load("http://www.cbr.ru/scripts/XML_daily.asp?date_req=" & Format(onDate, "dd.mm.yyyy")) Then
        GetCourse = - 4 
        DoCmd.Hourglass False
        MsgBox ("Документ не загружается. Проверьте подключение к Интернету или ссылка не работает.")
        GoTo Exit_GetCourse
    End If
        'dateXML = xmlDoc.selectNodes("ValCurs").Item(0).cloneNode(True).Attributes(0).Text
        'Debug.Print dateXML
    Set xmlNode = xmlDoc.selectNodes("ValCurs").Item( 0 ).cloneNode(True)
    For i =  0  To xmlNode.childNodes.Length -  1 
        'Выбираем в дереве XML документа ветку с нужной валютой
        If xmlNode.childNodes.Item(i).childNodes.Item( 1 ).Text = strVal Then
            strCourse = xmlNode.childNodes.Item(i).childNodes.Item( 4 ).Text
            'Debug.Print strCourse
            For j =  1  To Len(strCourse) 'заменяем "," на "."
                If mid(strCourse, j,  1 ) = "," Then
                    Mid(strCourse, j,  1 ) = "."
                End If
            Next j
            Exit For
        End If
    Next i
    GetCourse = CDbl(strCourse)
Exit_GetCourse:
    Set xmlDoc = Nothing
    Set xmlNode = Nothing
    DoCmd.Hourglass False
    Exit Function
ErrGetCourse:
    DoCmd.Hourglass False
    GetCourse = - 1 
    Resume Exit_GetCourse
End Function