I am trying to run one script which parse url and projectname from file and try to download files from url into the zip format. I am seeing error this while writing file to the folder. I am using windows sserver 2012 R2
ADODB.Stream : Write to the file failed
I've verified IUSER and other users have full access to the target and source folder.
Here is the script. May I know if something I am missing here?
Dim URLFile
Dim URLLine, URL, ProjectName
Dim xHttp, bStrm
Set objShell = CreateObject("WScript.Shell")
Set WshShell = WScript.CreateObject("WScript.Shell")
set fso = createobject("scripting.filesystemobject")
Set URLFile = fso.OpenTextFile("C:\Temp\Scripts\VBScripts\URLList.txt")
do while not URLFile.AtEndOfStream
URLLine = URLFile.ReadLine()
'Wscript.Echo URLLine
if len(URLLine)>10 then
URL = Left(URLLine,inStr(URLLine,";")-1)
ProjectName = Right(URLLine,Len(URLLine)-inStr(URLLine,";"))
Set xHttp = createobject("Microsoft.XMLHTTP")
Set bStrm = createobject("Adodb.Stream")
xHttp.Open "GET", URL, False
xHttp.Send
with bStrm
.type = 1 '//binary
.open
.write xHttp.responseBody
.savetofile "C:\Backups\"&"Backup Zip All Files for "&ProjectName&"-"&cStr(Date)&".zip", 2 '//overwrite
end with
Set xHttp = Nothing
Set bStrm = Nothing
end if
loop
If you get past the permissions thing by making read/write for Everyone, all you need then is a module to perform the ZIP function.
I usually use a commercial DLL and there are many to choose from.
Related
I have the url which contains a zipped csv file, I need to download only .csv from the zip , the Codes below is downloading zip
Sub DownloadFile()
Dim myURL As String
myURL = "https://www1.nseindia.com/content/historical/EQUITIES/2020/FEB/cm07FEB2020bhav.csv.zip"
Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False, "username", "password"
WinHttpReq.send
If WinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.SaveToFile "C:\Users\playt\Desktop\STACK\ruff.zip", 2 ' 1 = no overwrite, 2 = overwrite
oStream.Close
End If
End Sub
You cannot download a file from an archive, but you can adapt your code in the next way:
Insert this lines at the end of your existing code (just before End Sub):
Dim zipFileName As String, unZipFolderName As String
zipFileName = "C:\Users\playt\Desktop\STACK\ruff.zip"
unZipFolderName = left(zipFileName, InStrRev(zipFileName, "\") - 1)
UN_Zip zipFileName, unZipFolderName
The simplest sub able to unzip and delete the archive must look like that (it needs a reference to 'Microsoft Shell Controls And Automation'):
Private Sub UN_Zip(zipFileName As String, unZipFolderName As String)
Dim wShApp As New Shell
wShApp.Namespace(unZipFolderName).CopyHere wShApp.Namespace(zipFileName).Items
Kill zipFileName
End Sub
If too lazy for adding the reference, to make the code look more elegant, the sub can be adapted with only two lines:
Use Dim wShApp As Object instead of Dim wShApp As New Shell declaration and then add the next line:
Set ShApp = CreateObject("Shell.Application")
In this way, no reference is necessary, anymore...
I have a VBScript for zipping up old IIS log files. I keep getting this error though:
Microsoft VBScript runtime error: ActiveX component can't create
object: 'GetObject'
This is the line it errors on:
Set objIISOuter = GetObject("IIS://LOCALHOST")
I am unsure of what this means.
Tried what I found here and I wasn't able to get anything running with 32 or 64 bit.
I read somewhere that it could be a problem with a DLL not being registered but I don't know how this could be an issue here, might be wrong though.
For Each objWebOuter in objIISOuter
If LCase(objWebOuter.Class) = "iiswebservice" Then
Set objIIS = GetObject("IIS://LOCALHOST/W3SVC")
For Each objWeb in objIIS
If LCase(objWeb.Class) = "iiswebserver" Then
Call DeleteLogFiles( _
objWeb.LogFileDirectory & "\W3SVC" & objWeb.Name, _
intZipAge, intDelAge)
End If
I'm an admin so permissions aren't the issue. Any ideas?
Here are two potential approaches:
Use the FileSystemObject to get the LogFiles folder and delete files:
sLogFolder = "%SystemDrive%\inetpub\logs\LogFiles"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(sLogFolder)
For Each objSubfolder In objFolder.SubFolders
DeleteFiles objSubfolder.Path, 10
Next
Another approach:
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objIIS = GetObject("winmgmts:root\WebAdministration")
Set objSites = objIIS.InstancesOf("Site")
For Each objSite In objSites
DeleteFiles objSite.LogFile.Directory & "\w3svc\" & objSite.ID, 10
Next
Both approaches use the following Sub to delete the files from a folder:
Sub DeleteFiles(p_sFolder, p_iMaxAge)
Dim objFSO
Dim objFolder
Dim objFile
Dim iFileAge
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(p_sFolder)
If objFolder Is Nothing Then Exit Sub
For Each objFile In objFolder.Files
iFileAge = Now - objFile.DateCreated
If iFileAge > (p_iMaxAge) Then
objFSO.DeleteFile objFile, True
End If
Next
End Sub
I am trying to make a part in my routine which retrieves a .xls document from a FTP location.
I have been googling for quite a few hours now and I am starting to get quite frustrated with this piece of code.
When running the code I get Run-Time error '3001' saying that my arguments are either of the wrong type and are out of the aceptable range, or are in conflict with one another.
Sub GetFTPFile()
Dim objXML
Dim strFTPResponse
Dim varUser, varPassword As Variant
Dim LocalDir As String
Set objXML = CreateObject("MSXML2.XMLHTTP")
strURL = "ftp://xyz_hourly.xls"
LocalDir = "c//"
varUser = "xxx"
varPassword = "yyy"
Call objXML.Open("GET", strURL, varUser, varPassword, False)
Call objXML.send
Do While objXML.readystate <> 4
DoEvents
Loop
Set File = CreateObject("ADODB.Stream")
File.Type = 1
File.Open
File.Write objXML.ResponseBody
File.SaveToFile "c//yyy.xlsx", 2
End Sub
I am trying to download all the csv files from a specific website by using excel vba
Following is the code i have prepared :
Sub Gettable()
Dim URL As String
Dim ie As Object
Dim ieDoc As Object
Dim sel_day As Variant
URL = "http://www.bseindia.com/markets/equity/EQReports/BhavCopyDebt.aspx?expandable=3"
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
ie.navigate URL
Do Until (ie.readyState = 4 And Not ie.Busy)
DoEvents
Loop
Set ieDoc = ie.document
'============================================================================
ieDoc.getElementsByTagName("Select")("fdate1").Options("02").SelectIndex
'============================================================================
'ie.Quit
'Set ie = Nothing
'Set ieDoc = Nothing
End Sub
Now the problem i am facing here is i am not able to change the contents dropdown box(to form a date).
I have already tried lots of solutions from stackoverflow as well as other websites but havent got any success. i have good programming knowledge but am stuck at this point the whole day. Any help would be appreciated. thanks in advance :)
All i wanted in the end was to download all csv files. I figured out an alternative solution in the mean time to download the csv file but would still appreciate if someone gives a solution to this issue i had posted above... :)
My alternative Solution as follows :
Sub try10() 'Took me 10 tries by the way :)
Dim NoOfDays As Long, i As Long
Dim MyDate As Variant
'Since the minimum date can't be less #1/1/2007# so lets loop until Mydate reaches #1/1/2007#.
NoOfDays = Date - #1/1/2007#
For i = 0 To NoOfDays
MyDate = Format((Date - i), "ddmmyy")
Dim myURL As String
myURL = "http://www.bseindia.com/download/BhavCopy/Equity/eq" & MyDate & "_csv.zip"
Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False
WinHttpReq.Send
myURL = WinHttpReq.ResponseBody
If WinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.ResponseBody
oStream.SaveToFile ("C:\Users\X\Desktop\BhavCopies\eq" & MyDate & "_csv.zip")
oStream.Close
End If
Next
End Sub
This solution however produces a 211kb fake file for csv's that don't exist which can be dealt with manually . :) ;)
The items you are trying to control are in an iframe. To get to the HTML inside the iframe, extract the src attribute from the tag and navigate to the URL formed by that src and the base URL. In this case the src is "Equitydebcopy.aspx", so if you navigate to "http://www.bseindia.com/markets/equity/EQReports/Equitydebcopy.aspx" you'll find that the following lines will allow you to get the information you want.
ie.document.getElementByID("fdate1").Value = "15"
ie.document.getElementByID("fmonth1").Value = "1"
ie.document.getElementByID("fyear1").Value = "2014"
ie.document.getElementByID("btnSubmit").Click
I searched SO, SU, and SP.SE for a solution, but could not find what I needed. I'm looking for a solution which may be a script or some other non-coding method/tool.
I am trying to write a script (to be used by others) or some other form of automation to upload various reports automatically to a SharePoint site. I have managed to get the following (VBScript) code to work, but only for text-based files -- .CSV in this case, though this also works for .TXT, etc.
Option Explicit
Dim sCurPath
sCurPath = CreateObject("Scripting.FileSystemObject").GetAbsolutePathName(".")
UploadAllToSP sCurPath
Sub UploadAllToSP(sFolder)
Dim fso, folder, fil
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(sFolder)
For Each fil In folder.Files
If fso.GetExtensionName(fil) = "csv" Then
UploadFileToSP fil
End If
Next
End Sub
Sub UploadFileToSP(ofile)
Dim xmlhttp
Dim sharepointUrl
Dim sharepointFileName
Dim tsIn
Dim sBody
Set tsIn = ofile.openAsTextstream
sBody = tsIn.readAll
tsIn.close
sharepointUrl = "http://SHAREPOINT URL HERE"
sharepointFileName = sharepointUrl & ofile.name
set xmlHttp = createobject("MSXML2.XMLHTTP.4.0")
xmlhttp.open "PUT", sharepointFileName, false
xmlhttp.send sBody
If xmlhttp.status < 200 Or xmlhttp.status > 201 Then
wscript.echo "There was a problem uploading " & ofile.name & "!"
End If
End Sub
This only works for text files because it pipes the text data into a file on the SP site. However, if I want to transfer any kind of binary file (.XLS, .PDF), this results in garbage being uploaded.
I tried to take a look at a Shell.Application ==> .Namespace(), but this doesn't seem to work with a URL, but only a physical drive. Here's some of what else I tried (trimmed to show relevant pieces):
Set oApp = CreateObject("Shell.Application")
If oApp.NameSpace(sharepointUrl) <> Null then ' Always Null!
' Copy here
' Some lines omitted
oApp.NameSpace(sharepointUrl).CopyHere ofile.Name ' This also fails when not surrounded by the Null check
Else
MsgBox "SharePoint directory not found!"
End If
I also tried a batch file using xcopy, but that can't connect to the http:// either. I looked at this method, which may work for me, but I'd prefer not to deal with mapping/NET USE, since our company has multiple network shares, the mapping for which varies depending on who's logged in.
Since none of these work quite the way I need: Is there a method to automate this kind of functionality?
I have experience with VBA/VBscript, so either a script like the above, or something built in to an MS Office application (Outlook is best, but I can probably adapt whatever I am given) would be preferable. That being said, I am open to any method that would allow me to do this, running natively in Windows or Office. However, I do not have access to Visual Studio, so I can't use any .NET functionality.
Thanks to Sean Cheshire for pointing me at the obvious answer that I did not see. Posting the relevant code, since I don't believe this yet exists on SO.
Sub UploadFilesToSP(sFolder)
Dim sharepointUrl
Dim sharepointFileName
Dim LlFileLength
Dim Lvarbin()
Dim LobjXML
Dim LvarBinData
Dim PstrFullfileName
Dim PstrTargetURL
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Dim fldr
Dim f
'This has not been successfully tested using an "https" connection.
sharepointUrl = "http://SHAREPOINT URL HERE"
Set LobjXML = CreateObject("Microsoft.XMLHTTP")
Set fldr = fso.GetFolder(sFolder)
For Each f In fldr.Files
sharepointFileName = sharepointUrl & f.Name
PstrFullfileName = sFolder & f.Name
LlFileLength = FileLen(PstrFullfileName) - 1
' Read the file into a byte array.
ReDim Lvarbin(LlFileLength)
Open PstrFullfileName For Binary As #1
Get #1, , Lvarbin
Close #1
' Convert to variant to PUT.
LvarBinData = Lvarbin
PstrTargetURL = sharepointFileName
' Put the data to the server, false means synchronous.
LobjXML.Open "PUT", PstrTargetURL, False
' Send the file in.
LobjXML.Send LvarBinData
Next f
Set LobjXML = Nothing
Set fso = Nothing
End Sub
This is VBA code, formatted to mostly work with VBScript, though I could not get this block to transfer properly. As VBA, this can be improved some by assigning data types, etc.
' Read the file into a byte array.
ReDim Lvarbin(LlFileLength)
Open PstrFullfileName For Binary As #1
Get #1, , Lvarbin
Close #1
This is a very old post but a very useful one so thanks to everyone's contribution. This is my version with the early binding. I found that the previous posting didn't work due to VBA assumption of the none declared variable types.
Private Sub cmdUploadToApplicationsAndApprovals_Click()
Dim strSharePointUrl As String
Dim strSharePointFileName As String
Dim lngFileLength As Long
Dim bytBinary() As Byte
Dim objXML As XMLHTTP
Dim varBinData As Variant
Dim strFullfileName As String
Dim strTargetURL As String
Dim fso As FileSystemObject
Set fso = New FileSystemObject
Dim folder As folder
Dim file As file
Dim strFolder As String
strFolder = CurrentProject.Path & "\Upload\"
'This has not been successfully tested using an "https" connection.
strSharePointUrl = "http://sps.mysite.ca/subsite/DocLib/"
Set objXML = New XMLHTTP 'CreateObject("Microsoft.XMLHTTP")
Set folder = fso.GetFolder(strFolder)
For Each file In folder.Files
strSharePointFileName = strSharePointUrl & file.Name
strFullfileName = strFolder & file.Name
lngFileLength = FileLen(strFullfileName) - 1
'Read the file into a byte array.
ReDim bytBinary(lngFileLength)
Open strFullfileName For Binary As #1
Get #1, , bytBinary
Close #1
'Convert to variant to PUT.
varBinData = bytBinary
strTargetURL = strSharePointFileName
'Put the data to the server, false means synchronous.
objXML.Open "PUT", strTargetURL, False
'Send the file in.
objXML.Send varBinData
'Now Update the metadata
Next file
'Clean up
Set objXML = Nothing
Set fso = Nothing
MsgBox "Done"
End Sub
FYI the above code required 2 references.
1. Microsoft XML, v6.0
2. Microsoft Scripting Runtime
Hope this helps improve on the already brilliant answer!!