I'm trying to download(crawling) image in VBA.
I'm using "winhttp" for this.
Public Function WebFileDownload(ByVal strURL As String, ByVal strFileName As String) As Boolean
Dim Buf() As Byte, oWinHttp
On Error GoTo Err_Sub
Set oWinHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
With oWinHttp
.Open "GET", strURL, 0
.Send
Buf = .ResponseBody
End With
Open ThisWorkbook.Path & "\" & strFileName For Binary Access Write As #1
Put #1, , Buf
Close #1
Set oWinHttp = Nothing
WebFileDownload = True
Err_Sub:
If Err Then MsgBox Err.Description
If Not oWinHttp Is Nothing Then Set oWinHttp = Nothing
End Function
Unfortunately, After download 20-30 files. Server change the speed very slow. I think It detect by bot. I'm using VBA, So I don't know How to avoid this. I wrote sleep time randomly, But it is not work well. Is there any tip?
Related
I am trying to directly open an axf file in excel and then using my other functions I format the data. The problem I am having is sometimes the file opens without any delay and sometimes it never open and hangs the excel.
Sub Workbook_Open()
Dim OriginalSecuritySetting As MsoAutomationSecurity
sCSVLink = "http://www.bom.gov.au/fwo/IDQ60801/IDQ60801.99367.axf"
sfile = "IDQ60801.99367.axf"
ssheet = "Hay_Point_Data"
Set wnd = ActiveWindow
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets(ssheet).Cells.ClearContents
OriginalSecuritySetting = Application.AutomationSecurity
Application.AutomationSecurity = msoAutomationSecurityForceDisable
Workbooks.Open Filename:=sCSVLink
End Sub
Please advise how can I make it to run every time. Thanks
You need something like this: How do I download a file using VBA (without Internet Explorer)
Answered by Ole Henrik Skogstrøm
To open the same file, you need to import the data type, in this way, it is possible to identify the workbook and finish its adjustments.
Good Luck
Sub DownloadFile()
Dim myURL As String
Dim SrtPath As String
Dim SrtFile As String
myURL = "http://www.bom.gov.au/fwo/IDQ60801/IDQ60801.99367.axf"
Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False, "username", "password"
WinHttpReq.send
SrtPath = ActiveWorkbook.Path & "\" & "IDQ60801.yourname.axf"
If WinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.SaveToFile SrtPath, 2 ' 1 = no overwrite, 2 = overwrite
oStream.Close
End If
Workbooks.Open Filename:=SrtPath
End Sub
I have searched inside a folder in outlook, found all emails with a defined title, and downloaded their attachments into a folder via Excel VBA.
I now need to print those to new pdfs via Adobe Reader XI through VBA - as they are password protected- to be able to convert to RFT (I use VBA to get data from the PDF converted to RFT).
Somehow the correct RF layout is only created if the already saved pdf file is printed to a secondary pdf- Saving doesn't work - whether by explorer pdf viewer, Nitro or Adobe makes no difference.
I have tried Attachment.Printout but get error that the object does not support, am not able to find the option within a Shellexecute that will allow printing to file, as the main advice online allows printing via:
Call apiShellExecute(Application.hwnd, "print", strPathAndFilename, vbNullString, vbNullString, 0)
with options /p and /h for printing. any help on how to accomplish this with or without shell (or directly convert secured pdf to rft is appreciated).
The code I use ( borrowed and edited from VBA to loop through email attachments and save based on given criteria) for automatically downloading the files is listed bellow:
Sub email234()
Application.ScreenUpdating = False
Dim sPSFileName As String
Dim sPDFFileName As String
Dim olApp As Object
Dim ns As Namespace
Set olApp = CreateObject("Outlook.Application")
Set ns = olApp.GetNamespace("MAPI")
Dim oItem As Object
Dim olMailItem As Outlook.MailItem
Dim olNameSpace As Object
Dim olFolder As Object
Dim olFolderName As String
Dim olAtt As Outlook.Attachments
Dim strName As String
Dim sPath As String
Dim i As Long
Dim j As Integer
Dim olSubject As String
Dim olSender As String
Dim sh As Worksheet
Dim LastRow As Integer
olFolderName = "\\Subscriptions\Inbox" 'ThisWorkbook.Worksheets("Control").Range("D10")
olSender = "Argus Alerts" 'ThisWorkbook.Worksheets("Control").Range("D16")
sPath = Application.FileDialog(msoFileDialogFolderPicker).Show
sPathstr = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
Set olNameSpace = olApp.GetNamespace("MAPI")
'check if folder is subfolder or not and choose olFolder accordingly
Set olFolder = ns.Folders("Subscriptions").Folders("Inbox")
strName = "Argus Ammonia"
h = 2
For i = 1 To olFolder.Items.Count
If olFolder.Items(i).Class <> olMail Then
Else
Set olMailItem = olFolder.Items(i)
'check if the search name is in the email subject
'If (InStr(1, olMailItem.Subject, olSubject, vbTextCompare) <> 0) Then
If (InStr(1, olMailItem.Sender, olSender, vbTextCompare) <> 0) Then
With olMailItem
For j = 1 To .Attachments.Count
strName = .Attachments.Item(j).DisplayName
'check if file already exists
If Not Dir(sPathstr & "\" & strName) = vbNullString Then
strName = "(1)" & strName
Else
End If
If Err.Number <> 0 Then
Else
.Attachments(j).SaveAsFile sPathstr & "\" & strName
End If
Err.Clear
Set sh = Nothing
'wB.Close
On Error GoTo 0
h = h + 1
Next j
End With
End If
End If
Next i
Application.ScreenUpdating = True
MsgBox "Download complete!", vbInformation + vbOKOnly, "Done"
End Sub
You can hard code the path to your EXE, please refer to the below code:
Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" _
(ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
Sub Test_Printpdf()
Dim fn$
fn = "C:\Users\Ken\Dropbox\Excel\pdf\p1.pdf"
PrintPDf fn
End Sub
Sub PrintPDf(fn$)
Dim pdfEXE$, q$
pdfEXE = ExePath(fn)
If pdfEXE = "" Then
MsgBox "No path found to pdf's associated EXE.", vbCritical, "Macro Ending"
Exit Sub
End If
q = """"
'http://help.adobe.com/livedocs/acrobat_sdk/10/Acrobat10_HTMLHelp/wwhelp/wwhimpl/common/html/wwhelp.htm?context=Acrobat10_SDK_HTMLHelp&file=DevFAQ_UnderstandingSDK.22.31.html
'/s/o/h/p/t
Shell q & pdfEXE & q & " /s /o /h /t " & q & fn & q, vbHide
End Sub
Function ExePath(lpFile As String) As String
Dim lpDirectory As String, sExePath As String, rc As Long
lpDirectory = "\"
sExePath = Space(255)
rc = FindExecutable(lpFile, lpDirectory, sExePath)
sExePath = Left$(sExePath, InStr(sExePath, Chr$(0)) - 1)
ExePath = sExePath
End Function
Sub Test_ExePath()
MsgBox ExePath(ThisWorkbook.FullName)
End Sub
Added an API method to find the path, the command line parameters don't work as well with the newer Adobe Acrobat Reader DC.
For more information, please refer to these links:
Printing a file using VBA code
Print a PDF file using VBA
I'm a beginner at coding. So I would like to know how I could use nesting to code a macro (for VBA Word) that runs multiple other macros in all documents in a specified folder. I am trying to employ nesting by having the outer loop open all the documents in a folder (a user will input the location of the folder using InputBox), and within this loop, all the macros will be applied.
So far I know that this is what works perfectly (the code opens all documents in the specified folder);
Sub nestingMacro()
Dim currentFile As String
Dim location As String
location = InputBox("Location of folder")
If Right(location, 1) <> "\" Then location = location + "\"
currentFile = Dir(location & "*.doc*")
Do While (currentFile <> "")
Documents.Open FileName:=location & currentFile
currentFile = Dir()
Loop
End Sub
I tried adding the following;
Sub nestingMacro()
Dim currentFile As String
Dim location As String
location = InputBox("Location of folder")
If Right(location, 1) <> "\" Then location = location + "\"
currentFile = Dir(location & "*.doc*")
Do While (currentFile <> "")
Documents.Open FileName:=location & currentFile
currentFile = Dir()
If currentFile <> "" Then
'the name of the macros below
Call findReplaceStyle
Call countErrorsQuality
Call saveClose
End If
Loop
End Sub
Yes, it opens all documents in a folder, however, it runs the macros only on two of the documents then nothing happens to the others. How can I solve this?
Is there a better way to write the function IF, in order to run the macros on all documents using nesting?
Also is there a way to run the macros without actually calling their names?
Thank you!
You don't need if statement.
Sub nestingMacro()
Dim currentFile As String
Dim location As String
location = InputBox("Location of folder")
If Right(location, 1) <> "\" Then location = location + "\"
currentFile = Dir(location & "*.doc*")
Do While (currentFile <> "")
Documents.Open FileName:=location & currentFile
Call findReplaceStyle
Call countErrorsQuality
Call saveClose
currentFile = Dir()
Loop
End Sub
You don't need nesting for what you've described so far. If the code is only running on a few files in the folder, that's most likely because you're running the code from a document stored in the same folder and, as soon as it processes itself, it gets closed and that kills the macro. Try something along the lines of the following.
Sub Demo()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc as Document
strDocNm = ActiveDocument.Fullname
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc*", vbNormal)
While strFile <> ""
If strFolder & "\" & strFile <> strDocNm Then
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
Call findReplaceStyle
Call countErrorsQuality
Call saveClose
End If
strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
A potential problem with your
Call findReplaceStyle
Call countErrorsQuality
lines is that you're not passing the document you've just opened as a parameter. If anything in those subs changes the activedocument, you could run into problems. It's good coding practice to pass the document you want to process as a parameter, as in:
Call findReplaceStyle(wdDoc)
Call countErrorsQuality(wdDoc)
Drawing on your previous thread on a related topic, to accept and use such a parameter, the latter sub might be coded along the lines of:
Sub countErrorsQuality(wdDoc As Document)
Dim Rng As Range
With wdDoc
Set Rng = .Range(0, 0)
If .SpellingErrors.Count > 0 Then
With Rng
.Text "REJECTED" & vbCr
.Font.Size = 14
.Font.ColorIndex = wdRed
.Font.Bold = True
End With
End If
End With
Set Rng = Nothing
End Sub
Note that nothing gets selected. This reduces screen flicker and makes the code run faster.
I likewise suspect you don't need your
Call saveClose
code and all you really need is:
wdDoc.Close SaveChanges:=True
Asking users to identify the folder where they want certain files to be saved, then save new workbooks to that folder. Sub calls the Function that sets this folder path to JobFolder. When calling JobFolder folder path from sub, the sub runs the Function all over again. Just need the value of JobFolder. Thank you.
Sub ExportJobFiles()
'Ask user to set job folder
Dim JobFolder As String
JobFolder = GetFolder()
'Ask user to set suffix for file names
Dim FileNameSuffix As Variant
Dim Default As String
Default = Worksheets("Summary").Range("E2").Value
FileNameSuffix = InputBox("Input suffix for job files", , Default)
'Creates job files in job folder
Dim SummaryFileName As String
Dim AFileName As String
Dim BFileName As String
Dim CFileName As String
SummaryFileName = JobFolder & "/Summary_" & FileNameSuffix & ".xls"
AFileName = JobFolder & "/A_" & FileNameSuffix & ".xls"
BFileName = JobFolder & "/B_" & FileNameSuffix & ".xls"
CFileName = JobFolder & "/C_" & FileNameSuffix & ".xls"
Workbooks.Add.SaveAs FileName:=SummaryFileName
Workbooks.Add.SaveAs FileName:=AFileName
Workbooks.Add.SaveAs FileName:=BFileName
Workbooks.Add.SaveAs FileName:=CFileName
End Sub
Function GetFolder() As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = ""
.Show
GetFolder = .SelectedItems(1)
End With
End Function
Call JobFolder
That's calling the function (with an obsolete explicit call syntax) and discarding its return value.
Basically, that line does nothing useful.
Instead, declare a local variable:
Dim folder As String
And assign it with the function's return value:
folder = JobFolder
As noted in comments, you should also avoid GoTo jumps in or out of With blocks.
If the With block was written like this:
With Application.FileDialog(msoFileDialogFolderPicker)
'...
End With
Then jumping out of it would leave the object reference held by the With block in limbo. The only reason that's not happening with your code is because you already have a reference to the With block variable outside the With block, and you're destroying it manually... which isn't necessary if you let the With block handle the reference.
Im seeking for help as i have a bulk of links to check if the link is broken i have tried the below macro but it works twice and after that it is no longer working i am using ms office 10 64bit i would like to add on the macro if macro
can check the image resolution for example if i paste url on column A it will highlight the broken links and on column b it will show the image resolution
Sub Audit_WorkSheet_For_Broken_Links()
If MsgBox("Is the Active Sheet a Sheet with Hyperlinks You Would Like to Check?", vbOKCancel) = vbCancel Then
Exit Sub
End If
On Error Resume Next
For Each alink In Cells.Hyperlinks
strURL = alink.Address
If Left(strURL, 4) <> "http" Then
strURL = ThisWorkbook.BuiltinDocumentProperties("Hyperlink Base") & strURL
End If
Application.StatusBar = "Testing Link: " & strURL
Set objhttp = CreateObject("MSXML2.XMLHTTP")
objhttp.Open "HEAD", strURL, False
objhttp.Send
If objhttp.statustext <> "OK" Then
alink.Parent.Interior.Color = 255
End If
Next alink
Application.StatusBar = False
On Error GoTo 0
MsgBox ("Checking Complete!" & vbCrLf & vbCrLf & "Cells With Broken or Suspect Links are Highlighted in RED.")
End Sub
Edit: I changed your macro to declare variables properly and release objects upon macro completion; this should address any potential memory issues. Please try this code and let me know if it works.
Sub Audit_WorkSheet_For_Broken_Links()
If MsgBox("Is the Active Sheet a Sheet with Hyperlinks You Would Like to Check?", vbOKCancel) = vbCancel Then
Exit Sub
End If
Dim alink As Hyperlink
Dim strURL As String
Dim objhttp As Object
On Error Resume Next
For Each alink In Cells.Hyperlinks
strURL = alink.Address
If Left(strURL, 4) <> "http" Then
strURL = ThisWorkbook.BuiltinDocumentProperties("Hyperlink Base") & strURL
End If
Application.StatusBar = "Testing Link: " & strURL
Set objhttp = CreateObject("MSXML2.XMLHTTP")
objhttp.Open "HEAD", strURL, False
objhttp.Send
If objhttp.statustext <> "OK" Then
alink.Parent.Interior.Color = 255
End If
Next alink
Application.StatusBar = False
'Release objects to prevent memory issues
Set alink = Nothing
Set objhttp = Nothing
On Error GoTo 0
MsgBox ("Checking Complete!" & vbCrLf & vbCrLf & "Cells With Broken or Suspect Links are Highlighted in RED.")
End Sub
Old Answer Below
Combining your macro (which seems to be from here) with an alternative found on excelforum yields the below code. Give it a try and let me know if it works for you.
Sub TestHLinkValidity()
Dim rRng As Range
Dim fsoFSO As Object
Dim strPath As String
Dim cCell As Range
If MsgBox("Is the Active Sheet a Sheet with Hyperlinks You Would Like to Check?", vbOKCancel) = vbCancel Then
Exit Sub
End If
Set fsoFSO = CreateObject("Scripting.FileSystemObject")
Set rRng = ActiveSheet.UsedRange.Cells
For Each cCell In rRng.Cells
If cCell.Hyperlinks.Count > 0 Then
strPath = GetHlinkAddr(cCell)
If fsoFSO.FileExists(strPath) = False Then cCell.Interior.Color = 65535
End If
Next cCell
End Sub
Function GetHlinkAddr(rngHlinkCell As Range)
GetHlinkAddr = rngHlinkCell.Hyperlinks(1).Address
End Function