Related
I need to download a CSV file from a website using VBA in Excel. The server also needed to authenticate me since it was data from a survey service.
I found a lot of examples using Internet Explorer controlled with VBA for this. However, it was mostly slow solutions and most were also convoluted.
Update:
After a while I found a nifty solution using Microsoft.XMLHTTP object in Excel. I thought to share the solution below for future reference.
This solution is based from this website:
http://social.msdn.microsoft.com/Forums/en-US/bd0ee306-7bb5-4ce4-8341-edd9475f84ad/excel-2007-use-vba-to-download-save-csv-from-url
It is slightly modified to overwrite existing file and to pass along login credentials.
Sub DownloadFile()
Dim myURL As String
myURL = "https://YourWebSite.com/?your_query_parameters"
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:\file.csv", 2 ' 1 = no overwrite, 2 = overwrite
oStream.Close
End If
End Sub
Declare PtrSafe 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 Example()
DownloadFile$ = "someFile.ext" 'here the name with extension
URL$ = "http://some.web.address/" & DownloadFile 'Here is the web address
LocalFilename$ = "C:\Some\Path" & DownloadFile !OR! CurrentProject.Path & "\" & DownloadFile 'here the drive and download directory
MsgBox "Download Status : " & URLDownloadToFile(0, URL, LocalFilename, 0, 0) = 0
End Sub
Source
I found the above when looking for downloading from FTP with username and address in URL. Users supply information and then make the calls.
This was helpful because our organization has Kaspersky AV which blocks active FTP.exe, but not web connections. We were unable to develop in house with ftp.exe and this was our solution. Hope this helps other looking for info!
A modified version of above to make it more dynamic.
Public Function DownloadFileB(ByVal URL As String, ByVal DownloadPath As String, ByRef Username As String, ByRef Password, Optional Overwrite As Boolean = True) As Boolean
On Error GoTo Failed
Dim WinHttpReq As Object: Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", URL, False, Username, Password
WinHttpReq.send
If WinHttpReq.Status = 200 Then
Dim oStream As Object: Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.SaveToFile DownloadPath, Abs(CInt(Overwrite)) + 1
oStream.Close
DownloadFileB = Len(Dir(DownloadPath)) > 0
Exit Function
End If
Failed:
DownloadFileB = False
End Function
I was struggling for hours on this until I figured out it can be done in one line of powershell:
invoke-webrequest -Uri "http://myserver/Reports/Pages/ReportViewer.aspx?%2fClients%2ftest&rs:Format=PDF&rs:ClearSession=true&CaseCode=12345678" -OutFile "C:\Temp\test.pdf" -UseDefaultCredentials
I looked into doing it purely in VBA but it runs to several pages, so I just call my powershell script from VBA every time I want to download a file.
Simple.
Public Sub Test_DownloadFile()
Dim URLStr As String, DLPath As String, UName As String, PWD As String, DontOverWrite As Boolean
URLStr = "http.."
DLPath = Environ("USERPROFILE") & "\Downloads\TEST.PDF"
UName = ""
PWD = ""
DontOverWrite = False
Call DownloadFile(URLStr, DLPath, UName, PWD, DontOverWrite)
End Sub
Public Sub DownloadFile(ByVal URLStr As String, ByVal DLPath As String, Optional ByVal UName As String, Optional ByVal PWD As String, Optional DontOverWrite As Boolean)
On Error GoTo Failed
Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", URLStr, False, UName, PWD
WinHttpReq.send
If WinHttpReq.status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
Dim OWrite As Integer
If DontOverWrite = True Then
OWrite = 1
Else
OWrite = 2
End If
oStream.SaveToFile DLPath, OWrite
oStream.Close
Debug.Print "Downloaded " & URLStr & " To " & DLPath
Exit Sub
End If
Failed:
Debug.Print "Failed to DL " & URLStr
End Sub
A modified version of above solution to make it more dynamic.
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
Public Function DownloadFileA(ByVal URL As String, ByVal DownloadPath As String) As Boolean
On Error GoTo Failed
DownloadFileA = False
'As directory must exist, this is a check
If CreateObject("Scripting.FileSystemObject").FolderExists(CreateObject("Scripting.FileSystemObject").GetParentFolderName(DownloadPath)) = False Then Exit Function
Dim returnValue As Long
returnValue = URLDownloadToFile(0, URL, DownloadPath, 0, 0)
'If return value is 0 and the file exist, then it is considered as downloaded correctly
DownloadFileA = (returnValue = 0) And (Len(Dir(DownloadPath)) > 0)
Exit Function
Failed:
End Function
here is wininet.dll declare functions:
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
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
Private Declare Sub FtpCreateDirectory Lib "wininet.dll" _
Alias "FtpCreateDirectoryA" _
(ByVal hConnect As Long, _
ByVal lpszDirectory As String)
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" _
(ByVal hConnect As Long, _
ByVal lpszDirectory As String) As Boolean
this is my code:
If FtpSetCurrentDirectory(hConnect, sDir) = False Then
j = CountOccurrences(sDir, "/")
Debug.Print "dir = " & sDir
Debug.Print "j = " & j
For i = 1 To j
If i = 1 Then
intOccChar = InStr(1, sDir, "/")
Else
intOccChar = InStr(intOccChar + 1, sDir, "/")
End If
Debug.Print "for i=" & i & " intOccChar = " & intOccChar
Debug.Print Left(sDir, intOccChar)
Debug.Print FtpSetCurrentDirectory(hConnect, Left(sDir,(intOccChar)))
If FtpSetCurrentDirectory(hConnect, Left(sDir, (intOccChar))) = False Then
Call FtpCreateDirectory(hConnect, Left(sDir, (intOccChar)))
End If
Next
End If
Call FtpSetCurrentDirectory(hConnect, sDir)
problem is: when there is no directory on ftp server, code works well but when first directory exist then sub directory not created
This is Immediate windows output:
dir = AkhzaBank/80/2/Credit/
j = 4
for i=1 intOccChar = 10
AkhzaBank/
False
for i=2 intOccChar = 13
AkhzaBank/80/
False
for i=3 intOccChar = 15
AkhzaBank/80/2/
False
for i=4 intOccChar = 22
AkhzaBank/80/2/Credit/
False
note: the code works with ftp upload and download, the only problem is create directory on ftp server
Thanks in advance
update!!!!!!!!!!!!!!
I find a solution form my question
i don't know why, but somehow this line
If FtpSetCurrentDirectory(hConnect, Left(sDir, (intOccChar))) = False Then
prevents create directory in subfolder. i simply delete this line and code works.
true solution
My mistake is in these lines:
Private Declare Sub FtpCreateDirectory Lib "wininet.dll" _
Alias "FtpCreateDirectoryA" _
(ByVal hConnect As Long, _
ByVal lpszDirectory As String)
i must Declare FtpCreateDirectory as Boolean Function not as Sub! so the true declare function is:
Private Declare Function FtpCreateDirectory Lib "wininet.dll" _
Alias "FtpCreateDirectoryA" _
(ByVal hConnect As Long, _
ByVal lpszDirectory As String) As Boolean
I try to open a form in another database by using GetObject. Unfortunately I have to open a second instance of the database, but I would like to use the active instance of that database instead (if loaded). TO accomplish this I need to set an object reference to the running instance of that db.
What I currently use is the function below. This function first tries to activate the running instance of the database using its screen name, and if this generates an error the database and the form are loaded. However, if the database is already loaded I want to be able to load the form as well.
On lesser problem is if the error procedure to load the db and form generates an error, the error routine is not followed. How should I manage that?
Anyone has an idea?
I'm Using Access 2016
Thx.
Peter
Public Function AppDbOpen(strAppExec As String, strAppName As String, strOpenForm As String) As Boolean
On Error GoTo Err_Proc
Dim objDb As Object
'Activate DB if open
AppActivate strAppName
AppDbOpen = True
Exit_Err_Proc:
Set objDb = Nothing
Exit Function
Err_Proc:
Select Case Err.Number
Case 5 'Open Db if not open
Set objDb = GetObject(strAppExec, "Access.Application")
If Nz(strOpenForm, "") <> "" Then
objDb.DoCmd.OpenForm strOpenForm
End If
AppDbOpen = True
Case Else
MsgBox "Error: " & Trim(Str(Err.Number)) & vbCrLf & _
"Desc: " & Err.description & vbCrLf & vbCrLf & _
"Module: Mod_GeneralFunctions" & vbCrLf & _
"Function: AppDbOpen", _
vbCritical, "Error!"
End Select
Resume Exit_Err_Proc
End Function
This is not an easy task, but it can be accomplished by using some WinAPI window functions.
Essentially, you want to get an Access Application object by using the window title.
I'm going to assume you haven't got any unicode characters in that window title, else, we'll need something a little more complex.
First, declare our WinAPI functions:
Declare PtrSafe Function FindWindowExA Lib "user32" (Optional ByVal hWndParent As LongPtr, Optional ByVal hwndChildAfter As LongPtr, Optional ByVal lpszClass As String, Optional ByVal lpszWindow As String) As LongPtr
Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As LongPtr, ByVal dwId As Long, riid As Any, ppvObject As Object) As Long
FindWindowExA is used to find the window with the specified title. AccessibleObjectFromWindow is used to get the COM object of that window.
Then, we declare some constants to be used for AccessibleObjectFromWindow:
Const strIID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}" 'To identify the IDISPATCH COM interface
Const OBJID_NATIVEOM As Long = &HFFFFFFF0 'To identify the object type
Then, we can write the function
Public Function AppDbOpen(strAppExec As String, strAppName As String, strOpenForm As String) As Boolean
On Error GoTo Err_Proc
Dim objDb As Object
'Activate DB if open
AppActivate strAppName
AppDbOpen = True
Dim hwndAppDb As LongPtr
hwndAppDb = FindWindowExA (,,,strAppName) 'Find the window handle (hWnd)
If hwndAppDb <> 0 Then 'If it's 0, something went wrong, check the title
Dim guid() As Byte
guid = Application.GuidFromString(strIID_IDispatch)
'Get the IDispatch object associated with that handle
AccessibleObjectFromWindow hwndAppDb, OBJID_NATIVEOM, guid(0), objDb
End If
If Nz(strOpenForm, "") <> "" Then
objDb.DoCmd.OpenForm strOpenForm
End If
Exit_Err_Proc:
Set objDb = Nothing
Exit Function
Err_Proc:
Select Case Err.Number
Case 5 'Open Db if not open
Set objDb = GetObject(strAppExec, "Access.Application")
If Nz(strOpenForm, "") <> "" Then
objDb.DoCmd.OpenForm strOpenForm
End If
AppDbOpen = True
Case Else
MsgBox "Error: " & Trim(Str(Err.Number)) & vbCrLf & _
"Desc: " & Err.description & vbCrLf & vbCrLf & _
"Module: Mod_GeneralFunctions" & vbCrLf & _
"Function: AppDbOpen", _
vbCritical, "Error!"
End Select
Resume Exit_Err_Proc
End Function
I'm not going to discuss the point of chained error handlers, but you can just review this answer for that. Note that resetting the error handler resets the Err object as well, so you might first want to store error number and description if you want to use that.
This worked like a charm, thank you so much! I never figured this out by myself.
It seems that after an adjustment of the code there is no issue related to the nested errors too. I needed to add a maximize call because mu forms are showed related to the screen and this causes an invisible form when the other database was minimized. The final code is now
Option Compare Database
Option Explicit
Declare PtrSafe Function FindWindowExA Lib "user32" (Optional ByVal hWndParent As LongPtr, _
Optional ByVal hwndChildAfter As LongPtr, Optional ByVal lpszClass As String, _
Optional ByVal lpszWindow As String) As LongPtr
Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As LongPtr, _
ByVal dwId As Long, riid As Any, ppvObject As Object) As Long
Const strIID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}" 'To identify the IDISPATCH COM interface
Const OBJID_NATIVEOM = &HFFFFFFF0 'To identify the object type
Public Function AppDbOpen(strAppExec As String, strAppName As String, strOpenForm As String) As Boolean
On Error GoTo Err_Proc
Dim objDb As Object
Dim hwndAppDb As LongPtr
'Find the Db handle
hwndAppDb = FindWindowExA(, , , strAppName) 'Find the window handle (hWnd)
If hwndAppDb <> 0 Then 'If it's 0, something went wrong, check the title
'Activate DB if open
Dim guid() As Byte
guid = Application.GUIDFromString(strIID_IDispatch)
'Get the IDispatch object associated with that handle
AccessibleObjectFromWindow hwndAppDb, OBJID_NATIVEOM, guid(0), objDb
Else
'Open Db if not open
Set objDb = GetObject(strAppExec, "Access.Application")
End If
If Nz(strOpenForm, "") <> "" Then
objDb.RunCommand acCmdAppMaximize
objDb.DoCmd.OpenForm strOpenForm
objDb.Run "CenterForm", strOpenForm, False, False, False, 0
End If
AppDbOpen = True
Exit_Err_Proc:
Set objDb = Nothing
Exit Function
Err_Proc:
Select Case Err.Number
Case Else
MsgBox "Error: " & Trim(Str(Err.Number)) & vbCrLf & _
"Desc: " & Err.description & vbCrLf & vbCrLf & _
"Module: Mod_OpenExtDb" & vbCrLf & _
"Function: AppDbOpen", _
vbCritical, "Error!"
End Select
Resume Exit_Err_Proc
End Function
Again, thank you!
Peter
I am investigating some software written by a programmer before I came on-board at the company I work for.
They have some VBA code (in MS Access) that copies some files, writes to tables, etc., and somewhere in this process it is hanging up. It doesn't return any error codes or messages (in the error handler or in any other way). It just hangs up and Access goes into the "Not Responding" mode until it is forcibly stopped.
Here is the VBA code which handles the "Export" button (which is where it hangs):
Public Sub cmd_export_Click()
Dim ws As New WshShell, clsF As New clsNewFile, aspChemInv As MyCstmFile, _
fso As New IWshRuntimeLibrary.FileSystemObject, strFileName As String, _
fld As IWshRuntimeLibrary.Folder, fi As File
strFileName = Split(Field0.Value, ",")(0) & "_cheminv"
On Error GoTo Err_handler
Dim TblDeltree As String
Dim strArrTmpName
strArrTmpName = Split(Forms![MAIN MENU]![Field0], ", ")
TableName = strArrTmpName(0) & ", " & strArrTmpName(1)
If IsNull(Forms![MAIN MENU]![Field0]) = False Then
i = 0
Digits = Left(TableName, InStr(1, TableName, ",") - 1)
ShtDigits = Left(Digits, 2)
DoCmd.TransferDatabase acExport, "Microsoft Access", _
"\\A02-ds1\Public\Clients\" & ShtDigits & "\" & Digits & _
"\client.mdb", acTable, Forms![MAIN MENU]![Field0], TableName
'Scott request change (see email To: Ros Vicente Wed 4/16/2014 9:26 AM)
'Data Calculations
'TIER II CANDIDATES
'Revert changes per verbal (Scott Vaughn) 5/6/2014 10:09 AM
DoCmd.TransferDatabase acExport, "Microsoft Access", _
"\\A02-ds1\Public\Clients\" & ShtDigits & "\" & Digits & _
"\client.mdb", acTable, "Data Calculations", "Data Calculations"
DoCmd.TransferDatabase acExport, "Microsoft Access", _
"\\A02-ds1\Public\Clients\" & ShtDigits & "\" & Digits & _
"\client.mdb", acTable, "TIER II CANDIDATES", "TIER II CANDIDATES"
DoCmd.OpenReport "TIER II CANDIDATES", acViewPreview
Set rpt = Application.Reports![TIER II CANDIDATES]
Dim strReportsPath As String
strReportsPath = "\\A02-DS1\Public\Clients\" & ShtDigits & "\" & Digits & "\"
'ScreenShot rpt
DoCmd.OutputTo acOutputReport, Report, acFormatSNP, strReportsPath & rpt.Name & ".SNP", 0
DoCmd.Close acReport, rpt.Name
'DoCmd.OpenReport "Product Quantity List", acViewPreview
'Set rpt = Application.Reports![Product Quantity List]
modPDFCreator.RunReportAsPDF "Product Quantity List", strReportsPath & Digits & "_PQL.pdf"
Else
MsgBox "Please select the client table below.", vbExclamation, "Status: Export"
End If
If Not fso.FolderExists("C:\Temp") Then fso.CreateFolder ("C:\Temp")
ws.CurrentDirectory = "C:\Temp"
If Not fso.FolderExists(ws.CurrentDirectory & "\ESD_Upload") Then fso.CreateFolder ws.CurrentDirectory & "\ESD_Upload"
ws.CurrentDirectory = ws.CurrentDirectory & "\ESD_Upload"
Dim xFile As MyCstmFile
Set fld = fso.GetFolder("\\a02-ds1\Env-Sci\AutoCAD Files\Publish")
Dim strCurrentFile As String
For Each fi In fld.Files
strCurrentFile = fi.Name
fso.MoveFile fi.Path, ws.CurrentDirectory & "\" & strCurrentFile
Next
Dim tmpMSDS As New clsChemicalInventory
fso.CopyFile "\\a02-ds1\applicationDatabase$\MSDS.mdb", ws.CurrentDirectory & "\" & fGetUserName _
& ".mdb", True
tmpMSDS.CreateMSDS Digits, ws.CurrentDirectory & "\" & fGetUserName & ".mdb"
Set fld = fso.GetFolder(ws.CurrentDirectory)
For Each fi In fld.Files
If InStr(1, fi.Name, ".txt") = 0 And InStr(1, fi.Name, ".mdb") = 0 Then _
fso.CopyFile fi.Name, "\\a02-ds1\Vanguard Website\OHMMP\Clients\", True
If InStr(1, fi.Name, "layout.pdf") <> 0 Then _
fso.CopyFile fi.Name, "\\A02-DS1\public\Clients\Layouts\", True: _
fso.CopyFile fi.Name, "\\A01-DC1\clients$\", True
If InStr(1, fi.Name, "_msds_") <> 0 Then _
fso.CopyFile fi.Name, "\\A01-DC1\clients$\", True
Next
ws.CurrentDirectory = "C:\Temp"
fso.DeleteFolder ws.CurrentDirectory & "\ESD_Upload"
Set fso = Nothing
Set fld = Nothing
Set ws = Nothing
MsgBox "Export Completed"
Exit_Handler:
Exit Sub
Err_handler:
If Err.Number = 70 Then
MsgBox "File " & strCurrentFile & " is Open.", vbOKOnly, "Open File"
Else
MsgBox "An Error as occured while trying to complete this task." _
& vbCrLf & "Please report the following error to your IT department: " _
& vbCrLf & Err.Number & ":" & vbCrLf & Err.Description, vbCritical, "Error"
End If
'Resume
Resume Exit_Handler
End Sub
Unfortunately I haven't had too much experience with VB (I've used mostly SQL in the past) and while I've been researching the functions, and all, I can't seem to find a way to figure out where or why this is hanging up in the way that it is.
Is there any way to tell what's going on here or, perhaps, where I should look or what I can do to find out?
Edit
Also, I am using Adobe Acrobat 9.0.0 (just freshly installed from DVD).
New Things Found
I've realized there are 3 separate issues going on here, but not sure yet how to fix them.
1) I get an Error 58 (File already exists on the following line:
fso.MoveFile fi.Path, ws.CurrentDirectory & "\" & strCurrentFile
This is completely understandable since the MoveFile function in VB doesn't support the overwriting of files. Not sure who wrote that, but they overlooked a major flaw there. I plan on using CopyFile and then deleting the source when done to solve this one, so no problems here.
2) I am getting an error 3043 (Disk or Network Error) on the following line (which #Time Williams asked about in the comments below [I'm still investigating what's going on there, but I don't know where to find the location of self-built global functions]):
tmpMSDS.CreateMSDS Digits, ws.CurrentDirectory & "\" & fGetUserName & ".mdb"
3) And THIS is where the program hangs:
modPDFCreator.RunReportAsPDF "Product Quantity List", strReportsPath & Digits & "_PQL.pdf"
This is still a complete puzzle to me, because I've never used any method like this before, in any language.
Even More Stuff Found
modPDFCreator:
' The function to call is RunReportAsPDF
'
' It requires 2 parameters: the Access Report to run
' the PDF file name
'
' Enjoy!
'
' Eric Provencher
'===========================================================
Option Compare Database
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" (dest As Any, _
source As Any, _
ByVal numBytes As Long)
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _
Alias "RegOpenKeyExA" (ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" _
Alias "RegCreateKeyExA" (ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal Reserved As Long, _
ByVal lpClass As String, _
ByVal dwOptions As Long, _
ByVal samDesired As Long, _
ByVal lpSecurityAttributes As Long, _
phkResult As Long, _
lpdwDisposition As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" _
Alias "RegQueryValueExA" (ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal lpReserved As Long, _
lpType As Long, _
lpData As Any, _
lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" _
Alias "RegSetValueExA" (ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
lpData As Any, _
ByVal cbData As Long) As Long
Private Declare Function apiFindExecutable Lib "shell32.dll" _
Alias "FindExecutableA" (ByVal lpFile As String, _
ByVal lpDirectory As String, _
ByVal lpResult As String) As Long
Const REG_SZ = 1
Const REG_EXPAND_SZ = 2
Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_MULTI_SZ = 7
Const ERROR_MORE_DATA = 234
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Const KEY_READ = &H20019 ' ((READ_CONTROL Or KEY_QUERY_VALUE Or
' KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not
' SYNCHRONIZE))
Const KEY_WRITE = &H20006 '((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or
' KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
Public Function RunReportAsPDF(prmRptName As String, _
prmPdfName As String) As Boolean
' Returns TRUE if a PDF file has been created
Dim AdobeDevice As String
Dim strDefaultPrinter As String
'Find the Acrobat PDF device
AdobeDevice = GetRegistryValue(HKEY_CURRENT_USER, _
"Software\Microsoft\WIndows NT\CurrentVersion\Devices", _
"Adobe PDF")
If AdobeDevice = "" Then ' The device was not found
MsgBox "You must install Acrobat Writer before using this feature"
RunReportAsPDF = False
Exit Function
End If
' get current default printer.
strDefaultPrinter = Application.Printer.DeviceName
Set Application.Printer = Application.Printers("Adobe PDF")
'Create the Registry Key where Acrobat looks for a file name
CreateNewRegistryKey HKEY_CURRENT_USER, _
"Software\Adobe\Acrobat Distiller\PrinterJobControl"
'Put the output filename where Acrobat could find it
'SetRegistryValue HKEY_CURRENT_USER, _
"Software\Adobe\Acrobat Distiller\PrinterJobControl", _
Find_Exe_Name(CurrentDb.Name, CurrentDb.Name), _
prmPdfName
Dim oShell As Object
Dim strRegKey As String
Set oShell = CreateObject("WScript.Shell")
On Error GoTo ErrorHandler
' strRegKey = oShell.RegRead("HKEY_CURRENT_USER\Software\Adobe\Acrobat Distiller\10.0\AdobePDFOutputFolder\1")
' If Err.Number = -2147024893 Then
' ' Code for if the key doesn't exist
' MsgBox "The key does not exist"
' Else
' ' Code for if the key does exist
' MsgBox "The key exists"
' End If
Dim strRegPath As String
strRegPath = "Software\Adobe\Acrobat Distiller\9.0\AdobePDFOutputFolder"
1:
SetRegistryValue HKEY_CURRENT_USER, strRegPath, "2", Left(prmPdfName, InStrRev(prmPdfName, "\") - 1)
ErrorHandler:
If Err.Number <> 0 Then strRegPath = "Software\Adobe\Acrobat Distiller\10.0\AdobePDFOutputFolder": Err.Clear: Resume 1
On Error GoTo Err_handler
Dim strReportName As String
strReportName = Left(Right(prmPdfName, Len(prmPdfName) - InStrRev(prmPdfName, "\")), _
Len(Right(prmPdfName, Len(prmPdfName) - InStrRev(prmPdfName, "\"))) - 4)
DoCmd.CopyObject , strReportName, acReport, prmRptName
DoCmd.OpenReport strReportName, acViewNormal 'Run the report
DoCmd.DeleteObject acReport, strReportName
' While Len(Dir(prmPdfName)) = 0 ' Wait for the PDF to actually exist
' DoEvents
' Wend
RunReportAsPDF = True ' Mission accomplished!
Normal_Exit:
Set Application.Printer = Application.Printers(strDefaultPrinter) ' Restore default printer
On Error GoTo 0
Exit Function
Err_handler:
If Err.Number = 2501 Then ' The report did not run properly (ex NO DATA)
RunReportAsPDF = False
Resume Normal_Exit
Else
RunReportAsPDF = False ' The report did not run properly (anything else!)
MsgBox "Unexpected error #" & Err.Number & " - " & Err.Description
Resume Normal_Exit
End If
End Function
Public Function Find_Exe_Name(prmFile As String, _
prmDir As String) As String
Dim Return_Code As Long
Dim Return_Value As String
Return_Value = Space(260)
Return_Code = apiFindExecutable(prmFile, prmDir, Return_Value)
If Return_Code > 32 Then
Find_Exe_Name = Return_Value
Else
Find_Exe_Name = "Error: File Not Found"
End If
End Function
Public Sub CreateNewRegistryKey(prmPredefKey As Long, _
prmNewKey As String)
' Example #1: CreateNewRegistryKey HKEY_CURRENT_USER, "TestKey"
'
' Create a key called TestKey immediately under HKEY_CURRENT_USER.
'
' Example #2: CreateNewRegistryKey HKEY_LOCAL_MACHINE, "TestKey\SubKey1\SubKey2"
'
' Creates three-nested keys beginning with TestKey immediately under
' HKEY_LOCAL_MACHINE, SubKey1 subordinate to TestKey, and SubKey3 under SubKey2.
'
Dim hNewKey As Long 'handle to the new key
Dim lRetVal As Long 'result of the RegCreateKeyEx function
lRetVal = RegOpenKeyEx(prmPredefKey, prmNewKey, 0, KEY_ALL_ACCESS, hKey)
If lRetVal <> 5 Then
lRetVal = RegCreateKeyEx(prmPredefKey, prmNewKey, 0&, _
vbNullString, REG_OPTION_NON_VOLATILE, _
KEY_ALL_ACCESS, 0&, hNewKey, lRetVal)
End If
RegCloseKey (hNewKey)
End Sub
Function GetRegistryValue(ByVal hKey As Long, _
ByVal KeyName As String, _
ByVal ValueName As String, _
Optional DefaultValue As Variant) As Variant
Dim handle As Long
Dim resLong As Long
Dim resString As String
Dim resBinary() As Byte
Dim length As Long
Dim retVal As Long
Dim valueType As Long
' Read a Registry value
'
' Use KeyName = "" for the default value
' If the value isn't there, it returns the DefaultValue
' argument, or Empty if the argument has been omitted
'
' Supports DWORD, REG_SZ, REG_EXPAND_SZ, REG_BINARY and REG_MULTI_SZ
' REG_MULTI_SZ values are returned as a null-delimited stream of strings
' (VB6 users can use SPlit to convert to an array of string)
' Prepare the default result
GetRegistryValue = IIf(IsMissing(DefaultValue), Empty, DefaultValue)
' Open the key, exit if not found.
If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then
Exit Function
End If
' prepare a 1K receiving resBinary
length = 1024
ReDim resBinary(0 To length - 1) As Byte
' read the registry key
retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), length)
' if resBinary was too small, try again
If retVal = ERROR_MORE_DATA Then
' enlarge the resBinary, and read the value again
ReDim resBinary(0 To length - 1) As Byte
retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), _
length)
End If
' return a value corresponding to the value type
Select Case valueType
Case REG_DWORD
CopyMemory resLong, resBinary(0), 4
GetRegistryValue = resLong
Case REG_SZ, REG_EXPAND_SZ
' copy everything but the trailing null char
resString = Space$(length - 1)
CopyMemory ByVal resString, resBinary(0), length - 1
GetRegistryValue = resString
Case REG_BINARY
' resize the result resBinary
If length <> UBound(resBinary) + 1 Then
ReDim Preserve resBinary(0 To length - 1) As Byte
End If
GetRegistryValue = resBinary()
Case REG_MULTI_SZ
' copy everything but the 2 trailing null chars
resString = Space$(length - 2)
CopyMemory ByVal resString, resBinary(0), length - 2
GetRegistryValue = resString
Case Else
GetRegistryValue = ""
' RegCloseKey handle
' Err.Raise 1001, , "Unsupported value type"
End Select
RegCloseKey handle ' close the registry key
End Function
Function SetRegistryValue(ByVal hKey As Long, _
ByVal KeyName As String, _
ByVal ValueName As String, _
Value As Variant) As Boolean
' Write or Create a Registry value
' returns True if successful
'
' Use KeyName = "" for the default value
'
' Value can be an integer value (REG_DWORD), a string (REG_SZ)
' or an array of binary (REG_BINARY). Raises an error otherwise.
Dim handle As Long
Dim lngValue As Long
Dim strValue As String
Dim binValue() As Byte
Dim byteValue As Byte
Dim length As Long
Dim retVal As Long
' Open the key, exit if not found
If RegOpenKeyEx(hKey, KeyName, 0, KEY_WRITE, handle) Then
Err.Raise 1
Exit Function
End If
' three cases, according to the data type in Value
Select Case VarType(Value)
Case vbInteger, vbLong
lngValue = Value
retVal = RegSetValueEx(handle, ValueName, 0, REG_DWORD, lngValue, 4)
Case vbString
strValue = Value
retVal = RegSetValueEx(handle, ValueName, 0, REG_SZ, ByVal strValue, Len(strValue))
Case vbArray
binValue = Value
length = UBound(binValue) - LBound(binValue) + 1
retVal = RegSetValueEx(handle, ValueName, 0, REG_BINARY, binValue(LBound(binValue)), length)
Case vbByte
byteValue = Value
length = 1
retVal = RegSetValueEx(handle, ValueName, 0, REG_BINARY, byteValue, length)
Case Else
RegCloseKey handle
Err.Raise 1001, , "Unsupported value type"
End Select
RegCloseKey handle ' Close the key and signal success
SetRegistryValue = (retVal = 0) ' signal success if the value was written correctly
End Function
To try and debug, make the changes mentioned below, then run your test. If the error message indicates the 'line number' is 123, then that error needs to be resolved to fix the issue. If there is no line # indicated, the error is elsewhere and can be fixed. We need to know the error number and description.
Please try the following:
Replace the following lines of code in Function RunReportAsPDF
SetRegistryValue HKEY_CURRENT_USER, ......
ErrorHandler:....
If Err.Number <> 0 Then strRegPath = ....
On Error GoTo Err_handler
With the following:
' Make sure the 123 (line number below) starts in the first column
123 SetRegistryValue HKEY_CURRENT_USER, strRegPath, "2", Left(prmPdfName, InStrRev(prmPdfName, "\") - 1)
Exit Function
ErrorHandler:
' Display the Error info, plus Line number
Msgbox "Error = & Err.Number & vbtab & Err.Description & vbcrlf & "At Line: " & Erl
If Err.Number <> 0 Then strRegPath = "Software\Adobe\Acrobat Distiller\10.0\AdobePDFOutputFolder": Err.Clear: Resume 1
On Error GoTo Err_handler
This question already has answers here:
Closed 10 years ago.
Possible Duplicate:
GET pictures from a url and then rename the picture
I have over 30+ files links I need to download.
Is there a way to do this excel?
I want to do in excel because to get those 30+ links I have to do some clean ups which I do in excel.
I need to do this every day. if there is way to do in excel would be awesome.
For example, if A2 is image then download this image into folder
https://www.google.com/images/srpr/logo3w.png
if there is way to rename logo3w.png to whatever is in B2 that would be even more awesome so I won't have to rename file.
Script below, I found online, It works but I need help with rename it.
In column A2:down I have all links
In column B2:down I have filename with extension
Const TargetFolder = "C:\Temp\"
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 Test()
For Each Hyperlink In ActiveSheet.Hyperlinks
For N = Len(Hyperlink.Address) To 1 Step -1
If Mid(Hyperlink.Address, N, 1) <> "/" Then
LocalFileName = Mid(Hyperlink.Address, N, 1) & LocalFileName
Else
Exit For
End If
Next N
Call HTTPDownloadFile(Hyperlink.Address, TargetFolder & LocalFileName)
Next Hyperlink
End Sub
Sub HTTPDownloadFile(ByVal URL As String, ByVal LocalFileName As String)
Dim Res As Long
On Error Resume Next
Kill LocalFileName
On Error GoTo 0
Res = URLDownloadToFile(0&, URL, LocalFileName, 0&, 0&)
End Sub
I'm pretty sure you'll be able to slightly modify the following code to satisfy your needs:
Sub DownloadCSV()
Dim myURL As String
myURL = "http://pic.dhe.ibm.com/infocenter/tivihelp/v41r1/topic/com.ibm.ismsaas.doc/reference/LicenseImportSample.csv"
Dim WinHTTPReq As Object
Set WinHTTPReq = CreateObject("Microsoft.XMLHTTP")
Call WinHTTPReq.Open("GET", myURL, False)
WinHTTPReq.send
If WinHTTPReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHTTPReq.responseBody
oStream.SaveToFile ("D:\DOCUMENTS\timelog.csv")
oStream.Close
End If
End Sub
Good luck!
This should work for you. It will download and rename with the filename that is in column B. I just replaced the 2nd for loop with a line. Hyperlink.range.row gives the row number in which the hyperlink is present. So cells(hyperlink.range.row,2) evaluates to cells(1,2), cells(2,2) and so on (if the data is in A1, A2, A3..). Assuming that you have filename with extension (ex - xyz.png) in column B, this should work.
Const TargetFolder = "C:\Temp\"
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 Test()
For Each Hyperlink In ActiveSheet.Hyperlinks
LocalFileName=ActiveSheet.cells(hyperlink.Range.Row,2).value
Call HTTPDownloadFile(Hyperlink.Address, TargetFolder & LocalFileName)
Next Hyperlink
End Sub
Sub HTTPDownloadFile(ByVal URL As String, ByVal LocalFileName As String)
Dim Res As Long
On Error Resume Next
Kill LocalFileName
On Error GoTo 0
Res = URLDownloadToFile(0&, URL, LocalFileName, 0&, 0&)
End Sub
Let me know if this helps.