ask7779
11-21-2010, 11:42 AM
Hello,
I am not sure why following code gives error at oApp.Namespace(DefPath).CopyHere oApp.Namespace(Fname).items
This error comes intermittently.
My complete code is:
Option Explicit
'Declarations
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
'Download Code
Sub download()
Dim done
Dim unzipdone
Dim filename
Dim szfromdate As String
Dim sztodate As String
Dim fromdate As Date
Dim todate As Date
Dim i As Date
Dim szDay As String
fromdate = "01-Sep-2010"
todate = "30-Sep-2010"
For i = fromdate To todate
szfromdate = Format(i, "ddmmyy")
filename = "eq" + szfromdate + "_csv.zip"
szDay = Format(i, "dddd")
If szDay <> "Saturday" And szDay <> "Sunday" Then
' Add http and : and // and www and . and bseindia. and com and / and Histbhav and / in the following AboveURL as I was not able to post the questoin.
done = URLDownloadToFile(0, "AboveURL" + filename, "C:\" + filename, 0, 0)
unzipdone = Unzip("C:\", "C:\" + filename)
Kill "C:\" + filename
End If
Next i
'Test.
If done = 0 Then
MsgBox "File has been downloaded!"
Else
MsgBox "File not found!"
End If
End Sub
Public Function Zipp(ZipName, FileToZip)
'Zips A File
'ZipName must be FULL Path\Filename.zip - name Zip File to Create OR ADD To
'FileToZip must be Full Path\Filename.xls - Name of file you want to zip
Dim FSO As Object
Dim oApp As Object
If Dir(ZipName) = "" Then
Open ZipName For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End If
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(ZipName).CopyHere (FileToZip)
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(ZipName).items.Count = 1
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
Set oApp = Nothing
Set FSO = Nothing
End Function
Public Function Unzip(DefPath, Fname)
'Unzips A File
'Fname must be FULL Path\Filename.zip
'DefPath must be valid Path you want to Unzip file TO
'You just need to pass 2 strings.
'C:\FullPath\Filename.zip - the file to UNZIP
'C:\FullPath\ - folder to unzip to
Dim FSO As Object
Dim oApp As Object
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(DefPath).CopyHere oApp.Namespace(Fname).items
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
Set oApp = Nothing
Set FSO = Nothing
End Function
Can someone please help?
Thanks in advance.
Best Regards,
- Sandeep
I am not sure why following code gives error at oApp.Namespace(DefPath).CopyHere oApp.Namespace(Fname).items
This error comes intermittently.
My complete code is:
Option Explicit
'Declarations
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
'Download Code
Sub download()
Dim done
Dim unzipdone
Dim filename
Dim szfromdate As String
Dim sztodate As String
Dim fromdate As Date
Dim todate As Date
Dim i As Date
Dim szDay As String
fromdate = "01-Sep-2010"
todate = "30-Sep-2010"
For i = fromdate To todate
szfromdate = Format(i, "ddmmyy")
filename = "eq" + szfromdate + "_csv.zip"
szDay = Format(i, "dddd")
If szDay <> "Saturday" And szDay <> "Sunday" Then
' Add http and : and // and www and . and bseindia. and com and / and Histbhav and / in the following AboveURL as I was not able to post the questoin.
done = URLDownloadToFile(0, "AboveURL" + filename, "C:\" + filename, 0, 0)
unzipdone = Unzip("C:\", "C:\" + filename)
Kill "C:\" + filename
End If
Next i
'Test.
If done = 0 Then
MsgBox "File has been downloaded!"
Else
MsgBox "File not found!"
End If
End Sub
Public Function Zipp(ZipName, FileToZip)
'Zips A File
'ZipName must be FULL Path\Filename.zip - name Zip File to Create OR ADD To
'FileToZip must be Full Path\Filename.xls - Name of file you want to zip
Dim FSO As Object
Dim oApp As Object
If Dir(ZipName) = "" Then
Open ZipName For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End If
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(ZipName).CopyHere (FileToZip)
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(ZipName).items.Count = 1
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
Set oApp = Nothing
Set FSO = Nothing
End Function
Public Function Unzip(DefPath, Fname)
'Unzips A File
'Fname must be FULL Path\Filename.zip
'DefPath must be valid Path you want to Unzip file TO
'You just need to pass 2 strings.
'C:\FullPath\Filename.zip - the file to UNZIP
'C:\FullPath\ - folder to unzip to
Dim FSO As Object
Dim oApp As Object
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(DefPath).CopyHere oApp.Namespace(Fname).items
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
Set oApp = Nothing
Set FSO = Nothing
End Function
Can someone please help?
Thanks in advance.
Best Regards,
- Sandeep