P
pubdude2003
the code below does not seem to loop properly, anyone have a notion? It runs
from a button on a form and it only writes the record that has Focus when the
button is activated.
On Error GoTo ErrHandler
Dim cnts1 As String
Dim cnts2 As String
Dim strPath As String
Dim strPath2 As String
Dim aFolders() As String
Dim I As Integer
Dim objHTTP As HTTP
Set rs = Me.RecordsetClone
Dim strJustFile As String
rs.MoveFirst
Do While Not rs.EOF
rs.Edit
cnts2 = Mid([Contents], 43, 5)
Set objHTTP = New HTTP
With objHTTP
.HttpURL = "http://webplace.com/" & cnts2 & ".zip"
.DestinationFile = "D:\2\" & cnts2 & ".zip"
If .FileExists Then .OverwriteTarget = True
If Not .IsConnected Then .DialDefaultNumber
.ConnectToHTTPHost
.WriteHTTPDataToFile
End With
Set objHTTP = Nothing
rs.Update
strPath = "D:/1/"
strPath = strPath + cnts2 'Left(cnts2, 5)
strPath2 = ("D:\2\" & cnts2 & ".zip")
If IsFileOpen(strPath2) Then
For y = 1 To 3000
Pause 1000
Next y
End If
aFolders = Split(strPath, "\")
strPath = vbNullString
For I = LBound(aFolders) To UBound(aFolders)
strPath = strPath & aFolders(I)
If Len(Dir(strPath, vbDirectory)) = 0 Then
MkDir strPath
End If
strPath = strPath & "/"
Next I
strPath2 = ("D:\2\" & cnts2 & ".zip")
Call UnzipIt(strPath2, strPath)
CurrentDb.Execute "INSERT INTO tblDirectory2" & _
" ( FileDate, subject, justfile )" & _
" VALUES ( '" & rs!Received & "', '" & rs!Subject & "', '" & rs!Contents
& "' )" ', dbFailOnError
rs.MoveNext
Loop
from a button on a form and it only writes the record that has Focus when the
button is activated.
On Error GoTo ErrHandler
Dim cnts1 As String
Dim cnts2 As String
Dim strPath As String
Dim strPath2 As String
Dim aFolders() As String
Dim I As Integer
Dim objHTTP As HTTP
Set rs = Me.RecordsetClone
Dim strJustFile As String
rs.MoveFirst
Do While Not rs.EOF
rs.Edit
cnts2 = Mid([Contents], 43, 5)
Set objHTTP = New HTTP
With objHTTP
.HttpURL = "http://webplace.com/" & cnts2 & ".zip"
.DestinationFile = "D:\2\" & cnts2 & ".zip"
If .FileExists Then .OverwriteTarget = True
If Not .IsConnected Then .DialDefaultNumber
.ConnectToHTTPHost
.WriteHTTPDataToFile
End With
Set objHTTP = Nothing
rs.Update
strPath = "D:/1/"
strPath = strPath + cnts2 'Left(cnts2, 5)
strPath2 = ("D:\2\" & cnts2 & ".zip")
If IsFileOpen(strPath2) Then
For y = 1 To 3000
Pause 1000
Next y
End If
aFolders = Split(strPath, "\")
strPath = vbNullString
For I = LBound(aFolders) To UBound(aFolders)
strPath = strPath & aFolders(I)
If Len(Dir(strPath, vbDirectory)) = 0 Then
MkDir strPath
End If
strPath = strPath & "/"
Next I
strPath2 = ("D:\2\" & cnts2 & ".zip")
Call UnzipIt(strPath2, strPath)
CurrentDb.Execute "INSERT INTO tblDirectory2" & _
" ( FileDate, subject, justfile )" & _
" VALUES ( '" & rs!Received & "', '" & rs!Subject & "', '" & rs!Contents
& "' )" ', dbFailOnError
rs.MoveNext
Loop