Курсы валют и удобный интерфейс (готовое решение)

Option Explicit
'---------------------------------------------------------------------------------------
' Решение       : Курсы валют
' Дата и время  : 15 января 2015  20:49
' Автор         : Night Ranger
'                 Яндекс.Деньги - 410012757639478
'                 [email]Exingsteem@yandex.ru[/email]
'                 [url]https://www.cyberforum.ru/vba/[/url]
' Описание      : Этот пример демонстрирует как легко и просто можно обновить
'                 курсы валют, на любую дату в твоём листе, для этого нужна только пустая форма
'                 а в событии листа нужно только указать ячейки для размещения
'                 полученной информации. Вызываемая форма помнит свои размеры и имеет удобный интерфейс
'---------------------------------------------------------------------------------------
Const maxw& = 110 'Прямоугольник для списка
Const istart& = 5, jstart& = 5 'Стартовые точки
Const gap& = 5 'Разрыв между элементами
Const twip& = 18 'Прямоугольник для объектов
Const SetName = "CurVal" 'Имя для настройки
Const url = "http://www.cbr.ru/scripts/XML_daily.asp?date_req=", lsDel$ = "[]"
Const prom$ = _
"Ошибка загрузки, возможные причины:" & vbCrLf & _
"Нет соединения с интернетом" & vbCrLf & _
"Отсутствует компонент Microsoft XML (msxml.dll)"
Dim WithEvents lsbx As MSForms.ListBox
Dim WithEvents btOk As MSForms.CommandButton
Dim WithEvents btBack As MSForms.CommandButton
Dim WithEvents btDE As MSForms.CommandButton
 
Dim CVTitles$, url_request$, nodeList As Object, strDate$, bConnect As Boolean, IndxDE$
Dim DDoc As Object, a$(), aa$(), StartArr$(), i&, j&, iNext&, jNext&, LsSet$, v, w
Public CurentDate As Date 'Хранение установленной даты
Public ArrayValute As Variant 'Переменная списка полученных валют
Public Event ValuteSelect(ArrayValute As Variant) 'Событие после нажатия Ok
 
Private Function TextCaption$()
    TextCaption = "Курсы валют с запросом  на " & Format(CurentDate, "[$-FC22]d mmmm yyyy")
End Function
 
Private Sub btDE_Click()
    With lsbx
        a = Split(IndxDE, lsDel)
        For i = 0 To .ListCount - 1:
            .Selected(i) = IIf(.List(i) = StartArr(a(0)) Or .List(i) = StartArr(a(1)), 1, 0)
        Next
        lsbx_MouseUp 0, 0, 0, 0
        .ListIndex = 0
    End With
End Sub
 
Public Sub ShowCurVal( _
    Optional ByVal SetDate As Date, _
    Optional ByVal bUpdateTitles As Boolean)
    'ShowCurVal -Процедура вызова с параметрами
    'SetDate -Устанавливает дату запроса
    'bUpdateTitles -Устанавливает возможность обновить список названий валют
    CurentDate = IIf(CDbl(SetDate), SetDate, Date)
    If bUpdateTitles Then Call UpdateTitles
    Me.Caption = TextCaption
    Me.Show
End Sub
 
Private Function TrimDel$(ByVal Value$, Optional ByVal Del = lsDel)
    TrimDel = Mid$(Value, Len(Del) + 1)
End Function
 
Public Sub UpdateTitles()
    'Обновление названий валют
    On Error Resume Next: i = 0
    With DOMDocument: IndxDE = ""
        CVTitles = "": url_request = url & Format(CurentDate, "dd/mm/yyyy")
        bConnect = .Load(url_request)
        If bConnect = False Then MsgBox prom, 48: Unload Me
        For Each v In .selectNodes("*/Valute")
            With v.childNodes: CVTitles = CVTitles & lsDel & .Item(2).Text & " " & .Item(3).Text
                '
                'В этом месте запоминаются индексы в массиве доллара и евро
                '
                If .Item(1).Text = "USD" Or .Item(1).Text = "EUR" Then
                    IndxDE = IndxDE & lsDel & i
                End If: i = i + 1
            End With
        Next
        CVTitles = TrimDel(CVTitles)
        IndxDE = TrimDel(IndxDE)
        SaveSetting "Ms Office", SetName, "IndxDE", IndxDE
        SaveSetting "Ms Office", SetName, "CVTitles", CVTitles
    End With
End Sub
 
Private Sub btOk_Click()
    On Error Resume Next
    With lsbx: LsSet = "": v = ""
        For i = 0 To .ListCount - 1: For j = 0 To UBound(StartArr)
            If .List(i) = StartArr(j) Then LsSet = LsSet & lsDel & j & "-" & Abs(.Selected(i))
        Next j, i
        LsSet = TrimDel(LsSet): SaveSetting "Ms Office", SetName, "List", LsSet
        For i = 0 To .ListCount - 1: If .Selected(i) Then v = v & lsDel & .List(i)
        Next: If v = "" Then Exit Sub
        v = Split(Mid$(v, Len(lsDel) + 1), lsDel)
    End With
    With DOMDocument
        url_request = url & Format(CurentDate, "dd/mm/yyyy")
        bConnect = .Load(url_request)
        If bConnect = False Then MsgBox prom, 48: Exit Sub
        Set nodeList = .selectNodes("ValCurs")
        With nodeList.Item(0).CloneNode(True)
            strDate = "Курсы валют по состоянию на: " & .Attributes(0).Value
        End With
        For Each w In .selectNodes("*/Valute")
            For i = 0 To UBound(v)
                If InStr(1, w.Text, v(i), 1) Then strDate = strDate & lsDel & w.Text: Exit For
            Next
        Next: v = Split(strDate, lsDel)
    End With
    RaiseEvent ValuteSelect(v)
    Me.Hide
End Sub
 
Private Sub btBack_Click()
    a = Split(LsSet, lsDel)
    With lsbx: .Clear
        For i = 0 To UBound(a): aa = Split(a(i), "-")
            .AddItem StartArr(aa(0)): .Selected(i) = aa(1)
        Next
    End With
End Sub
 
Private Sub UserForm_Initialize()
    CurentDate = Date 'По умолчанию вставляется сегодняшняя
    iNext = istart: jNext = jstart
    Set lsbx = Me.Controls.Add("Forms.ListBox.1", "lsbx")
    Set btOk = Me.Controls.Add("Forms.CommandButton.1", "btOk")
    Set btBack = Me.Controls.Add("Forms.CommandButton.1", "btBack")
    Set btDE = Me.Controls.Add("Forms.CommandButton.1", "btDE")
    With lsbx
        .Move jNext, iNext, maxw * 2, maxw
        .ListStyle = fmListStyleOption
        .MultiSelect = fmMultiSelectMulti
        .Clear
        
        LsSet = GetSetting("Ms Office", SetName, "List", vbNullString)
        CVTitles = GetSetting("Ms Office", SetName, "CVTitles", vbNullString)
        IndxDE = GetSetting("Ms Office", SetName, "IndxDE", vbNullString)
        If Len(CVTitles) = 0 Or Len(IndxDE) = 0 Then UpdateTitles
        StartArr = Split(CVTitles, lsDel)
        If Len(LsSet) Then
            btBack_Click
        Else
            For Each v In StartArr: .AddItem v: Next
            btDE_Click
        End If
        iNext = iNext + .Height + gap
    End With
    
    With btOk
        .Move jNext, iNext
        .AutoSize = 1: .Caption = "Ok"
        .ControlTipText = "Запрос, сохранение и выход"
        jNext = jNext + .Width + gap
    End With
    With btBack
        .Move jNext, iNext
        .AutoSize = 1: .Caption = "Откатить"
        .ControlTipText = "К прежним настройкам"
        jNext = jNext + .Width + gap
    End With
    With btDE
        .Move jNext, iNext
        .AutoSize = 1: .Caption = "Только доллар и евро"
        jNext = jNext + .Width + gap
    End With
    iNext = iNext + btOk.Height + gap
    With Me: .Caption = TextCaption
        .Height = iNext + twip * 2
        If Application.Left > -100 Then
            .StartUpPosition = 0
            .Left = GetSetting("Ms Office", SetName, "Left", .Left)
            .Top = GetSetting("Ms Office", SetName, "Top", .Top)
            If .Left <= 0 Or .Left > (Application.Left + Application.Width - 100) Or _
            .Top <= 0 Or .Top > (Application.Top + Application.Height - 100) Then
                'Если сохраненная ранее позиция вышла за предел экрана
                .StartUpPosition = 2
            End If
        End If
    End With
End Sub
 
 
Private Sub lsbx_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    'Выделенные пункты перебрасываются вперёд
    With lsbx
        ReDim a(.ListCount * 2 - 1)
        For i = 0 To .ListCount - 1
            If .Selected(i) Then
                a(i) = .List(i)
            Else: a(.ListCount + i) = .List(i)
            End If
        Next: i = -1
        For j = 0 To UBound(a)
            If Len(a(j)) Then
                i = i + 1: .List(i) = a(j): .Selected(i) = j < .ListCount
            End If
        Next
    End With
End Sub
 
Private Property Get DOMDocument() As Object
    If DDoc Is Nothing Then Set DDoc = CreateObject("Msxml.DOMDocument"): DDoc.async = False
    Set DOMDocument = DDoc
End Property
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    With Me 'Перед закрытием запомнить позицию
        SaveSetting "Ms Office", SetName, "Left", .Left
        SaveSetting "Ms Office", SetName, "Top", .Top
    End With
End Sub

Option Explicit
Dim WithEvents mCurVal As CurVal
Dim WithEvents mCalendar As Calendar
 
Private Sub CommandButton1_Click()
    Set mCurVal = CurVal
    CurVal.ShowCurVal Me.[a1]
End Sub
 
Private Sub CommandButton2_Click()
    Set mCalendar = Calendar
    Calendar.ShowCalendar Me.[a1]
End Sub
 
Private Sub mCalendar_DateSelect(ThisDate As Date)
    Me.[a1] = ThisDate
End Sub
 
Private Sub mCurVal_ValuteSelect(ArrayValute As Variant)
    Dim i&, j&
    j = 4
    With Me
        .Columns(j).ClearContents
        For i = 0 To UBound(ArrayValute)
            .Cells(i + 2, j) = ArrayValute(i)
        Next
    End With
End Sub