I am trying to download a .pdf file which opens up in an IE Web browser. Here is my code:
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
Sub DownPDF()
Dim sUrl As String
Dim sPath As String
sPath = "C:\Users\adhil\Documents"
sUrl = "http://analytics.ncsu.edu/sesug/2010/HOW01.Waller.pdf"
Ret = URLDownloadToFile(0, sUrl, sPath, 0, 0)
If Ret = 0 Then
Debug.Print sUrl & " downloaded to " & sPath
Else
Debug.Print sUrl & " not downloaded"
End If
End Sub
However, I am unable to get the file downloaded although response says so.
Can anyone assist me?
The function expects the parameter szFileName to be a fullpath name of a file, not a folder.
Try with this:
sPath = "C:\Users\adhil\Documents\HOW01.Waller.pdf"
I worked with me, while it did not work when the destination file name was omitted.
Related
I've been using this code to print PDFs from a folder at work but the code isn't working anymore. I'm working remotely from home and I've updated the file path and I still receive a run time 53 error code. Can anyone help?
Public Sub Print_All_PDF_Files_in_Folder()
Dim folder As String
Dim PDFfilename As String
folder = "C:\Users\16468\Desktop\CONF\TAXES" 'CHANGE AS REQUIRED
If Right(folder, 1) <> "\" Then folder = folder & "\"
PDFfilename = Dir(folder & "*.pdf", vbNormal)
While Len(PDFfilename) <> 0
Print_PDF folder & PDFfilename
PDFfilename = Dir() ' Get next matching file
Wend
End Sub
Private Sub Print_PDF(sPDFfile As String)
Shell "C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe /p /h " & Chr(34) & sPDFfile & Chr(34), vbNormalFocus
End Sub
This Should print just about anything:
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function ShellExecute _
Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As LongPtr, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) _
As LongPtr
#Else
Private Declare Function ShellExecute _
Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) _
As Long
#End If
Private Const SW_HIDE = 0
Sub FilePrint(ByVal strFilePath As String)
Dim retVal As Long
retVal = ShellExecute(0, "Print", strFilePath, 0, 0, SW_HIDE)
If retVal < 32 Then
'// there are Error codes for this..left out
MsgBox "An Error occured...could not print"
End If
End Sub
Public Sub Print_All_PDF_Files_in_Folder()
Dim folder As String
Dim PDFfilename As String
folder = "C:\Users\16468\Desktop\CONF\TAXES" 'CHANGE AS REQUIRED
If Right(folder, 1) <> "\" Then folder = folder & "\"
PDFfilename = Dir(folder & "*.pdf", vbNormal)
While Len(PDFfilename) <> 0
FilePrint folder & PDFfilename
PDFfilename = Dir() ' Get next matching file
Wend
End Sub
Original Code found here
I created a macro for a file and first it was working fine, but today I've been opening and restarting the file and macro hundreds of times and I'm always getting the following error:
Excel VBA Run-time error '13' Type mismatch
I didn't change anything in the macro and don't know why am I getting the error. Furthermore it takes ages to update the macro every time I put it running (the macro has to run about 9000 rows).
ERROR is somewhere "FileData = WHTTP.ResponseBody"
Sub Test2()
Dim A As Long
Dim FileNum As Long
Dim FileData() As Byte
Dim MyFile As String
Dim WHTTP As Object
On Error Resume Next
Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5")
If Err.Number <> 0 Then
Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5.1")
End If
On Error GoTo 0
If Dir("C:\MyDownloads", vbDirectory) = Empty Then MkDir "C:\MyDownloads"
For A = 1 To 228
MyFile = Cells(A, 1).Text
TempFile = Right(MyFile, InStr(1, StrReverse(MyFile), "/") - 1)
WHTTP.Open "GET", MyFile, False
WHTTP.Send
FileData = WHTTP.ResponseBody
FileNum = FreeFile
Open "C:\MyDownloads\" & TempFile For Binary Access Write As #FileNum
Put #FileNum, 1, FileData
Close #FileNum
Next
Set WHTTP = Nothing
MsgBox "Open the folder [ C:\MyDownloads ] for the downloaded file..."
End Sub
Put On Error Resume Next above the line causing an error (probably this line WHTTP.Send). Put this block of code after your line with an error.
Files/Web Addresses/Registry keys - YOU MUST ASSUME IT MAY NOT WORK and trap errors so you know why (and where it's not working). Usually these are not programming questions.
If err.number <> 0 then
ERRString = ErrString & ""
ERRString = ErrString & "Error getting file"
ERRString = ErrString & "=================="
ERRString = ErrString & ""
ERRString = ErrString & "Error " & err.number & "(0x" & hex(err.number) & ") " & err.description
ERRString = ErrString & "Source " & err.source
ERRString = ErrString & ""
ERRString = ErrString & "HTTP Error " & WHTTP.Status & " " & WHTTP.StatusText
ERRString = ErrString & WHTTP.getAllResponseHeaders
Msgbox ErrString
End If
Just download direct using API call and URL
Option Explicit
#If VBA7 And Win64 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As LongPtr, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As LongPtr, _
ByVal lpfnCB As LongPtr _
) As Long
Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "Wininet.dll" _
Alias "DeleteUrlCacheEntryA" ( _
ByVal lpszUrlName As String _
) As Long
#Else
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 Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" _
Alias "DeleteUrlCacheEntryA" ( _
ByVal lpszUrlName As String _
) As Long
#End If
Public Const BINDF_GETNEWESTVERSION As Long = &H10
Public Const folderName As String = "C:\Users\User\Desktop\Blah.zip" '<== Change to destination
Public Sub downloadIFolder()
Dim ret As Long
ret = URLDownloadToFile(0, "http://www.bseindia.com/BSEDATA/margins/VAR290716.zip", folderName, BINDF_GETNEWESTVERSION, 0)
MsgBox ret
End Sub
Problem description:
Unable to connect to a FTPS server , this is a private server FTP Over SSL or FTPS. It is a secure connection same as HTTPS. .The code I am using is successful to connect to a public server . But it seems in order to connect to a secured FTPS server I need to use some sort of SSL encryption . I have no idea at all , I am java guy but I am asked to fix this , it is always fun to learn new things , and this time its VBA code, . Please help me VBA experts.
Can somebody please tell me what and where is the code I should modify or add in order to connect to my FTPS server . Please note again I can connect to FTP server but not FTPS.
Below is the code I am currently using. This will be a great help thank you!
'API code
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Const MAX_PATH = 260
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private Declare Function InternetOpen _
Lib "wininet.dll" _
Alias "InternetOpenA" _
(ByVal sAgent As String, _
ByVal lAccessType As Long, _
ByVal sProxyName As String, _
ByVal sProxyBypass As String, _
ByVal lFlags As Long) As Long
'Connect to the network
Private Declare Function InternetConnect _
Lib "wininet.dll" _
Alias "InternetConnectA" _
(ByVal hInternetSession As Long, _
ByVal sServerName As String, _
ByVal nServerPort As Integer, _
ByVal sUsername As String, _
ByVal sPassword As String, _
ByVal lService As Long, _
ByVal lFlags As Long, _
ByVal lContext As Long) As Long
'Get a file using FTP
Private Declare Function FtpGetFile _
Lib "wininet.dll" _
Alias "FtpGetFileA" _
(ByVal hFtpSession As Long, _
ByVal lpszremoteDir As String, _
ByVal lpszNewFile As String, _
ByVal fFailIfExists As Boolean, _
ByVal dwFlagsAndAttributes As Long, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Boolean
'Close the Internet object
Private Declare Function InternetCloseHandle _
Lib "wininet.dll" _
(ByVal hInet As Long) As Integer
'
Private Declare Function FtpFindFirstFile _
Lib "wininet.dll" _
Alias "FtpFindFirstFileA" _
(ByVal hFtpSession As Long, _
ByVal lpszSearchFile As String, _
lpFindFileData As WIN32_FIND_DATA, _
ByVal dwFlags As Long, _
ByVal dwContent As Long) As Long
Private Declare Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" _
(ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" _
(ByVal hConnect As Long, ByVal lpszDirectory As String) As Long
'***************
'downloadFile method downloads files from a specified server through FTP
'This method downloads files on only first level of specified directory on the server
'
'
'
'
'***************
'***************
'To do
'
'1. if localDir does not include "\", it does not work - fixed
'2. if folders exist on the remote server, it will not download
'
'
'***************
'download files from a specified server
Public Function downloadFiles(ServerName As String, UserName As String, Password As String, remoteDir As String, localDir As String, logFile As String) As Variant()
Dim INet As Long
Dim INetConn As Long
Dim RetVal As Long
Dim Success As Long
Dim hFile As Long
Dim w32FindData As WIN32_FIND_DATA
Dim StrFile As String
Dim fileList() As String
Dim cnt As Long
Dim gcnt As Long
Dim i As Integer
Dim curDir As Long
Dim result(1) As Variant
cnt = -1
gcnt = 0
RetVal = False
Rem confirm local dir has \ at the end
If Not Right(localDir, 1) = "\" Then
localDir = localDir + "\"
End If
'Test Code need to remove as the username and password are hardcoded
INet = InternetOpen("MYFTP Control", 1&, vbNullString, vbNullString, 0&)
If INet > 0 Then
INetConn = InternetConnect(INet, ServerName, 0&, UserName, Password, 1&, 0&, 0&)
If INetConn > 0 Then
file.log "==== Connected to " & ServerName & "===", logFile
curDir = FtpSetCurrentDirectory(INetConn, remoteDir)
If (curDir <> 0) Then
file.log "current remote dir: " & remoteDir, logFile
End If
''''''''''''''''''''
''Create a list of files to download
''''''''''''''''''''
'get file list
hFile = FtpFindFirstFile(INetConn, remoteDir, w32FindData, INTERNET_FLAG_RELOAD, 0&)
'create a list of files on the remote server
If hFile = 0 Then
file.log "cannot get a list of files", logFile
Else
Do
StrFile = Left(w32FindData.cFileName, InStr(w32FindData.cFileName, vbNullChar) - 1)
StrFile = Mid(StrFile, InStrRev(StrFile, " ") + 1)
'if the path is directory, skip this
If ((w32FindData.dwFileAttributes And &H10) <> &H10) Then
'strFile = strFile & "/"
cnt = cnt + 1
ReDim Preserve fileList(cnt)
fileList(cnt) = StrFile
Debug.Print StrFile 'Debug
End If 'end of skiping dir condition
Loop Until InternetFindNextFile(hFile, w32FindData) = 0
''''''''''''''''''''
''Download files on the list
''''''''''''''''''''
For i = 0 To cnt
'set local file
StrFile = localDir & fileList(i)
'download a file
Success = FtpGetFile(INetConn, fileList(i), StrFile, False, FILE_ATTRIBUTE_NORMAL, BINARY_TRANSFER, 0&)
If Success > 0 Then
file.log fileList(i) & " is downloaded", logFile
gcnt = gcnt + 1
Else
file.log fileList(i) & " is Not downloaded", logFile
End If
Next
End If
RetVal = InternetCloseHandle(INet)
Else
'cannot connet to the server error message
file.log "Client cannnoot connet to " & ServerName, logFile
RetVal = InternetCloseHandle(INet)
End If
End If
result(0) = cnt + 1
result(1) = gcnt
file.log ServerName & " - " & "Downloaded files: " & CStr(result(1)) & " out of " & CStr(result(0)), logFile
If RetVal > 0 Then
file.log "===Connection is closed===", logFile
Else
file.log "===Connection is not closed correctly===", logFile
End If
downloadFiles = result
End Function
Private Function log(warnLevel As String, info As String, fileName As String)
End Function
Private Function msg(info As String)
MsgBox info
End Function
WinSCP will support FTPS (explicit or implicit); you can use VBA to interface with WinSCP via the latter's scripting commands.
These links should get you started:
https://winscp.net/eng/docs/ftps
https://winscp.net/eng/docs/scripting
https://stackoverflow.com/a/35644297/5472502
I am fresh-starter at VBA.
How do I download PDF file using UrlDownloadToFile from http://cetatenie.just.ro/wp-content/uploads/?
Can anybody help with this? The code is searching the PDF files udner hyperlinks and matches them under some criteria, i.e. the current year under their name.
Function UrlDownloadToFile(lNum As Long, sUrl As String, sPath As String, _
lNum1 As Long, lNum2 As Long) As Long
UrlDownloadToFile = 0
End Function
Sub DownPDF()
' This macro downloads the pdf file from webpage
' Need to download MSXML2 and MSHTML parsers and install
Dim sUrl As String
Dim xHttp As MSXML2.XMLHTTP
Dim hDoc As MSHTML.HTMLDocument
Dim hAnchor As MSHTML.HTMLAnchorElement
Dim Ret As Long
Dim sPath As String
Dim i As Long
sPath = "C:\Documents and Settings\ee28118\Desktop\"
sUrl = "http://cetatenie.just.ro/wp-content/uploads/"
'Get the directory listing
Set xHttp = New MSXML2.XMLHTTP
xHttp.Open "GET", sUrl
xHttp.send
'Wait for the page to load
Do Until xHttp.readyState = 4
DoEvents
Loop
'Put the page in an HTML document
Set hDoc = New MSHTML.HTMLDocument
hDoc.body.innerHTML = xHttp.responseText
'Loop through the hyperlinks on the directory listing
For i = 0 To hDoc.getElementsByTagName("a").Length - 1
Set hAnchor = hDoc.getElementsByTagName("a").Item(i)
'test the pathname to see if it matches your pattern
If hAnchor.pathname Like "Ordin-*.2013.pdf" Then
Ret = UrlDownloadToFile(0, sUrl & hAnchor.pathname, sPath, 0, 0)
If Ret = 0 Then
Debug.Print sUrl & hAnchor.pathname & " downloaded to " & sPath
Else
Debug.Print sUrl & hAnchor.pathname & " not downloaded"
End If
End If
Next i
End Sub
Sorry - I should have guessed that URLDownloadToFile was an API call and could have answered the whole question at SQL "%" equivalent in VBA.
Remove the function named URLDownloadToFile completely. Paste this at the top of the module where your Sample procedure is
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
Now change that one line in Sample to look like this
Ret = URLDownloadToFile(0, sUrl & hAnchor.pathname, sPath & hAnchor.pathname, 0, 0)
Then you should be good to go. If you want some different file name, then you'll have to code some logic to change it at each iteration.
I have mini project in VBA (Excel). I need to open the IE and download the files (save the doc) in the designated folder in my desktop.
However, I having difficulties in accessing the Download files dialog box. Even tried Savekeys concept but in vain.
How to proceed further and save the files?
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
Sub DownloadFileFromWeb()
Dim myFile As String
Dim strSavePath As String
Dim URL As String, ext As String
URL = "www.ahma.org/Education/BRD_Hardlines_Industry_Item.doc" 'for TEST
strSavePath = "C:\Users\Yogendra.Ur\Desktop\" & "DownloadedFile" & ext
Dim buf, Ret As Long
buf = Split(URL, ".")
ext = buf(UBound(buf))
Dim IE As Object
Set IE = CreateObject("internetexplorer.application")
IE.VISIBLE = True
IE.Navigate URL
Ret = URLDownloadToFile(0, URL, strSavePath, 0, 0)
If Ret = 0 Then
MsgBox "Download has been succeed!"
Else
MsgBox "Error"
End If
End Sub
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
Sub DownloadFileFromWeb()
Dim myFile As String
Dim buf, Ret As Long
Dim strSavePath As String
Dim URL As String, ext As String
URL = "http://www.ahma.org/Education/BRD_Hardlines_Industry_Item.doc"
buf = Split(URL, ".")
ext = buf(UBound(buf))
strSavePath = "C:\local files\DownloadedFile." & ext
Debug.Print strSavePath
Ret = URLDownloadToFile(0, URL, strSavePath, 0, 0)
If Ret = 0 Then
MsgBox "Download OK!"
Else
MsgBox "Error"
End If
End Sub