Pasek boczny
Konto
Konto
Szukaj
Szukaj
Ustawienia
Ustawienia
Szukaj

Szukaj w:



Zaawansowane wyszukiwanie
Ustawienia
Przełącz na wersję mobilną
Motyw
Język



Notariusz Katowice





Excel/VBA - kurs waluty pobierany z sieci
  • 0 głosów - średnia: 0
  • 1
  • 2
  • 3
  • 4
  • 5
Subskrybuj ten wątek
fantazyjny
Użytkownik
Offline

Reputacja: 18

 0     0    
1   04-11-2014, 17:40   
Edytuj ten post      Cytuj     
Witam!

Mam mały kłopot. Posiadam kod PHP na pobieranie kursu waluty z NBP oraz kod na pobieranie danych ze strony internetowej.
Mam problem z VBA, bo wynikiem funkcji jest "0" lub "4". Nie wiem co jest nie tak......


PHP na stronce:
Kod PHP:
<?php

class Waluta{
    
    function 
ZwrocKurs($name$date) {
    
            
$name $_GET['w'];
            
$date $_GET['d'];
            
            
//formatowanie daty na potrzeby wyszukania ciągu w pliku txt oraz odpowiedniego pliku na stronie NBP 
            
$fdate substr($date22) . substr($date52) . substr($date,,2);
            
//jeśli jest plik cache.txt i jest w nim zapisany kurs o wymaganym kodzie i dacie wyświetlamy go
            
if(file_exists("cache.txt") && preg_match("/$fdate\:\s+$name\:\s+\d,\d\d\d\d/"file_get_contents("cache.txt"), $matches)){
                
                echo 
substr($matches[0], 13,6);
    
            
//jeśli plik nie istnieje, bądź nie znaleziono wymaganego kursu pobieramy odpowiedni plik ze strony NBP
            
}else{
            
$link "";
            
//pobranie pliku z kodami do plików XML
            
$file file_get_contents("http://www.nbp.pl/Kursy/xml/dir.txt") or die("System nie mógł pobrać pliku");
            
//wyszukanie wymaganego kodu
            
$test preg_match("/a\d\d\d.$fdate/"$file$machtable);
            
            if(!
$test){
                die(
"Brak pliku o podanej z wybraną datą. Najprawdopodobniej wybrałeś dzień w którym nie publikowano kursów walut");
            }else{
                
$link .= $machtable[0];
            }
            
//parsowanie wymaganego pliku XML
            
$courses simplexml_load_file("http://www.nbp.pl/Kursy/xml/$link.xml");
            
            foreach (
$courses->pozycja as $key) {
                if (
$key->kod_waluty == $name){
                    
$course $key->kurs_sredni;
                    echo 
$course;
                    
//tworzenie bądź dopisanie do istniejącego pliku ciąg z datą, kodem oraz kursem waluty
                    
$fp fopen("cache.txt""a+");
                    
$fout fwrite($fp"$fdate":" $key->kod_waluty":" $key->kurs_sredni\r");
                    
fclose($fp);
                }
            }
        }
        
    }
    
}

$kurs = new Waluta;
$kurs->ZwrocKurs($name$date);


?>

Kod VBA w excelu:
Kod:
Option Explicit
Private Declare Function InternetOpen Lib "wininet" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet" (ByVal hInet As Long) As Integer
Private Declare Function InternetReadFile Lib "wininet" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, ByVal sUsername As String, ByVal sPassword As String, ByVal lService As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function HttpQueryInfo Lib "wininet.dll" Alias "HttpQueryInfoA" (ByVal hHttpRequest As Long, ByVal lInfoLevel As Long, ByRef sBuffer As Any, ByRef lBufferLength As Long, ByRef lIndex As Long) As Integer
Private Declare Function HttpOpenRequest Lib "wininet.dll" Alias "HttpOpenRequestA" (ByVal hHttpSession As Long, ByVal sVerb As String, ByVal sObjectName As String, ByVal sVersion As String, ByVal sReferer As String, ByVal something As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function HttpSendRequest Lib "wininet.dll" Alias "HttpSendRequestA" (ByVal hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength As Long, sOptional As Any, ByVal lOptionalLength As Long) As Integer

Function InternetGetText(sServerName As String, sFileName As String, Optional sUsername As String = vbNullString, Optional sPassword As String = vbNullString, Optional lBufferSize As Long = -1) As String
    Dim hInternetSession As Long, hInternetConnect As Long, hHttpOpenRequest As Long
    Dim lRetVal As Long, lLenFile As Long, lNumberOfBytesRead As Long, lResLen As Long
    Dim sBuffer As String, lTotalBytesRead As Long
    
    Const clBufferIncrement As Long = 2000, scUserAgent As String = "qwerty"
    Const INTERNET_OPEN_TYPE_PRECONFIG = 0, INTERNET_FLAG_EXISTING_CONNECT = &H20000000
    Const INTERNET_OPEN_TYPE_DIRECT = 1, INTERNET_OPEN_TYPE_PROXY = 3
    Const INTERNET_DEFAULT_HTTP_PORT = 80, INTERNET_FLAG_RELOAD = &H80000000
    Const INTERNET_SERVICE_HTTP = 3
    Const HTTP_QUERY_CONTENT_LENGTH = 5
    
    If lBufferSize = -1 Then
        sBuffer = String$(clBufferIncrement, vbNullChar)
        lBufferSize = clBufferIncrement
    Else
        sBuffer = String$(lBufferSize, vbNullChar)
    End If
    

    hInternetSession = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
    hInternetConnect = InternetConnect(hInternetSession, sServerName, INTERNET_DEFAULT_HTTP_PORT, sUsername, sPassword, INTERNET_SERVICE_HTTP, 0, 0)
    hHttpOpenRequest = HttpOpenRequest(hInternetConnect, "GET", sFileName, "HTTP/1.0", vbNullString, 0, INTERNET_FLAG_RELOAD, 0)
    
    lRetVal = HttpSendRequest(hHttpOpenRequest, vbNullString, 0, 0, 0)
    If lRetVal Then
        lResLen = lBufferSize
        lRetVal = HttpQueryInfo(hHttpOpenRequest, HTTP_QUERY_CONTENT_LENGTH, ByVal sBuffer, lResLen, 0)
        If lRetVal Then
            lLenFile = Val(Left$(sBuffer, lResLen))
            sBuffer = String$(lLenFile, vbNullChar)
            lBufferSize = lLenFile
        Else
            lLenFile = -1
        End If
        
        Do
            lRetVal = InternetReadFile(hHttpOpenRequest, sBuffer, lBufferSize, lNumberOfBytesRead)
            InternetGetText = InternetGetText & Left$(sBuffer, lNumberOfBytesRead)
            lTotalBytesRead = lTotalBytesRead + lNumberOfBytesRead
            If lNumberOfBytesRead = 0 Or lTotalBytesRead = lLenFile Or lRetVal = 0 Then

                Exit Do
            End If
        Loop
    End If

    InternetCloseHandle hHttpOpenRequest
    InternetCloseHandle hInternetSession
    InternetCloseHandle hInternetConnect
    
End Function

Function Kurs(waluta As String, data As String) As Double
    Dim q As String
    q = "?w=" & waluta & "&d=" & data
    Kurs = Val(InternetGetText("fantazyjny.esy.es", "/kurs_2.php" & q))
End Function

Sub Test()
    Debug.Print Kurs("EUR", "2014-10-31")
End Sub




Zaloguj się lub zarejestruj, aby odpowiedzieć w temacie.
Dołącz do naszej społeczności!


Zarejestruj się
Posiadasz konto? Kliknij poniżej.


Zaloguj się


Użytkownicy przeglądający ten wątek: 1 gości



Portal  Kontakt  Pomoc  Facebook 
© CentrumWindows
Polskie tłumaczenie © 2007-2016 Polski Support MyBB
Silnik forum MyBB, © 2002-2018 MyBB Group
Biznes-Host