URLDownloadToFile Error: INET_E_SECURITY_PROBLEM - excel

I'm modifying code to download multiple files via Excel VBA.
The code is as follows:
Option Explicit
'API function declaration for both 32 and 64bit Excel.
#If VBA7 Then
Private 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
#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 DownloadFiles()
'--------------------------------------------------------------------------------------------------
'The macro loops through all the URLs (column C) and downloads the files at the specified folder.
'The characters after the last "/" of the URL string are used to create the file path.
'If the file is downloaded successfully an OK will appear in column D (otherwise an ERROR value).
'The code is based on API function URLDownloadToFile, which actually does all the work.
'Written By: Christos Samaras
'Date: 02/11/2013
'Last Update: 06/06/2015
'E-mail: xristos.samaras#gmail.com
'Site: https://myengineeringworld.net/////
'--------------------------------------------------------------------------------------------------
'Declaring the necessary variables.
Dim sh As Worksheet
Dim DownloadFolder As String
Dim LastRow As Long
Dim SpecialChar() As String
Dim SpecialCharFound As Double
Dim FilePath As String
Dim i As Long
Dim j As Integer
Dim Result As Long
Dim CountErrors As Long
'Disable screen flickering.
Application.ScreenUpdating = False
'Set the worksheet object to the desired sheet.
Set sh = Sheets("Sheet1")
'An array with special characters that cannot be used for naming a file.
SpecialChar() = Split(" / : * ? " & Chr$(34) & " < > |", " ")
'Find the last row.
With sh
.Activate
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
End With
'Check if the download folder exists.
DownloadFolder = sh.Range("B4")
On Error Resume Next
If Dir(DownloadFolder, vbDirectory) = vbNullString Then
MsgBox "The folder's path is incorrect!", vbCritical, "Folder's Path Error"
sh.Range("B4").Select
Exit Sub
End If
On Error GoTo 0
'Check if there is at least one URL.
If LastRow < 8 Then
MsgBox "You did't enter a single URL!", vbCritical, "No URL Error"
sh.Range("C8").Select
Exit Sub
End If
'Clear the results column.
sh.Range("D8:D" & LastRow).ClearContents
'Add the backslash if doesn't exist.
If Right(DownloadFolder, 1) <> "" Then
DownloadFolder = DownloadFolder & ""
End If
'Counting the number of files that will not be downloaded.
CountErrors = 0
'Save the internet files at the specified folder of your hard disk.
On Error Resume Next
For i = 8 To LastRow
'Find the characters after the last "/" of the URL.
With WorksheetFunction
FilePath = Mid(sh.Cells(i, 3), .Find("*", .Substitute(sh.Cells(i, 3), "/", "*", Len(sh.Cells(i, 3)) - _
Len(.Substitute(sh.Cells(i, 3), "/", "")))) + 1, Len(sh.Cells(i, 3)))
End With
'Check if the file path contains a special/illegal character.
For j = LBound(SpecialChar) To UBound(SpecialChar)
SpecialCharFound = InStr(1, FilePath, SpecialChar(j), vbTextCompare)
'If an illegal character is found substitute it with a "-" character.
If SpecialCharFound > 0 Then
FilePath = WorksheetFunction.Substitute(FilePath, SpecialChar(j), "-")
End If
Next j
'Create the final file path.
FilePath = DownloadFolder & FilePath
'Check if the file path exceeds the maximum allowable characters.
If Len(FilePath) > 255 Then
sh.Cells(i, 4) = "ERROR"
sh.Cells(i, 2) = "ERROR1"
CountErrors = CountErrors + 1
End If
'If the file path is valid, save the file into the selected folder.
If UCase(sh.Cells(i, 4)) <> "ERROR" Then
'Try to download and save the file.
Result = URLDownloadToFile(0, sh.Cells(i, 3), FilePath, 0, 0)
'Check if the file downloaded successfully and exists.
If Result = 0 And Not Dir(FilePath, vbDirectory) = vbNullString Then
'Success!
sh.Cells(i, 4) = "OK"
sh.Cells(i, 2) = Result & "&" & FilePath & "&" & vbDirectory
Else
'Error!
sh.Cells(i, 4) = "ERROR"
sh.Cells(i, 2) = Result & "&" & FilePath & "&" & vbDirectory
CountErrors = CountErrors + 1
End If
End If
Next i
On Error GoTo 0
'Enable the screen.
Application.ScreenUpdating = True
'Inform the user that macro finished successfully or with errors.
If CountErrors = 0 Then
'Success!
If LastRow - 7 = 1 Then
MsgBox "The file was successfully downloaded!", vbInformation, "Done"
Else
MsgBox LastRow - 7 & " files were successfully downloaded!", vbInformation, "Done"
End If
Else
'Error!
If CountErrors = 1 Then
MsgBox "There was an error with one of the files!", vbCritical, "Error"
Else
MsgBox "There was an error with " & CountErrors & " files!", vbCritical, "Error"
End If
End If
End Sub
This code downloads most files just fine, but I ran across issues when trying to download from SPP(Southwest Power Pool)'s API. For Example:
https://marketplace.spp.org/file-api/download/da-lmp-by-location?path=%2F2018%2F11%2FDA-LMP-MONTHLY-SL-201811.csv
This file or any similar file that I try to download from this api is identified and downloaded just fine by any browser or download manager, but URLDownloadToFile reports an error and does not download the file. It downloads files from other sources successfully
My knowledge of coding allowed me to track down the error/return code, which is reported in column B by the following bit of code:
sh.Cells(i, 2) = Result & "&" & FilePath & "&" & vbDirectory
To my understanding, this indicates INET_E_SECURITY_PROBLEM with return code of -2146697202.
Beyond Identifying the error, I am out of my depth.
Assistance in figuring out how to get past this major roadblock would be greatly appreciated.

Related

Do While loops, but only returns the first specified value

I'm a novice programmer and I'm making a program that will send individualized emails to merchandisers with a list when they've violated our pricing policies. I've gotten sending the email and filling in most of the merchandiser-specific information to work, but I'm trying to include URL links so they can view their violations in detail.
Different merchants will have different numbers of violations, so I added this while loop at the end so it adds only those URLs that are pertinent to them. This loop is nested inside a For loop to the end of the data.
Do While ((Range("B" & n).Value <> "") And (Range("A" & n).Value = ""))
xMsg = xMsg & xRg.Cells(n, 21) & vbCrLf
n = n + 1
Loop
If the value in B row n is not empty and A row n is it should add the URL from column 21 on row n to the bottom of the message and then stop when those conditions aren't met (when we're at a new merchant).
Currently, it will only return the value for column 21 from the first row and nothing else, despite appearing to loop.
I've ran the debugger to see if the loop isn't incrementing like it should, but that seems to be working. I've also tried formatting it as a Do Until Loop, using Cells(n, 1).Value and Cells(n, 2).Value for the reference addresses and a Do While with one of the conditions and a nested If to create the other. Nothing has worked.
I can include more of my code if that would be helpful. Please excuse any sloppiness in my code (I know there are plenty). I'm an accountant, not a programmer.
Here is the entirety of my code. Full disclosure and in the interest of plagarism, I got the majority of it from Kutools on Extendoffice.com and have just modified it to my needs. I've also edited out the actual text of the email body.
#If VBA7 And Win64 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
Sub SendEMail()
'update by Extendoffice 20160506
Dim xEmail As String
Dim xSubj As String
Dim xMsg As String
Dim xURL As String
Dim i As Integer
Dim n As Long
Dim k As Double
Dim xCell As Range
Dim xRg As Range
Dim xTxt As String
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
If xRg.Columns.Count <> 21 Then
MsgBox " Regional format error, please check", , "Kutools for Excel"
Exit Sub
End If
For i = 1 To xRg.Rows.Count
n = i + 2
If InStr(1, xRg.Cells(i, 13).Value, "#") > 0 Then
' Get the email address
xEmail = xRg.Cells(i, 13)
' Message subject
xSubj = "MAPP Violation"
' Compose the message
xMsg = ""
xMsg = xMsg & "Text" &vbCrLf
Do While ((Range("B" & n).Value <> "") And (Range("A" & n).Value = ""))
xMsg = xMsg & xRg.Cells(n, 21) & vbCrLf
n = n + 1
Loop
' Replace spaces with %20 (hex)
xSubj = Application.WorksheetFunction.Substitute(xSubj, " ", "%20")
xMsg = Application.WorksheetFunction.Substitute(xMsg, " ", "%20")
' Replace carriage returns with %0D%0A (hex)
xMsg = Application.WorksheetFunction.Substitute(xMsg, vbCrLf, "%0D%0A")
' Create the URL
xURL = "mailto:" & xEmail & "?subject=" & xSubj & "&body=" & xMsg
' Execute the URL (start the email client)
ShellExecute 0&, vbNullString, xURL, vbNullString, vbNullString, vbNormalFocus
' Wait two seconds before sending keystrokes
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "%s"
End If
Next
End Sub
Again, I apologize for the sloppiness. I know the formatting is mediocre and I can make the Do While Loop as a separate sub and call it. I learned basic C++ five years ago and haven't retained much of my knowledge or etiquette. I wasn't planning on anyone else seeing my code so I wasn't going to clean it up until I got it working.
Currently, it's set up so you select the total data range for it to look at. I've kept it that way so I could test it without sending tons of emails to unsuspecting victims. Once I have it working I'll change xRg to be the last populated row and column.
Here's what the data I'm using looks like. I've edited the merchant information to protect their privacy.
enter image description here
Suggested fix:
Sub SendEMail()
Dim xEmail As String, xSubj As String, xMsg As String, xURL As String
Dim i As Long, n As Long, k As Double
Dim xRg As Range
Dim xTxt As String
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select the data range:", _
"Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
If xRg.Columns.Count <> 21 Then
MsgBox " Regional format error, please check", , "Kutools for Excel"
Exit Sub
End If
For i = 1 To xRg.Rows.Count
If InStr(1, xRg.Cells(i, 13).Value, "#") > 0 Then
xEmail = xRg.Cells(i, 13) 'Get the email address
xSubj = "MAPP Violation" 'Message subject
xMsg = "Text" & vbCrLf
n = i + 2
'### use xRg.Cells() not Range() here...
Do While xRg.Cells(n, "B").Value <> "" And xRg.Cells(n, "A").Value = ""
xMsg = xMsg & xRg.Cells(n, 21) & vbCrLf
n = n + 1
Loop
xSubj = Replace(xSubj, " ", "%20") 'Replace spaces with %20 (hex)
xMsg = Replace(xMsg, " ", "%20")
xMsg = Replace(xMsg, vbCrLf, "%0D%0A") 'Replace carriage returns with %0D%0A (hex)
xURL = "mailto:" & xEmail & "?subject=" & xSubj & "&body=" & xMsg 'Create the URL
'Execute the URL (start the email client)
ShellExecute 0&, vbNullString, xURL, vbNullString, vbNullString, vbNormalFocus
'Wait two seconds before sending keystrokes
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "%s"
End If
Next i
End Sub
My issue seems to have been a that the URLs were too long and I reached a character limit which caused errors when exporting to Outlook. I ended up rewriting my code in HTML format so I could add the URLs as hyperlinks and that worked.

file not found error on MacOS when trying to download images from url placed in column in excel sheet

I am trying to download all jpg files whose url are placed in an excel sheet in one columns. I am having an error error 53 in mac its 64 bit version. Would changing long variable type to longptr help?
Here is my code
`Option Explicit
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 LongPtr
Public Function DownloadURLtoFile(sSourceURL As String, _
sLocalFileName As String) As Boolean
Debug.Print sSourceURL
Debug.Print sLocalFileName
DownloadURLtoFile = URLDownloadToFile(0&, _
sSourceURL, sLocalFileName, &H10, 0&) = 0&
End Function
Sub DownLoadFiles()
Dim cell As Range, rngListOfURL As Range, FirstName As String, LastName As String, spacepos As Integer, lastrow As Long
Dim FolderName As String, FolderString As String
FolderName = ThisWorkbook.Worksheets("CANDIDATURE").Range("B2").Value & "_" & ThisWorkbook.Worksheets("CANDIDATURE").Range("A2").Value 'Choose Folder Name
FolderString = CreateFolderinMacOffice(NameFolder:=FolderName) 'Create Folder
FolderString = FolderString & Application.PathSeparator
'Const PTH = FolderString & Application.PathSeparator 'this is your save to location
lastrow = ThisWorkbook.Worksheets("CANDIDATURE").Range("C999999").End(xlUp).Row
'Set rngListOfURL = ThisWorkbook.Worksheets("database").Range("AL2:AL26") 'amend as appropriate
Set rngListOfURL = ThisWorkbook.Worksheets("CANDIDATURE").Range("I2", Range("I" & lastrow)) 'amend as appropriate
Debug.Print rngListOfURL.Address
i = 2
For Each cell In rngListOfURL
LastName = ThisWorkbook.Worksheets("CANDIDATURE").Cells(i, 6).Value
FirstName = ThisWorkbook.Worksheets("CANDIDATURE").Cells(i, 5).Value
spacepos = InStr(1, LastName, " ")
If spacepos <> 0 Then
LastName = Left(LastName, spacepos - 1)
End If
Debug.Print cell.Address
If DownloadURLtoFile(cell.Value, FolderString & FirstName & "_" & LastName & ".jpg") Then
cell.Offset(, 3).Value = "Successfully downloaded"
Else
cell.Offset(, 3).Value = "Error - no download"
End If
i = i + 1
Next cell
End Sub
Function CreateFolderinMacOffice(NameFolder As String) As String
'Function to create folder if it not exists in the Microsoft Office Folder
Dim OfficeFolder As String
Dim PathToFolder As String
Dim TestStr As String
OfficeFolder = MacScript("return POSIX path of (path to desktop folder) as string")
OfficeFolder = Replace(OfficeFolder, "/Desktop", "") & _
"Library/Group Containers/UBF8T346G9.Office/"
'OfficeFolder = "C:\Users\Dell\Desktop\New folder\"
PathToFolder = OfficeFolder & NameFolder
Debug.Print PathToFolder
On Error Resume Next
TestStr = Dir(PathToFolder & "*", vbDirectory)
On Error GoTo 0
If TestStr = vbNullString Then
MkDir PathToFolder
'You can use this msgbox line for testing if you want
'MsgBox "You find the new folder in this location :" & PathToFolder
End If
CreateFolderinMacOffice = PathToFolder
End Function
`
My SheetName is "CANDIDATURE" and URL of Images are Placed in Column I (URL of images) of sheet. The Names of the images would be the name in column F (LastName) & Column E (First Name). The images would be placed in a folder which would be named with column B (Person to which task is assigned) and A (Date). I dont have any experience of VBA in Mac so please leave suggestions.

Open PDF file and copy filepath and print pages VBA

I currently have a macro that loops through a list and finds PDF files based on keywords. The macro works as it should, but I would like to take it a bit further. The macro searches for the correct PDF based on the report number per item.
I would like to loop and:
Hyperlink the file in the column "M".
Check if the file was opened correctly and place the status in column "K"
Minimize all open PDF windows.
If possible, find the Item number within the PDF and it's corresponding page. Each page is also bookmarked with the item number so it could be searched that way as well. I would like to somehow print the correct pages.
There are hundreds of reports and it is a very tedious process. I also have Adobe Pro. I am open to all suggestions.
Current working code to find PDF based on wildcard:
`Sub Open_PDF()
Dim filePath As String, fileName As String, iName As String
Dim lrow As Long
Dim i As Long
lrow = Cells(Rows.Count, 10).End(xlUp).Row
For i = 5 To lrow
iName = Cells(i, 10)
FileType = Range("FileType")
filePath = Range("B6")
fileName = Dir(filePath & iName & "*" & "." & FileType)
If fileName <> "" Then
openAnyFile filePath & fileName
End If
Next i
End Sub
Function openAnyFile(strPath As String)
Dim objShell As Object
Set objShell = CreateObject("Shell.Application")
objShell.Open (strPath)
End Function
`
I found the following codes, but could not understand how to get it to work.
Option Explicit
'Retrieves a handle to the top-level window whose class name and window name match the
specified strings.
'This function does not search child windows. This function does not perform a case-
sensitive search.
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
`'Retrieves a handle to a window whose class name and window name match the specified
strings.
'The function searches child windows, beginning with the one following the specified
child window.
'This function does not perform a case-sensitive search.
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
'Brings the thread that created the specified window into the foreground and activates
the window.
'Keyboard input is directed to the window, and various visual cues are changed for the
user.
'The system assigns a slightly higher priority to the thread that created the
foreground
'window than it does to other threads.
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
'Sends the specified message to a window or windows. The SendMessage function calls
the window procedure
'for the specified window and does not lParenturn until the window procedure has
processed the message.
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
'Places (posts) a message in the message queue associated with the thread that created
the specified
'window and lParenturns without waiting for the thread to process the message.
Public Declare Function PostMessage Lib "user32.dll" Alias "PostMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
As Long
'Constants used in API functions.
Public Const WM_SETTEXT = &HC
Public Const VK_RETURN = &HD
Public Const WM_KEYDOWN = &H100
Private Sub OpenPDF(strPDFPath As String, strPageNumber As String, strZoomValue As String)
'Opens a PDF file to a specific page and with a specific zoom
'using Adobe Reader Or Adobe Professional.
'API functions are used to specify the necessary windows
'and send the page and zoom info to the Adobe window.
'By Christos Samaras
'https://myengineeringworld.net/////
Dim strPDFName As String
Dim lParent As Long
Dim lFirstChildWindow As Long
Dim lSecondChildFirstWindow As Long
Dim lSecondChildSecondWindow As Long
Dim dtStartTime As Date
'Check if the PDF path is correct.
If FileExists(strPDFPath) = False Then
MsgBox "The PDF path is incorect!", vbCritical, "Wrong path"
Exit Sub
End If
'Get the PDF file name from the full path.
On Error Resume Next
strPDFName = Mid(strPDFPath, InStrRev(strPDFPath, "") + 1, Len(strPDFPath))
On Error GoTo 0
'The following line depends on the apllication you are using.
'For Word:
'ThisDocument.FollowHyperlink strPDFPath, NewWindow:=True
'For Power Point:
'ActivePresentation.FollowHyperlink strPDFPath, NewWindow:=True
'Note that both Word & Power Point pop up a security window asking
'for access to the specified PDf file.
'For Access:
'Application.FollowHyperlink strPDFPath, NewWindow:=True
'For Excel:
ThisWorkbook.FollowHyperlink strPDFPath, NewWindow:=True
'Find the handle of the main/parent window.
dtStartTime = Now()
Do Until Now() > dtStartTime + TimeValue("00:00:05")
lParent = 0
DoEvents
'For Adobe Reader.
'lParent = FindWindow("AcrobatSDIWindow", strPDFName & " - Adobe Reader")
'For Adobe Professional.
lParent = FindWindow("AcrobatSDIWindow", strPDFName & " - Adobe Acrobat Pro")
If lParent <> 0 Then Exit Do
Loop
If lParent <> 0 Then
'Bring parent window to the foreground (above other windows).
SetForegroundWindow (lParent)
'Find the handle of the first child window.
dtStartTime = Now()
Do Until Now() > dtStartTime + TimeValue("00:00:05")
lFirstChildWindow = 0
DoEvents
lFirstChildWindow = FindWindowEx(lParent, ByVal 0&, vbNullString, "AVUICommandWidget")
If lFirstChildWindow <> 0 Then Exit Do
Loop
'Find the handles of the two subsequent windows.
If lFirstChildWindow <> 0 Then
dtStartTime = Now()
Do Until Now() > dtStartTime + TimeValue("00:00:05")
lSecondChildFirstWindow = 0
DoEvents
lSecondChildFirstWindow = FindWindowEx(lFirstChildWindow, ByVal 0&, "Edit", vbNullString)
If lSecondChildFirstWindow <> 0 Then Exit Do
Loop
If lSecondChildFirstWindow <> 0 Then
'Send the zoom value to the corresponding window.
SendMessage lSecondChildFirstWindow, WM_SETTEXT, 0&, ByVal strZoomValue
PostMessage lSecondChildFirstWindow, WM_KEYDOWN, VK_RETURN, 0
dtStartTime = Now()
Do Until Now() > dtStartTime + TimeValue("00:00:05")
lSecondChildSecondWindow = 0
DoEvents
'Notice the difference in syntax between lSecondChildSecondWindow and lSecondChildFirstWindow.
'lSecondChildSecondWindow is the handle of the next child window after lSecondChildFirstWindow,
'while both windows have as parent window the lFirstChildWindow.
lSecondChildSecondWindow = FindWindowEx(lFirstChildWindow, lSecondChildFirstWindow, "Edit", vbNullString)
If lSecondChildSecondWindow <> 0 Then Exit Do
Loop
If lSecondChildSecondWindow <> 0 Then
'Send the page number to the corresponding window.
SendMessage lSecondChildSecondWindow, WM_SETTEXT, 0&, ByVal strPageNumber
PostMessage lSecondChildSecondWindow, WM_KEYDOWN, VK_RETURN, 0
End If
End If
End If
End If
End Sub
Function FileExists(strFilePath As String) As Boolean
'Checks if a file exists.
'By Christos Samaras
'https://myengineeringworld.net/////
On Error Resume Next
If Not Dir(strFilePath, vbDirectory) = vbNullString Then FileExists = True
On Error GoTo 0
End Function
Sub TestPDF()
OpenPDF ThisWorkbook.Path & "" & "Sample File.pdf", 6, 143
End Sub
I can partially help you:
Sub Open_PDF()
Dim filePath As String, fileName As String, iName, disptxt As String
Dim lrow As Long
Dim i As Long
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
lrow = Cells(Rows.Count, 10).End(xlUp).Row
For i = 5 To lrow
iName = Cells(i, 10)
FileType = Range("FileType")
filePath = Range("B6")
fileName = Dir(filePath & iName & "*" & "." & FileType)
If fileName <> "" Then
disptxt = filePath & iName ' whatever you want the hyperlink to show
ws.Hyperlinks.Add Anchor:=ws.Range("M" & i), Address:=filePath & fileName, ScreenTip:="hover message", TextToDisplay:=disptxt
Range("K" & i) = "Success"
openAnyFile filePath & fileName
Else
Range("K" & i) = "Failed"
End If
Next i
End Sub

Download a set of images from Excel with their names using a macros

I want to run a VBScript macro to download a set of images from an URL which can de sorted by the key , (comma). I have to name each image with names given in the secondary column. For example: I have 2 columns and 5 rows. In column "A" I have all the names of the images and in column "B" I have all the URL links which can be sorted by the ,. Now I want to download all the images with their names in column "A" and for the second set of images it should rename column "A" by adding 2 at the end of each row, and then it should start downloading the second set of images. Same should go for the 3rd set or 4th set until the image set ends. Sometimes there might be only one image URL in column "B".
Here is the script which I tried to download but I was not able to sort the images and download it by renaming it again.
Option Explicit
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
Dim Ret As Long
'~~> This is where the images will be saved. Change as applicable
Const FolderName As String = "C:\Temp\"
Sub Sample()
Dim ws As Worksheet
Dim LastRow As Long, i As Long
Dim strPath As String
'~~> Name of the sheet which has the list
Set ws = Sheets("Sheet1")
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow '<~~ 2 because row 1 has headers
strPath = FolderName & ws.Range("A" & i).Value & ".jpg"
Ret = URLDownloadToFile(0, ws.Range("B" & i).Value, strPath, 0, 0)
If Ret = 0 Then
ws.Range("C" & i).Value = "File successfully downloaded"
Else
ws.Range("C" & i).Value = "Unable to download the file"
End If
Next i
End Sub
VBScript is not VB, all variables in VBScript are automatically of type Variant and does not directly support API's. It utilizes COM objects instead.
You have to implement a new function that does the same like URLDownloadToFile API call from urlmon.dll.
This should work:
Function URLDownloadToFile(szURL, szFileName, OverWrite)
On Error Resume Next
Dim FSO: Set FSO = WScript.CreateObject("Scripting.FileSystemObject")
Dim ADO_STREAM: Set ADO_STREAM = WScript.CreateObject("ADODB.Stream")
Dim HTTP: Set HTTP = WScript.CreateObject("Microsoft.XMLHTTP")
HTTP.Open "GET", CStr(szURL), False
HTTP.Send
If Err.Number <> 0 Then
WScript.Echo "An error has occured, Not connected to a network" + VbCrLf + "Error " + CStr(Err.Number) + ", " + CStr(Err.Description)
Err.Clear
URLDownloadToFile = CInt(-1)
Exit Function
End If
With ADO_STREAM
.Type = 1
.Open
.Write HTTP.ResponseBody
.SaveToFile szFileName, (CInt(OverWrite) + 1)
End With
If Err.Number <> 0 Then
WScript.Echo "URLDownloadToFile failed, Error " + CStr(Err.Number) + VbCrLf + CStr(Err.Description)
Err.Clear
URLDownloadToFile = CInt(-1)
Exit Function
End If
If (Err.Number = 0) And (FSO.FileExists(szFileName) = True) Then
URLDownloadToFile = CInt(0)
End If
On Error Goto 0
End Function
Usage of this function:
Ret = URLDownloadToFile(ws.Range("B" & i).Value, strPath, 1)
About OverWrite parameter:
Valid values: 0 or 1
1 overwrites existing file and 0 creates a new file if file doesn't exist.
If the file downloaded successfully, above function returns 0 and otherwise it returns -1 (In case any error).
Define following, so you can get the last row in Excel.
'~~> Define xlUp
Const xlUp = -4162
You must create an object referring Excel Application like:
Dim Excel: Set Excel = WScript.CreateObject("Excel.Application")
Use Excel.Sheets, instead of using only Sheets in VB. Example:
Set ws = Excel.Sheets("Sheet1")
IMPORTANT: Change your code as applicable.
Dim Ret
'~~> This is where the images will be saved.
Const FolderName = "E:\TEST\"
Sub Sample()
Dim ws, LastRow, i, strPath
'~~> Name of the sheet which has the list
Set ws = Excel.Sheets("Sheet1")
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow '<~~ 2 because row 1 has headers
strPath = FolderName & ws.Range("A" & i).Value & ".jpg"
Ret = URLDownloadToFile(ws.Range("B" & i).Value, strPath, 1) '<~~ 1 to overwrite existing file
If Ret = 0 Then
ws.Range("C" & i).Value = "File successfully downloaded"
Else
ws.Range("C" & i).Value = "Unable to download the file"
End If
Next
End Sub

Search VBA code across multiple Excel files

I have about 100 macros in a folder, and I'm looking for one in particular that contains a VBA module with function called addGBE - I forget WHICH file it's in though. Is there any software program that allows me to search within the VBA code of files in a specific folder?
Make Windows Search look within MS Office and other Compressed files
Starting with Microsoft Office 2007, the Office Open XML (OOXML) file formats have become the default file format.
File types such as .XLSX, .XLSM and .DOCX use XML architecture and ZIP compression to store things like text and formulas into cells that are organized into rows and columns. For example, simply changing a .XLSM' file's extension to.ZIP` allows you to open it as a compressed file and view the files that make up the Excel workbook.
By tweaking a few settings we can ensure that Windows Search always searches within OOXML and other compressed file formats.
My example uses Windows 7, but Windows 10 has equivalent settings.
Specify which filetypes should be indexed
Hit +E an browse to the folder where you keep your Office or Compressed files are stored.
Hit Alt+T to open the Tools menu and click Folder Options
Specify which filetypes to always search within
Go to the Search tab
Make sure Always search filenames and contents is selected
Make sure Include compressed is checked
Apply change to other folders:
At this point you can either:
repeat the above steps on any other folders on which you want to change these options, or,
go to the View tab and click Apply to Folders to make all folders look/act like the current one.
Caution! This will copy all of the current folder settings to all other folders, including displayed columns, sort order, view, etc., so be aware that you may lose unique setups for individual folders.
Personally, I'll take the time to setup one folder exactly how I like it, and implement everywhere with a single click.
Open Indexing Options:
Hit the Windows Key
Type index click Indexing Options or hit Enter
click Modify to open a filetree to specify which folders should be included in the Index.
I like to include all folders, but this negatively impacts overall performance if you have a ton of data on the drive(s).
In the Indexing Options dialog:
click the Advanced tab
in the Advanced Options dialog, go to the File Types tab.
This is where you specify which filetypes the indexer should always search within.
Go through the list looking for each Open Office XML filetype (like .XLSM and DOCX)
Select Index Properties and File Contents.
Repeat for any compressed filetypes you want to include (such as .ZIP and .RAR)
When finished click OK
]10
Force re-index:
When you're finished customizing the Indexing options:
On the Indexing Options dialog, click Rebuild to build a new index file.
Note that re-indexing can take a really long time to complete, especially if you're actively using the device and/or you have a ton of data stored locally.
You can optionally close the Indexing dialog with the × and the process will continue in the background.
I found some old code (2006) that I've updated. It will open a box to enter search string then open a dir dialog box to select folder. It will then search through all modules and display a msgbox displaying file name and sheet/module name where string was found. I did not make this, just updated. Orig found here. See here for Microsoft documentation on checking for 64bit and declaring data types properly.
Option Explicit
#If VBA7 And Win64 Then ' VBA7
Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Type BROWSEINFO
hOwner As LongPtr
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As LongPtr
lParam As LongPtr
iImage As Long
End Type
#Else ' Downlevel when using previous version of VBA7
Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
#End If
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim R As Long
Dim x As Long
Dim pos As Integer
'Root folder (&H0 for Desktop, &H11 for My Computer)
bInfo.pidlRoot = &H0
'Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
'Type of directory to return
bInfo.ulFlags = &H1
'Display the dialog
x = SHBrowseForFolder(bInfo)
'Parse the result
Path = Space$(512)
R = SHGetPathFromIDList(ByVal x, ByVal Path)
If R Then
pos = InStr(Path, Chr$(0))
GetDirectory = Left(Path, pos - 1)
Else
GetDirectory = ""
End If
End Function
Function RecursiveFindFiles(strPath As String, _
strSearch As String, _
Optional bSubFolders As Boolean = True, _
Optional bSheet As Boolean = False, _
Optional lFileCount As Long = 0, _
Optional lDirCount As Long = 0) As Variant
'adapted from the MS example:
'http://support.microsoft.com/default.aspx?scid=kb;en-us;185476
'---------------------------------------------------------------
'will list all the files in the supplied folder and it's
'subfolders that fit the strSearch criteria
'lFileCount and lDirCount will always have to start as 0
'---------------------------------------------------------------
Dim strFileName As String 'Walking strFileName variable.
Dim strDirName As String 'SubDirectory Name.
Dim arrDirNames() As String 'Buffer for directory name entries.
Dim nDir As Long 'Number of directories in this strPath.
Dim i As Long 'For-loop counter.
Dim n As Long
Dim arrFiles
Static strStartDirName As String
Static strpathOld As String
On Error GoTo sysFileERR
If lFileCount = 0 Then
Static collFiles As Collection
Set collFiles = New Collection
Application.Cursor = xlWait
End If
If Right$(strPath, 1) <> "\" Then
strPath = strPath & "\"
End If
If lFileCount = 0 And lDirCount = 0 Then
strStartDirName = strPath
End If
'search for subdirectories
'-------------------------
nDir = 0
ReDim arrDirNames(nDir)
strDirName = Dir(strPath, _
vbDirectory Or _
vbHidden Or _
vbArchive Or _
vbReadOnly Or _
vbSystem) 'Even if hidden, and so on.
Do While Len(strDirName) > 0
'ignore the current and encompassing directories
'-----------------------------------------------
If (strDirName <> ".") And (strDirName <> "..") Then
'check for directory with bitwise comparison
'-------------------------------------------
If GetAttr(strPath & strDirName) And vbDirectory Then
arrDirNames(nDir) = strDirName
lDirCount = lDirCount + 1
nDir = nDir + 1
DoEvents
ReDim Preserve arrDirNames(nDir)
End If 'directories.
sysFileERRCont1:
End If
strDirName = Dir() 'Get next subdirectory
DoEvents
Loop
'Search through this directory
'-----------------------------
strFileName = Dir(strPath & strSearch, _
vbNormal Or _
vbHidden Or _
vbSystem Or _
vbReadOnly Or _
vbArchive)
While Len(strFileName) <> 0
'dump file in sheet
'------------------
If bSheet Then
If lFileCount < 65536 Then
Cells(lFileCount + 1, 1) = strPath & strFileName
End If
End If
lFileCount = lFileCount + 1
collFiles.Add strPath & strFileName
If strPath <> strpathOld Then
Application.StatusBar = " " & lFileCount & _
" " & strSearch & " files found. " & _
"Now searching " & strPath
End If
strpathOld = strPath
strFileName = Dir() 'Get next file
DoEvents
Wend
If bSubFolders Then
'If there are sub-directories..
'------------------------------
If nDir > 0 Then
'Recursively walk into them
'--------------------------
For i = 0 To nDir - 1
RecursiveFindFiles strPath & arrDirNames(i) & "\", _
strSearch, _
bSubFolders, _
bSheet, _
lFileCount, _
lDirCount
DoEvents
Next
End If 'If nDir > 0
'only bare main folder left, so get out
'--------------------------------------
If strPath & arrDirNames(i) = strStartDirName Then
ReDim arrFiles(1 To lFileCount) As String
For n = 1 To lFileCount
arrFiles(n) = collFiles(n)
Next
RecursiveFindFiles = arrFiles
Application.Cursor = xlDefault
Application.StatusBar = False
End If
Else 'If bSubFolders
ReDim arrFiles(1 To lFileCount) As String
For n = 1 To lFileCount
arrFiles(n) = collFiles(n)
Next
RecursiveFindFiles = arrFiles
Application.Cursor = xlDefault
Application.StatusBar = False
End If 'If bSubFolders
Exit Function
sysFileERR:
Resume sysFileERRCont1
End Function
Function FileFromPath(ByVal strFullPath As String, _
Optional bExtensionOff As Boolean = False) _
As String
Dim FPL As Long 'len of full path
Dim PLS As Long 'position of last slash
Dim pd As Long 'position of dot before exension
Dim strFile As String
On Error GoTo ERROROUT
FPL = Len(strFullPath)
PLS = InStrRev(strFullPath, "\", , vbBinaryCompare)
strFile = Right$(strFullPath, FPL - PLS)
If bExtensionOff = False Then
FileFromPath = strFile
Else
pd = InStr(1, strFile, ".", vbBinaryCompare)
FileFromPath = Left$(strFile, pd - 1)
End If
Exit Function
ERROROUT:
On Error GoTo 0
FileFromPath = ""
End Function
Sub SearchWBsForCode()
Dim strTextToFind As String
Dim strFolder As String
Dim arr
Dim i As Long
Dim strWB As String
Dim VBProj As VBProject
Dim VBComp As VBComponent
Dim lStartLine As Long
Dim lEndLine As Long
Dim lFound As Long
Dim lType As Long
Dim lSkipped As Long
Dim oWB As Workbook
Dim bOpen As Boolean
Dim bNewBook As Boolean
strTextToFind = InputBox("Type the text to find", _
"finding text in VBE")
If Len(strTextToFind) = 0 Or StrPtr(strTextToFind) = 0 Then
Exit Sub
End If
strFolder = GetDirectory()
If Len(strFolder) = 0 Then
Exit Sub
End If
lType = Application.InputBox("Type file type to search" & _
vbCrLf & vbCrLf & _
"1. Only .xls files" & vbCrLf & _
"2. Only .xla files" & vbCrLf & _
"3. Either file type", _
"finding text in VBE", 1, Type:=1)
Select Case lType
Case 1
arr = RecursiveFindFiles(strFolder, "*.xls", True, True)
Case 2
arr = RecursiveFindFiles(strFolder, "*.xla", True, True)
Case 3
arr = RecursiveFindFiles(strFolder, "*.xl*", True, True)
Case Else
Exit Sub
End Select
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
For i = 1 To UBound(arr)
Application.StatusBar = i & "/" & UBound(arr) & _
" - Searching " & arr(i)
strWB = FileFromPath(arr(i))
On Error Resume Next
Set oWB = Workbooks(strWB)
If oWB Is Nothing Then
bOpen = False
Workbooks.Open arr(i)
Else
'for preventing closing WB's that are open already
bOpen = True
Set oWB = Nothing
End If
bNewBook = True
For Each VBComp In Workbooks(strWB).VBProject.VBComponents
If Err.Number = 50289 Then 'for protected WB's
lSkipped = lSkipped + 1
Err.Clear
GoTo PAST
End If
lEndLine = VBComp.CodeModule.CountOfLines
If VBComp.CodeModule.Find(strTextToFind, _
lStartLine, _
1, _
lEndLine, _
-1, _
False, _
False) = True Then
If bNewBook = True Then
lFound = lFound + 1
bNewBook = False
End If
Application.ScreenUpdating = True
If MsgBox("Workbook: " & arr(i) & vbCrLf & _
"VBComponent: " & VBComp.Name & vbCrLf & _
"Line number: " & lStartLine & _
vbCrLf & vbCrLf & _
"WB's found so far: " & lFound & vbCrLf & _
"Protected WB's skipped: " & lSkipped & _
vbCrLf & vbCrLf & _
"Stop searching?", _
vbYesNo + vbDefaultButton1 + vbQuestion, _
i & "/" & UBound(arr) & _
" - found " & strTextToFind) = vbYes Then
With Application
.StatusBar = False
.EnableEvents = True
.DisplayAlerts = True
End With
With VBComp.CodeModule.CodePane
.SetSelection lStartLine, 1, lStartLine, 1
.Show
End With
Exit Sub
End If
Application.ScreenUpdating = False
End If
Next
PAST:
If bOpen = False Then
Workbooks(strWB).Close savechanges:=False
End If
On Error GoTo 0
Next
On Error Resume Next
If bOpen = False Then
Workbooks(strWB).Close savechanges:=False
End If
With Application
.ScreenUpdating = True
.StatusBar = False
.EnableEvents = True
.DisplayAlerts = True
End With
MsgBox lFound & " WB's found with " & strTextToFind & " in VBE" & _
vbCrLf & vbCrLf & _
"protected WB's skipped: " & lSkipped, , _
"finding text in VBE"
End Sub

Resources