' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller _
As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB _
As Long) As Long
Private Function TextReadAll(ByVal FileName As String) As String
Dim FF As Integer, strText As String
On Error Resume Next
FF = FreeFile
Open FileName For Binary As #FF
strText = Space$(LOF(FF))
Get #FF, , strText
Close #FF
TextReadAll = strText
On Error GoTo 0
Err.Clear
End Function
Public Sub test()
Dim strTmp As String, strSrc As String, strFile As String
Dim varTmp() As Variant
Dim lngI As Long, lngP1 As Long, lngP2 As Long
On Error GoTo ErrorHandler
strSrc = "http://www.karopapier.de/api/user/773/dran.json"
strFile = Environ("TEMP") & "\tmp.json"
Call URLDownloadToFile(0, strSrc, strFile, 0, 0)
If Dir(strFile, vbNormal) <> "" Then
strTmp = TextReadAll(strFile)
Do
lngP1 = InStr(lngP1 + 1, strTmp, "GID=")
If lngP1 > 0 Then
lngP2 = InStr(lngP1, strTmp, "}")
If lngP2 > 0 Then
Redim Preserve varTmp(lngI)
varTmp(lngI) = Clng(Mid(strTmp, lngP1 + 4, lngP2 - lngP1 - 5))
lngI = lngI + 1
End If
End If
Loop While lngP1 > 0 And lngP2 > 0
If lngI > 0 Then
Sheets("API").Range("A1").Resize(lngI, 1) = Application.Transpose(varTmp)
End If
Kill strFile
End If
ErrorHandler:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'test'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Prozedur - test"
.Clear
End If
End With
On Error GoTo 0
End Sub