Binäre Datei schreiben

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Bin so matt, habs gefunden.

26.02.2006 23:41:32

Norman

AW: Bin so matt, habs gefunden.

26.02.2006 23:45:41

Reinhard

Klaro!

27.02.2006 20:51:32

Norman

Danke dir o.w.T.

28.02.2006 15:01:14

Reinhard

Hier der Code. Geht bestimmt auch einfacher, hatte aber keine Lust mehr. Wahrscheinlich gib's eine Einzelfunktion für den ganzen Kram, ich will aber gerne eine Progress-bar nutzen. Leider muss man die Dateigröße kennen, um dann einen Balken laufen zu lassen, aber in meinem Fall ist die Grüße bekannt.
Viele Grüße
Norman
Option Explicit
Option Base 1
'Declares for direct ping
Private Declare


Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal lpszAgent As String, ByVal dwAccessType As Long, ByVal lpszProxyName As String, ByVal lpszProxyBypass As String, ByVal dwFlags As Long) As Long
Private Declare 

Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal hInet As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare 

Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Long
Private Declare 

Function InternetReadFile Lib "wininet.dll" _
(ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, _
lNumberOfBytesRead As Long) As Integer
Private Declare 

Function InternetGetLastResponseInfo Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" _
(lpdwError As Long, ByVal lpszBuffer As String, ByVal lpdwBufferLength As Long) As Integer
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const INTERNET_FLAG_KEEP_CONNECTION = &H400000
Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000
Public 

Function SaveInetFile(fName As String, destFName As String, Optional fsize As Long = 0) As Boolean
Dim hInet As Long
Dim hUrl As Long
Dim Flags As Long
Dim url As Variant
SaveInetFile = False
hInet = InternetOpen(" ", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0&)
If hInet Then
Flags = INTERNET_FLAG_KEEP_CONNECTION Or INTERNET_FLAG_NO_CACHE_WRITE Or INTERNET_FLAG_RELOAD
hUrl = InternetOpenUrl(hInet, "hierbitte_HTTP_ADRESSE_REIN_www_meine_adresse_de_SLASH" & fName, vbNullString, 0, Flags, 0)
If hUrl Then
Dim sReadBuf As String * 512
Dim flagMoreData As Boolean
Dim bytesRead As Long
Dim wRet As Integer
Dim lastErr As Long
flagMoreData = True
Dim fileNr As Integer
fileNr = FreeFile
If FileExists(destFName) Then Kill destFName
Open destFName For Binary As #fileNr ' Dateiname
Do While flagMoreData
sReadBuf = vbNullString
wRet = InternetReadFile(hUrl, sReadBuf, Len(sReadBuf), bytesRead)
If Err.LastDllError <> 0 Then
lastErr = Err.LastDllError
Close #fileNr
GoTo exitfunc
End If
If wRet <> 1 Then
Close #fileNr
GoTo exitfunc
End If
Dim tArray() As Byte
If bytesRead > 0 Then
ReDim tArray(bytesRead)
Dim i As Long
For i = 1 To bytesRead
tArray(i) = CByte(Asc(Mid(sReadBuf, i, 1)))
Next i
Put #fileNr, , tArray
End If
If Not CBool(bytesRead) Then flagMoreData = False
Loop
Close #fileNr
Call InternetCloseHandle(hUrl)
Call InternetCloseHandle(hInet)
SaveInetFile = True
Exit Function
Else
Call InternetCloseHandle(hInet)
End If
End If
Exit Function
exitfunc:
If hUrl <> 0 Then InternetCloseHandle (hUrl)
If hInet <> 0 Then InternetCloseHandle (hInet)
End Function

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Binäre Datei schreiben

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread