Save an Excel file as PDF to a specific path - excel

I would like to save an Excel file as a .pdf file to a specific location and then send the file in a mail.
I'm using Office 2000 :|
This is my code so far:
Application.ActivePrinter = "PDF995 on Ne00:"
ActiveSheet.PageSetup.PrintArea = Range("A68").Value
ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:= _
"PDF995 on Ne00:", Collate:=True
Set WB = ActiveWorkbook
Set oApp = CreateObject("Outlook.Application")
Set omail = oApp.Createitem(0)
With omail
.To = Range("B61").Value
.Subject = "Approved"
.Body
.Display
Rows("81:134").Select
Selection.EntireRow.Hidden = True
End With
I can easily save the file and mail it, but I can't save it to a specific location.
I need to be able to specificy a path like "C:\path\file.pdf".

If you have the file saved to fixed location but you're unable to choose where, as a last resort you could always use fso's MoveFile to move it to your specified location
eg. If the file is always saved as "C:\temp\file1.pdf", and you want it on desktop
'Initialise first'
set fso = CreateObject("Scripting.FileSystemObject")
...
'After procedure'
desired_destination = "c:\windows\desktop\"
target_file = "C:\temp\file1.pdf"
fso.MoveFile target_file, desired_destination
If you want to check for an existing file conflict (I believe fso's Move doesn't allow for overwrite), use CopyFile with over-write switched on then Delete the source file if necessary
If you'd like to use a file dialog to choose the destination, you can use the UserAccounts.CommonDialog object (although that doesn't work with Vista) or SAFRCFileDlg.FileOpen (pretty much only works on XP) or borrow an IE prompted box. (Unfortunately the options aren't all that great with VBS to my knowledge)
Check them out here: http://www.robvanderwoude.com/vbstech_ui_fileopen.php

It's a little complicated, as you have to set registry keys.
Assuming that you have a full version of Adobe Acrobat that has installed the initial registry keys:
First, you have the registry accessing functions, which you put in a non-sheet module:
Private Const HKEY_CURRENT_USER As Long = &H80000001
Private Const HKCU = HKEY_CURRENT_USER
Private Const KEY_SET_VALUE = &H2&
Private Const REG_SZ = 1
Private Declare Function RegOpenKeyEx Lib "advapi32" _
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 RegSetValueExA Lib "ADVAPI32.DLL" _
(ByVal hKey As Long, _
ByVal sValueName As String, _
ByVal dwReserved As Long, _
ByVal dwType As Long, _
ByVal sValue As String, _
ByVal dwSize As Long) As Long
Private Declare Function RegCloseKey Lib "ADVAPI32.DLL" ( _
ByVal hKey As Long) As Long
Then, you use the following code to set the registry key that tells Adobe where to save the file. Note, it has to be set everytime you print.
Dim RegResult As Long, Result As Long
RegResult = RegOpenKeyEx(HKCU, "Software\Adobe\Acrobat Distiller\PrinterJobControl", _
0&, KEY_SET_VALUE, Result)
RegResult = RegSetValueExA(Result, "C:\Windows\splwow64.exe", 0&, REG_SZ, _
FileName, Len(FileName))
RegResult = RegCloseKey(Result)
Also Note, the "C:\Windows\splwow64.exe" is what I needed for my Excel 2010 32-bit, and it may be different for you. To determine it (which won't change) first print manually to PDF, then go to the registry key and see what application is used in the HKCU\Software\Adobe\Acrobat Distiller\PrinterJobControl LastPDFPortFolder key. Then use the name of the full application path for that executable.

Try this:
sName = "C:\path\file.pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sName

Related

Download file from url in Excel 2019 (it works on Excel 2007)

I got a code to download a CSV file from a website that requires credentials. I got a code thanks to this website and I could adapted to my needs. My relevant part of code is:
Option Explicit
Private Declare Function URLDownloadToFileA Lib "urlmon" _
(ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
Private Function DownloadUrlFile(URL As String, LocalFilename As String) As Boolean
Dim RetVal As Long
RetVal = URLDownloadToFileA(0, URL, LocalFilename, 0, 0)
If RetVal = 0 Then DownloadUrlFile = True
End Function
Sub DESCARGAR_CSV_DATOS()
Dim EstaURL As String
Dim EsteCSV As String
EstaURL = "https://user:token#www.privatewebsite.com/export/targetfile.csv"
EsteCSV = "MyCSV " & Format(Date, "dd-mm-yyyy") & ".csv"
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
DownloadUrlFile EstaURL, _
ThisWorkbook.Path & "\" & EsteCSV
DoEvents
Workbooks.Open ThisWorkbook.Path & "\" & EsteCSV, , True, , , , , , , , , , , True
'rest is just doing operations and calculations inside workbook
End Sub
Sorry but I cannot provide the real url. Anyways, this code has been working perfectly since September 2019. And it still works perfectly every day.
The computers that execute this code are all of them Windows 7 and Excel 2007 and 64 bits. None of them fail.
But now, this task is going to be outsourced to another office. There, the computers are Excel 2019, Windows 10 and 64 bits.
And the code does not work there. It does not arise any error, but the function DownloadUrlFile does not download any file on Excel 2019 + W10
So to resume, Excel 2007 + Windows 7 works perfectly (tested today). Excel 2019 + Windows 10 does not work (no errors on screen).
Things I've tried to fix it:
I've checked that file urlmon.dll exists in system32 and it does
I've tried declaring the function URLDownloadToFileA using PtrSafe
If I manually type the url in Chrome in the PC with Excel 2019 + W10, the file is downloaded properly, so the URL is ok.
None of this solved my problem. I'm pretty sure the solution it's really easy, because the code works perfectly in Excel 2007, but I can't find what I'm missing here.
I would like to get a code that works in any case, but I would accept also a solution that works only in Excel 2019 and Windows 10 if it's the only way.
Hope somebody can throw some light about this. Thanks in advance.
UPDATE: Tried also the solution in this post but still nothing.
UPDATE 2: Also, tested the code posted here (Excel 2007) with Excel 2010 and it works perfectly.
UPDATE 3: The variable RetVal stores the result of the download. I know some values:
' Returns 0 if success, error code if not.
' Error codes:
' -2146697210 "file not found".
' -2146697211 "domain not found".
' -2147467260 "transfer aborted".
But in my case, it returns -2147221020. What could that be?
UPDATE 4: Well, this is just weird. I've tried same code to download a different file from a public website, and it works in Excel 2019 + W10.
I made a new easy code like this:
#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
#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
#End If
Sub Descarga()
Dim EstaURL As String
Dim EsteCSV As String
EstaURL = privateone 'can't be shared, sorry
EsteCSV = "CSV Datos " & Format(Date, "dd-mm-yyyy") & ".csv"
On Error GoTo Errores
URLDownloadToFile 0, "https://tutorialesexcel.com/wp-content/uploads/2018/10/funciones.xlsm", ThisWorkbook.Path & "\" & EsteCSV, 0, 0
URLDownloadToFile 0, EstaURL, ThisWorkbook.Path & "\" & EsteCSV, 0, 0
Exit Sub
Errores:
'Si es un bucle lo mejor sería no mostrar ningún mensaje
MsgBox "Not downloaded", vbCritical, "Errores"
End Sub
The line that says URLDownloadToFile 0, "https://tutorialesexcel.com/wp-content/uploads/2018/10/funciones.xlsm", ThisWorkbook.Path & "\" & EsteCSV, 0, works perfect and downloas the file.
The line URLDownloadToFile 0, EstaURL, ThisWorkbook.Path & "\" & EsteCSV, 0, 0does not work.
So tested again exactly same code but on Excel 2007 and both of them work
Why the first download works and the second one does not on Excel 2019 + W10 but both of them work on Excel 2007+W7?
UPDATE 5: The URL is private, because it contains username and password, but it's like this:
https://user:token#www.privatewebsite.com/export/target%20file.csv
Thanks to #Stachu, the URL does not work manually on Internet Explorer on any PC (copy/pasting in the explorer navigation bar, I mean). The URL works perfectly in Google Chrome in all PC.
It's really curious that, manually, the URL on Internet Explorer does not work, but same URL coded with VBA and Executed on Excel2007/2010 works perfectly. Maybe I should change something about the encoding?
UPDATE 6: Still studying all posts by you. The issue here is that I'm just the data guy, the analyst, so plenty of information posted here sounds really hardcore to me.
I've emailed all the info to the IT guys 1 day ago, and still waiting for an answer.
Meanwhile, and based on information here, finally coded something totally different that works on all machines. It works on Windows 7 and 10, and it works on Excel 2007 and 2010 (installed as 32 bits) and Excel 2019 (installed as 64 bits).
I'm adding the code here, so maybe somebody can explain why it works properly, but it looks like the issue was the base64 encoding.
The code I got now is like this (added reference to Microsoft Winhttp Setvices 5.1)
Application.ScreenUpdating = False
Dim whr As WinHttp.WinHttpRequest
Dim oStream As Object
Dim EsteCSV As String
Dim EstaURL As String
EstaURL = "https://user:pass#www.privatewebsite.com/export/target%20file.csv"
EsteCSV = "CSV Datos" & Format(Date, "dd-mm-yyyy") & ".csv"
'Set whr = CreateObject("WinHttp.WinHttpRequest.5.1")
Set whr = New WinHttp.WinHttpRequest
whr.Open "GET", EstaURL, True
whr.setRequestHeader "Authorization", "Basic " & EncodeBase64("user" & ":" & "password")
whr.send
' Using 'true' above and the call below allows the script to remain responsive.
whr.waitForResponse
DoEvents
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write whr.responseBody
oStream.SaveToFile ThisWorkbook.Path & "\" & EsteCSV
oStream.Close
DoEvents
Set oStream = Nothing
whr.abort
Set whr = Nothing
'rest of code for operations
Kill ThisWorkbook.Path & "\" & EsteCSV
Application.ScreenUpdating = True
End Sub
Private Function EncodeBase64(text As String) As String
Dim arrData() As Byte
arrData = StrConv(text, vbFromUnicode)
Dim objXML As Object
Dim objNode As Object
Set objXML = CreateObject("MSXML2.DOMDocument")
Set objNode = objXML.createElement("b64")
objNode.DataType = "bin.base64"
objNode.nodeTypedValue = arrData
EncodeBase64 = objNode.text
Set objNode = Nothing
Set objXML = Nothing
End Function
Sub Code is fine. Check the references in tools menu in vba and make declaration ptrsafe as below
Private Declare PtrSafe Function URLDownloadToFileA Lib "urlmon" _
The computers that execute this code are all of them Windows 7 and
Excel 2007 and 64 bits. None of them fail.
But now, this task is going to be outsourced to another office. There,
the computers are Excel 2019, Windows 10 and 64 bits.
And the code does not work there. It does not arise any error, but the
function DownloadUrlFile does not download any file on Excel 2019 +
W10
I'm guessing it is not working in another office.
This will only happen if the URL is private and the IPs are not whitelisted. You can check with your networking team for the same whether they have whitelisted the IPs for that URL.
The line that says URLDownloadToFile 0,
"https://tutorialesexcel.com/wp-content/uploads/2018/10/funciones.xlsm",
ThisWorkbook.Path & "\" & EsteCSV, 0, works perfect and downloas the
file.
The line URLDownloadToFile 0, EstaURL, ThisWorkbook.Path & "\" &
EsteCSV, 0, 0does not work.
So tested again exactly same code but on Excel 2007 and both of them
work
Why the first download works and the second one does not on Excel 2019
+ W10 but both of them work on Excel 2007+W7?
Also, It makes no sense that the same code is working perfectly fine for the public URL and not for the private URL except there is an IP restriction.
As for your error, -2147221020 => 0x800401E4 as per VBA Error Codes and Descriptions
this error is MK_E_SYNTAX which is 'invalid moniker syntax'.
When it says moniker I guess it means your url and to be honest the web address does not look syntactically correct...
"https://user:token#www.privatewebsite.com/export/targetfile.csv"
I'd have to dig around to see if that truly met the web standard for a url. In the meantime I'd suggest figuring out a different url. It maybe that an upgrade to urlmon.dll now complains about the url whereas the Windows 7 version didn't.
Ok, my bad, actually it looks like you can do such uris, in theory, so I have a uri fragment
first-client:noonewilleverguess#localhost:8080/oauth/token taken from OAuth2 Boot
Ok, so it is valid, re top of page 17 rfc3986.
authority = [ userinfo "#" ] host [ ":" port ]
Looks like you'll have to drop into Windows API calls to set username and password. So here is sample code
Option Explicit
'* with thanks to http://www.holmessoft.co.uk/homepage/WininetVB.htm
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" ( _
ByVal lpszAgent As String, _
ByVal dwAccessType As Long, _
ByVal lpszProxyName As String, _
ByVal lpszProxyBypass As String, _
ByVal dwFlags As Long) As Long
Private Enum InternetOpenAccessTypes
INTERNET_OPEN_TYPE_PRECONFIG = 0 'Retrieves the proxy or direct configuration from the registry.
INTERNET_OPEN_TYPE_DIRECT = 1 'Resolves all host names locally.
INTERNET_OPEN_TYPE_PROXY = 3 'Passes requests to the proxy unless a proxy bypass list is supplied and the name to be resolved bypasses the proxy. In this case, the function uses INTERNET_OPEN_TYPE_DIRECT.
INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY = 4 'Retrieves the proxy or direct configuration from the registry and prevents the use of a startup Microsoft JScript or Internet Setup (INS) file.
End Enum
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" ( _
ByVal hInternetSession As Long, _
ByVal lpszServerName As String, _
ByVal nServerPort As Integer, _
ByVal lpszUsername As String, _
ByVal lpszPassword As String, _
ByVal dwService As Long, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Private Const INTERNET_SERVICE_HTTP = 3
Private Const INTERNET_FLAG_NO_COOKIES = &H80000
Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000
Private Declare Function HttpOpenRequest Lib "wininet.dll" Alias "HttpOpenRequestA" ( _
ByVal hHttpSession As Long, _
ByVal lpszVerb As String, _
ByVal lpszObjectName As String, _
ByVal lpszVersion As String, _
ByVal lpszReferer As String, _
ByVal lpszAcceptTypes As String, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Private Declare Function HttpSendRequest Lib "wininet.dll" Alias "HttpSendRequestA" ( _
ByVal hHttpRequest As Long, _
ByVal lpszHeaders As String, _
ByVal dwHeadersLength As Long, _
ByVal lpOptional As String, _
ByVal dwOptionalLength As Long) As Boolean
Private Declare Function InternetReadFile Lib "wininet.dll" ( _
ByVal hFile As Long, _
ByVal lpBuffer As String, _
ByVal dwNumberOfBytesToRead As Long, _
ByRef lpNumberOfBytesRead As Long) As Boolean
Private Sub Test()
Dim hInternet As Long
hInternet = InternetOpen("Mozilla", INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
If hInternet = 0 Then
Debug.Print "InternetOpen failed"
GoTo SingleExit
End If
Dim sUSERNAME As String
sUSERNAME = "foo"
Dim sPASSWORD As String
sPASSWORD = "bar"
Dim hConnect As Long
hConnect = InternetConnect(hInternet, "www.microsoft.com", 80, sUSERNAME, sPASSWORD, INTERNET_SERVICE_HTTP, 0, 0)
If hConnect = 0 Then
Debug.Print "InternetConnect failed"
GoTo SingleExit
End If
Dim lFlags As Long
Dim hRequest As Long
lFlags = INTERNET_FLAG_NO_COOKIES
lFlags = lFlags Or INTERNET_FLAG_NO_CACHE_WRITE
hRequest = HttpOpenRequest(hConnect, "GET", "www.microsoft.com", "HTTP/1.0", vbNullString, vbNullString, lFlags, 0)
Dim bRes As Boolean
bRes = HttpSendRequest(hRequest, vbNullString, 0, vbNullString, 0)
Dim strFile As String
strFile = "downloadedfile.txt"
Dim strBuffer As String * 1
Dim strDir As String
strDir = Dir(ThisWorkbook.Path & "\" & strFile)
If Len(strDir) > 0 Then
Kill ThisWorkbook.Path & "\" & strFile
End If
Dim iFile As Long
iFile = FreeFile()
Open ThisWorkbook.Path & "\" & strFile For Binary Access Write As iFile
Do
Dim lBytesRead As Long
bRes = InternetReadFile(hRequest, strBuffer, Len(strBuffer), lBytesRead)
If lBytesRead > 0 Then
Put iFile, , strBuffer
End If
Loop While lBytesRead > 0
Debug.Print "finished"
SingleExit:
End Sub
UPDATE: Congratulations on your solution for which you invite an explanation, perhaps see this MSDN Forum where the discourse outlines the different technology stacks. If I browse the C++ header file urlmon.h then URLDownloadToFile looks like its based on WinInet. So switching to WinHTTP is a smart move to a more server based stack.
Also, on the same stack logic, I believe you could have used MSXML2.ServerXMLHTTP see this VBScript newsgroup archive
I tried this solution in Excel 2019 / O365 64 bits (version: 1912) / win 10 64 bits
I know you have a working code, but if anybody else needs an alternative, here it is:
Sub DownloadFile()
Dim evalURL As String
Dim streamObject As Object
Dim winHttpRequest As Object
Set winHttpRequest = CreateObject("Microsoft.XMLHTTP")
evalURL = "https://fullPathTofile/tst.csv" ' -> Didn't need to add the username at the beginning
winHttpRequest.Open "GET", evalURL, False, "username", "password"
winHttpRequest.send
If winHttpRequest.Status = 200 Then
Set streamObject = CreateObject("ADODB.Stream")
streamObject.Open
streamObject.Type = 1
streamObject.Write winHttpRequest.responseBody
streamObject.SaveToFile "C:\temp\file.csv", 2 ' 1 = no overwrite, 2 = overwrite
streamObject.Close
End If
End Sub
The "simplified" method you used (user+password#url) has had spotty support at best due to its potential of remote abuse. Some browsers no longer even support it.
For example, a HREF link of ...admin:admin#192.168.1.1/cgi-bin/something-else?... is enough to exploit several routers protected only by a "deny remote access" default instead of a reliable password, and there are many of those.
You might be able to overcome this by saving user and password in Internet Explorer, whose libraries are used by Excel, and/or placing the remote site in the "Trusted Sites" group from Internet Options. But this is a stopgap measure too, since the password cache might be erased by accident and security levels might be reset by an update at any time (I had this happen to me more than once).
Here there are other methods discussed. Otherwise, your solution of course works (you might want to add an answer to that effect, and mark it accepted for the next who gets the same problem).
I was struggling for days with this, until I figured out it can be done in one line of PowerShell, for example:
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 and was making me lose me mind, so I just call my PowerShell script from VBA every time I want to download a file.
very, very simple and the "UseDefaultCredentials" works an absolute treat and I don't have to worry about logging into the remote site etc.
This lets me download reports from SSRS in PDF format to a folder in a couple of lines of code.
Thanks everybody for all your help and answers. Unfortunately, my IT department was not able to tell me what was happening exactly, even with all the links provided here with a lot of useful info.
I'm posting here the code we are using here right now. IT's works perfectly on Excel 2007 32 bit, Excel 2010 32 and 64 bits and Excel 2019 64 bits. It works too on Windows 7 and 10.
To make this code work, you need to add a reference to Microsoft Winhttp Setvices 5.1. Check How to Add an Object Library Reference in VBA in case you don't know how to do this:
Application.ScreenUpdating = False
Dim whr As WinHttp.WinHttpRequest
Dim oStream As Object
Dim EsteCSV As String
Dim EstaURL As String
EstaURL = "https://user:pass#www.privatewebsite.com/export/target%20file.csv"
EsteCSV = "CSV Datos" & Format(Date, "dd-mm-yyyy") & ".csv"
'Set whr = CreateObject("WinHttp.WinHttpRequest.5.1")
Set whr = New WinHttp.WinHttpRequest
whr.Open "GET", EstaURL, True
whr.setRequestHeader "Authorization", "Basic " & EncodeBase64("user" & ":" & "password")
whr.send
' Using 'true' above and the call below allows the script to remain responsive.
whr.waitForResponse
DoEvents
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write whr.responseBody
oStream.SaveToFile ThisWorkbook.Path & "\" & EsteCSV
oStream.Close
DoEvents
Set oStream = Nothing
whr.abort
Set whr = Nothing
'rest of code for operations
Kill ThisWorkbook.Path & "\" & EsteCSV
Application.ScreenUpdating = True
End Sub
Private Function EncodeBase64(text As String) As String
Dim arrData() As Byte
arrData = StrConv(text, vbFromUnicode)
Dim objXML As Object
Dim objNode As Object
Set objXML = CreateObject("MSXML2.DOMDocument")
Set objNode = objXML.createElement("b64")
objNode.DataType = "bin.base64"
objNode.nodeTypedValue = arrData
EncodeBase64 = objNode.text
Set objNode = Nothing
Set objXML = Nothing
End Function
Thanks again everyone. SO is a great place.

printing specific pages form pdf file using print scope string

I need to print selected pages of *.pdf file using excel VBA.
I need to do this not by providing scope "from - to" but giving scoope of pages like "1-3,4,8, 17-25"
I can only print whole file using below code:
Public 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
Public Function PrintThisDoc(formname As Long, FileName As String)
On Error Resume Next
Dim X As Long
X = ShellExecute(formname, "Print", FileName, 0&, 0&, 3)
End Function
Sub testPrint()
Dim printThis
Dim strDir As String
Dim strFile As String
strDir = "C:\Users\any\Desktop"
strFile = "somefile.pdf"
printThis = PrintThisDoc(0, strDir & "\" & strFile)
End Sub ```
Judging from this post, it is not possible using ShellExecute alone. What you would need is to write a script which will open the file in whatever PDF reader you have installed, find a "Print" button there and provide all the options. This will take a huge amount of work and will depend on the version of Windows and the PDF reader, so basically it will work only for you, and not for other users.
If you want to go this path though, take a look at FindWindow and SendMessage WinAPI functions.

Excel VBA - Closing a specific File Explorer window out of multiple open File Explorer windows

Cell A3 contains folder path. Cells below contain file names with extensions. Upon selecting a cell below, my Excel macro opens that file's location in File Explorer and out of multiple files in that folder selects this particular one, which can be seen in Preview. When next cell containing another file name is selected on the spreadsheet, another File Explorer window opens, even though it's the same path from A3. Looking for a line of code to add which will first close the first File Explorer window, before opening a new one. The code needs to be closing that specific File Explorer window from cell A3, out of multiple open File Explorer windows. Code I have so far
UPDATE: Running below codes, but it does not close the existing opened folder, just opens yet another:
If Target.Column = 1 And Target.Row > 5 Then
Call CloseWindow
Shell "C:\Windows\explorer.exe /select," & Range("A3") & ActiveCell(1, 1).Value, vbNormalFocus 'this works, but opens NEW folder every time
and in separate Module:
'BELOW GOES WITH Public Sub CloseWindow() FROM: https://stackoverflow.com/questions/49649663/close-folder-opened-through-explorer-exe
Option Explicit
''for 64-bit Excel use
'Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
' (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Long) As LongPtr
''for 32-bit Excel use
'Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
' (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
'To make it compatible with both 64 and 32 bit Excel you can use
#If VBA7 Then
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Long) As LongPtr
#Else
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
#End If
'Note that one of these will be marked in red as compile error but the code will still run.
Const WM_SYSCOMMAND = &H112
Const SC_CLOSE = &HF060
Public Sub CloseWindow()
Dim sh As Object
Set sh = CreateObject("shell.application")
Dim w As Variant
For Each w In sh.Windows
'print all locations in the intermediate window
Debug.Print w.LocationURL
' select correct shell window by LocationURL
' If w.LocationURL = "file://sharepoint.com#SSL/DavWWWRoot/sites/folder" Then
'If w.LocationURL = "Range("M1").value" Then
If w.LocationURL = "file://K:/ppp/xx/yy/1 - zzz" Then
SendMessage w.hWnd, WM_SYSCOMMAND, SC_CLOSE, 0
End If
Next w
End Sub
UPDATE 2:
I am now thinking however, that probably the best solution would actually be not to close the file explorer and then open it, but rather for the code to identify that there is already an open file explorer window with path from cell A3 and neither close it nor open a new one, but rather just select the new file corresponding to the new cell being clicked on in already opened file explorer window with path from cell A3. Can anybody think of a way to do that?
I found an solution (not my own) that implements a WMI query against a 'Win32_Process' Class. The code here closes any explorer.exe instances. While I don't fully understand it, I did test and found it works.
Sub CloseWindow()
Dim objWMIcimv2 As Object, objProcess As Object, objList As Object
Dim intError As Integer
Set objWMIcimv2 = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set objList = objWMIcimv2.ExecQuery("select * from win32_process where name='explorer.exe'")
For Each objProcess In objList
intError = objProcess.Terminate
If intError <> 0 Then Exit For
Next
Set objWMIcimv2 = Nothing
Set objList = Nothing
Set objProcess = Nothing
End Sub
This will do the job for you. If the folder is not open it will open it, otherwise it will activate it and will bring it to the front.
In case you want to select a file in the folder, you should modify this a bit and use oWinOpen.Quit to close the window and then re-open it. Shell's behavior when opening a folder simply is different from when selecting a file in the folder too.
Sub OpenFolder(strPath As String)
Dim bFolderIsOpen As Boolean
Dim oShell As Object
Dim oWinOpen As Object
Dim Wnd As Object
Set oShell = CreateObject("Shell.Application")
bFolderIsOpen = FALSE
For Each Wnd In oShell.Windows
If Wnd.Document.Folder.Self.Path = strPath Then
Set oWinOpen = Wnd
bFolderIsOpen = TRUE
End If
Next Wnd
If bFolderIsOpen = FALSE Then 'open it for the first time
Call Shell("explorer.exe" & " " & """" & strPath & """", vbNormalFocus)
Else
oWinOpen.Visible = FALSE
oWinOpen.Visible = TRUE
End If

Downloading zip file using web api results in corrupted file

I have a VBA code that downloads a zip file based on the URL and saves it to a folder. However, the downloaded file is corrupted. The downloaded file using the VBA code has a file size significantly lower than the actual file.
Below is the code I am using:
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
Sub DownloadFile
Dim L as long
L = URLDownloadToFile(0&, UrlFileName, DestinationFileName, 0&, 0&)
If L = 0 Then
Debug.Print "Download successful"
Else
Debug.Print "Download unsuccessful"
End If
End Sub
`
The site that I am downloading the ZIP files requires a log-in, and I log-in to the site before I run the said VBA code.
Sample URL (not the true URL): https://www.samplewebsite.org/bsplink14/updownload/motorqcopia2.asp?vr=&name=VBGHFaz7243%5F20180424%5F0403%5FAirline%5FZCVDRFDBilling.zip&filtroread=true&extid=INDEFD1834262&rif=3373&s3s=47c7d4b47bc1c57cc4c6c29959dca0
Can you help me on this?
Make sure you reference to MSXML, insert a class module, and in it the following code. Do the DownloadToFile only in case that function returns True, should work.
Public Function DoLoginByPost(URL As String, strUser As String, strPassword As String) As Boolean
Dim xHttp As MSXML2.XMLHTTP
Dim sTICKER As String
sTICKER = "user=" & strUser & "&pass=" & strPassword & "&logintype=login&pid=4&login=Login"
'Check this and edit accordingly by e.g. using the web developer tools in your browser when logging in regularly.
'You should be able to identify what form data is being sent when loggin on.
Set xHttp = New MSXML2.XMLHTTP
xHttp.Open "POST", URL
xHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
xHttp.send sTICKER
Do Until xHttp.READYSTATE = 4
DoEvents
Loop
If xHttp.Status = 200 Then
DoLoginByPost = True
Else: DoLoginByPost = False
End If
End Function
'After receiving "TRUE", alter your original code to:
Set xHttp = New MSXML2.XMLHTTP
xHttp.Open "Get", UrlFileName, False
xHttp.send
Do Until xHttp.ReadyState = 4
DoEvents
Loop
Open DestinationFileName For Binary As #1
Put #1, , xHttp.responseBody
Close #1

VBA - Username of open workbook (read only)

If an open workbook (located on a server) is in read only mode, how can I display the active username using VBA?
I've looked into .WriteReservedBy but this only shows the name of the person that last saved the file with a password.
This should probably be a comment but my reputation is too low
I've seen this but never needed the info...
Things to try:
ThisWorkbook.UserStatus - array with all current users for the file open as exclusive or shared
Environ("USERNAME")
CreateObject("WScript.NetWork").UserName
API calls:
.
Declare Function WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA"
( _
ByVal lpName As String, _
ByVal lpUserName As String, _
lpnLength As Long
) As Long
Declare Function GetUserName& Lib "advapi32.dll" Alias "GetUserNameA" _
(ByVal lpBuffer As String, nSize As Long)
.
more details about these APIs:
https://support.microsoft.com/en-us/kb/161394
http://www.vbaexpress.com/kb/getarticle.php?kb_id=768
WMI Win32_NetworkConnection:
Public Function GetActiveUser(Optional ByVal computer As String = ".") As String
Dim wmi As Object, itm As String
On Error Resume Next
Set wmi = GetObject("winmgmts:\\" & computer & "\Root\CIMv2")
itm = wmi.ExecQuery("Select UserName from Win32_NetworkConnection", , 48)
GetNetActiveUser = itm
End Function

Resources