Într-un articol precedent v-am explicat cum puteţi prelua cursul valutar de pe site-ul BNR folosind un script, html, etc.
Acum, revin cu o actualizare şi anume, am eliminat acel script care salva pagina în format HTML, dar şi codul care prelucra pagina.
Noul cod iniţiază o nouă sesiune de browser şi interpretează codul HTML al paginii, iar la urmă afişează datele de interes într-un formular.
Un alt exemplu îl aveţi aici: [Aplicaţie] – Validare cod CIF în Microsoft Access
Codul folosit este:
'---------------------------------------------------------------------------------------
' Modul : Form_frmCheckCurs
' Autor : Alexandru Dionisie
' Data : 04.12.2011
' WebSite : www.tutorialeoffice.ro
' Sursa Cod : -
' Scop : Codul de mai jos afiseaza cursul valutar in campurile unui formular.
' Observatii: Pentru a rula pe SO: Windows 7 si browser-ul IE9, este nevoie sa:
' 1. mergeti in Tools - References si sa puneti o bifa
' librariei Microsoft Internet Controls.
' 2. In IE 9, mergeti in Tools - Compatibility View Settings
' si sa bifati optiunea Display All Websites in Compatibility View.
'---------------------------------------------------------------------------------------
Option Compare Database
'declaratii pentru testarea conexiunii la internet
Private Declare Function InternetGetConnectedStateEx Lib "wininet.dll" _
(ByRef lpdwFlags As Long, ByVal lpszConnectionName As String, _
ByVal dwNameLen As Integer, ByVal dwReserved As Long) As Long
Dim sConnType As String * 255
Private Sub cmdCheck_Click()
On Error GoTo err
Dim Ret As Long
Dim ie As Object
Dim strSource As String, strEuro As String, strDolar As String
'ascundem avertizarea pentru net
lblNet.Visible = False
'golim textbox-urile
txtEuro.SetFocus
txtEuro.Text = ""
txtDolar.SetFocus
txtDolar.Text = ""
txtConvD.SetFocus
txtConvD.Text = ""
txtConvE.SetFocus
txtConvE.Text = ""
'se verifica starea conexiunii
'este legat de If Ret = 1 Then
Ret = InternetGetConnectedStateEx(Ret, sConnType, 254, 0)
'cream o noua instanta de IE
Set ie = CreateObject("internetexplorer.application")
'ascundem fereastra browser-ului
ie.Visible = False
'deschidem link-ul creat
ie.Navigate "http://bnr.ro/Home.aspx"
'asteptam sa se incarca complet pagina
TryAgain:
While ie.Busy
DoEvents
Wend
'extragem outerHTML - contine XML-ul paginii
On Error GoTo TryAgain
strSource = ie.Document.body.outerHTML
'daca avem conexiune la internet, rezultatul este 1 adica TRUE si se trece la rularea codului
If Ret = 1 Then
'daca pagina nu este valida, afisam mesaj de eroare
If ie.Document.title = "HTTP 404 Not Found" Then
'lblStatus.Visible = True
'golim textbox-urile
txtEuro.SetFocus
txtEuro.Text = ""
txtDolar.SetFocus
txtDolar.Text = ""
txtConvD.SetFocus
txtConvD.Text = ""
txtConvE.SetFocus
txtConvE.Text = ""
Else
On Error GoTo 0
'eliminam tag-urile html - Euro
strSource = Mid(strSource, InStr(1, strSource, _
"1 EUR") + 22)
'preluam doar valoarea de interes - Euro
strEuro = Left(strSource, 6)
'eliminam tag-urile html - Dolar
strSource = Mid(strSource, InStr(1, strSource, _
"1 USD") + 22)
'preluam doar valoarea de interes - Dolar
strDolar = Left(strSource, 6)
'afisam toate datele in TextBox-uri
txtEuro.SetFocus
txtEuro.Text = strEuro & " lei"
txtDolar.SetFocus
txtDolar.Text = strDolar & " lei"
'eliminam procesul din memorie
ie.Quit
'realizam conversia EURO - RON si USD - RON
txtConvE = txtSumaE * txtEuro
txtConvD = txtSumaD * txtDolar
End If
Else
'daca nu avem conexiune la internet, rezultatul este 0 adica FALSE
'se afiseaza un label cu un text informativ
lblNet.Visible = True
End If
Exit Sub
err:
MsgBox err.Description, vbOKOnly + vbInformation, "Eroare"
End Sub
Download | Preluare_Curs.accdb
Download | Preluare_Curs.mdb
UPDATE:
Dat fiind faptul că în weekend cursul valutar nu se actualizează, am decis să mai adaug câteva linii de cod care să:
– afişeze data cursului;
– dacă data la care a fost adăugat cursul nu este identică cu data curentă, să afişeze o notificare, dar totuşi să preia cursul.
Întreg codul este comentat, deci nu va fi nicio problemă în a-l interpreta.
Pentru fişierele de lucru, folosiţi link-urile de download de mai sus.
Noul cod este:
'---------------------------------------------------------------------------------------
' Modul : Form_frmCheckCurs
' Autor : Alexandru Dionisie
' Data : 04.12.2011
' WebSite : www.tutorialeoffice.ro
' Sursa Cod : -
' Scop : Codul de mai jos afiseaza cursul valutar in campurile unui formular.
' Observatii: Pentru a rula pe SO: Windows 7 si browser-ul IE9, este nevoie sa:
' 1. mergeti in Tools - References si sa puneti o bifa
' librariei Microsoft Internet Controls.
' 2. In IE 9, mergeti in Tools - Compatibility View Settings
' si sa bifati optiunea Display All Websites in Compatibility View.
'---------------------------------------------------------------------------------------
Option Compare Database
'declaratii pentru testarea conexiunii la internet
Private Declare Function InternetGetConnectedStateEx Lib "wininet.dll" _
(ByRef lpdwFlags As Long, ByVal lpszConnectionName As String, _
ByVal dwNameLen As Integer, ByVal dwReserved As Long) As Long
Dim sConnType As String * 255
Private Sub cmdCheck_Click()
On Error GoTo err
Dim Ret As Long
Dim ie As Object
Dim strSource As String, strEuro As String, strDolar As String, strCN As String
'ascundem avertizarea pentru net
lblNet.Visible = False
'ascundem avertizarea pentru curs expirat
lblData.Visible = False
'ascundem label-ul pentru data
txtDataCurs.Visible = False
'golim textbox-urile
txtEuro.SetFocus
txtEuro.Text = ""
txtDolar.SetFocus
txtDolar.Text = ""
txtConvD.SetFocus
txtConvD.Text = ""
txtConvE.SetFocus
txtConvE.Text = ""
'se verifica starea conexiunii
'este legat de If Ret = 1 Then
Ret = InternetGetConnectedStateEx(Ret, sConnType, 254, 0)
'cream o noua instanta de IE
Set ie = CreateObject("internetexplorer.application")
'ascundem fereastra browser-ului
ie.Visible = False
'deschidem link-ul creat
ie.Navigate "http://bnr.ro/Home.aspx"
'asteptam sa se incarca complet pagina
TryAgain:
While ie.Busy
DoEvents
Wend
'extragem outerHTML - contine XML-ul paginii
On Error GoTo TryAgain
strSource = ie.Document.body.outerHTML
'daca avem conexiune la internet, rezultatul este 1 adica TRUE si se trece la rularea codului
If Ret = 1 Then
'daca pagina este invalida, afisam mesaj de eroare
If ie.Document.title = "HTTP 404 Not Found" Then
'lblStatus.Visible = True
'golim textbox-urile
txtEuro.SetFocus
txtEuro.Text = ""
txtDolar.SetFocus
txtDolar.Text = ""
txtConvD.SetFocus
txtConvD.Text = ""
txtConvE.SetFocus
txtConvE.Text = ""
Else
On Error GoTo 0
'eliminam tag-urile html - pentru data cursului
strSource = Mid(strSource, InStr(1, strSource, _
"rates") + 62)
'verificam data noului curs
strCN = Left(strSource, 10)
'daca data de pe site este = cu data curenta, ruleaza codul
If strCN = Date Then
'afisam label-ul pentru data
txtDataCurs.Visible = True
'deblocam textbox-ul
txtDataCurs.Locked = False
'stabilim focusul pe textbox-ul cu data
txtDataCurs.SetFocus
'afisam data curenta
txtDataCurs.Text = "Cursul este din data de: " & strCN
'blocam textbox-ul
txtDataCurs.Locked = True
'rulam procedura de preluare a cursului
Demo:
'eliminam tag-urile html - Euro
strSource = Mid(strSource, InStr(1, strSource, _
"1 EUR") + 22)
'preluam doar valoarea de interes - Euro
strEuro = Left(strSource, 6)
'eliminam tag-urile html - Dolar
strSource = Mid(strSource, InStr(1, strSource, _
"1 USD") + 22)
'preluam doar valoarea de interes - Dolar
strDolar = Left(strSource, 6)
'afisam toate datele in TextBox-uri
txtEuro.SetFocus
txtEuro.Text = strEuro & " lei"
txtDolar.SetFocus
txtDolar.Text = strDolar & " lei"
'eliminam procesul din memorie
ie.Quit
'realizam conversia EURO - RON si USD - RON
txtConvE = txtSumaE * txtEuro
txtConvD = txtSumaD * txtDolar
Else
'daca data curenta =/= de data de pe site, afiseaza mesaj in label
'si ruleaza codul oricum
lblData.Visible = True
'afisam label-ul pentru data
txtDataCurs.Visible = True
'deblocam textbox-ul
txtDataCurs.Locked = False
'stabilim focusul pe textbox-ul cu data
txtDataCurs.SetFocus
'afisam data curenta
txtDataCurs.Text = "Cursul este din data de: " & strCN
'blocam textbox-ul
txtDataCurs.Locked = True
'rulam codul de preluare a cursului, daca se indeplineste conditia Today=Date
GoTo Demo
End If
End If
Else
'daca nu avem conexiune la internet, rezultatul este 0 adica FALSE
'se afiseaza un label cu un text informativ
lblNet.Visible = True
End If
Exit Sub
err:
MsgBox err.Description, vbOKOnly + vbInformation, "Eroare"
End Sub