I want to download multiple files from a list of links. The website where I find the links is protected. This is why I want to use IE (using the current session/cookie). The target of each link is a xml file. The files are too large to open and then save. So I need to save them directly (right-click, save target as).
The list of links looks like this:
<html>
<body>
<p> <a href="https://example.com/report?_hhhh=XML"Link A</a><br>> </p>
<p> <a href="https://example.com/report?_aaaa=XML"Link B</a><br>> </p>
...
</body>
</html>
I want to loop through all links and save each target. Currently I have problems with the "Save As". I don't really know how to do it. This is my code so far:
Sub DownloadAllLinks()
Dim IE As Object
Dim Document As Object
Dim List As Object
Dim Link As Object
' Before I logged in to the website
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
IE.Navigate ("https:\\......\links.html")
Do While IE.Busy
DoEvents
Loop
' Detect all links on website
Set Document = IE.Document
Set List = Document.getElementsByTagName("a")
' Loop through all links to download them
For Each Link In List
' Now I need to automate "save target as" / right-click and then "save as"
...
Next Link
End Sub
Do you have any ideas to automate "Save As" for each link?
Any help is appreciated. Many thanks,
Uli
Private Declare PtrSafe Function Test 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 AutoOpen()
Dim strFile As String
Dim strURL As String
Dim strPath As String
Dim ret As Long
Dim strFile1 As String
Dim strURL1 As String
Dim strPath1 As String
Dim ret1 As Long
Dim Shex As Object
Dim Test2 As String
strFile = "1st_file"
strURL = "first-url" & strFile
strPath = Environ("UserProfile") & "your-path" & strFile
ret = Test(0, strURL, strPath, 0, 0)
strFile1 = "something_else"
strURL1 = "your-url" & strFile1
strPath1 = Environ("UserProfile") & "your-path" & strFile1
re1t = Test(0, strURL1, strPath1, 0, 0)
If ret <> 0 Then MsgBox "Something went wrong!", vbInformation
End Sub
You can use this macro to download multiple files. To download even more just duplicate this part
Dim strFile As String
Dim strURL As String
Dim strPath As String
Dim ret As Long
and this part:
strFile = "1st_file"
strURL = "first-url" & strFile
strPath = Environ("UserProfile") & "your-path" & strFile
ret = Test(0, strURL, strPath, 0, 0)
Obviously just change the variables and then you are good to go.
Below is a quite common example I adapted for your case, it shows the usage of XHR and RegEx to retrieve webpage HTML content, extract all links from it, and download each link's target file:
Option Explicit
Sub Test()
' declare vars
Dim sUrl As String
Dim sReqProt As String
Dim sReqAddr As String
Dim sReqPath As String
Dim sContent As String
Dim oLinks As Object
Dim oMatch As Object
Dim sHref As String
Dim sHrefProt As String
Dim sHrefAddr As String
Dim sHrefPath As String
Dim sHrefFull As String
Dim n As Long
Dim aContent() As Byte
' set source URL
sUrl = "https:\\......\links.html"
' process source URL
SplitUrl sUrl, sReqProt, sReqAddr, sReqPath
If sReqProt = "" Then sReqProt = "http:"
sUrl = sReqProt & "//" & sReqAddr & "/" & sReqPath
' retrieve source page HTML content
With CreateObject("Microsoft.XMLHTTP")
.Open "GET", sUrl, False
.Send
sContent = .ResponseText
End With
' parse source page HTML content to extract all links
Set oLinks = CreateObject("Scripting.Dictionary")
With CreateObject("VBScript.RegExp")
.Global = True
.MultiLine = True
.IgnoreCase = True
.Pattern = "<a.*?href *= *(?:'|"")(.*?)(?:'|"").*?>"
For Each oMatch In .Execute(sContent)
sHref = oMatch.subMatches(0)
SplitUrl sHref, sHrefProt, sHrefAddr, sHrefPath
If sHrefProt = "" Then sHrefProt = sReqProt
If sHrefAddr = "" Then sHrefAddr = sReqAddr
sHrefFull = sHrefProt & "//" & sHrefAddr & "/" & sHrefPath
oLinks(oLinks.Count) = sHrefFull
Next
End With
' save each link target into file
For Each n In oLinks
sHref = oLinks(n)
With CreateObject("Microsoft.XMLHTTP")
.Open "GET", sHref, False
.Send
aContent = .ResponseBody
End With
With CreateObject("ADODB.Stream")
.Type = 1 ' adTypeBinary
.Open
.Write aContent
.SaveToFile "C:\Test\" & n & ".xml", 2 ' adSaveCreateOverWrite
.Close
End With
Next
End Sub
Sub SplitUrl(sUrl, sProt, sAddr, sPath)
' extract protocol, address and path from URL
Dim aSplit
aSplit = Split(sUrl, "//")
If UBound(aSplit) = 0 Then
sProt = ""
sAddr = sUrl
Else
sProt = aSplit(0)
sAddr = aSplit(1)
End If
aSplit = Split(sAddr, "/")
If UBound(aSplit) = 0 Then
sPath = sAddr
sAddr = ""
Else
sPath = Mid(sAddr, Len(aSplit(0)) + 2)
sAddr = aSplit(0)
End If
End Sub
This method doesn't employ IE automation. Usually the IE's cookies which Microsoft.XMLHTTP processes are sufficient to refer to the current session, so if your website doesn't use additional procedures for authentication and generation the list of the links then the method should work for you.
Related
I managed code to create a group of tables based off of .csv files inside of a folder.
I want each of them to be a separate table so most of the concatenation posts weren't for me.
Public Function importExcelSheets(Directory As String) As Long
On Error Resume Next
Dim strDir As String
Dim strFile As String
Dim I As Long
Dim N As Long
Dim FSO As Object, MyFile As Object
Dim FileName As String, Arr As Variant
Dim Content As String
Dim objStreamIn
Dim objStreamOut
'Prepare Table names-------------------------------------------------------------------------------------
FileName = "path/to/table/names.txt"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set MyFile = FSO.OpenTextFile(FileName, 1)
Arr = Split(MyFile.ReadAll, vbNewLine)
'Verify Directory and pull a file------------------------------------------------------------------------
If Left(Directory, 1) <> "\" Then
strDir = Directory & "\"
Else
strDir = Directory
End If
strFile = Dir(strDir & "*.csv")
'Fill Tables----------------------------------------------------------------------------------------------
I = UBound(Arr) - 1
While strFile <> ""
strFile = strDir & strFile
Set objStreamIn = CreateObject("ADODB.Stream")
Set objStreamOut = CreateObject("ADODB.Stream")
objStreamIn.Charset = "utf-8"
objStreamOut.Charset = "utf-8"
objStreamIn.Open
objStreamOut.Open
objStreamIn.LoadFromFile (strFile)
objStreamOut.Open
N = 1
While Not objStreamIn.EOS
Content = objStreamIn.ReadText(-2)
If N = 1 Then
Content = Replace(Content, "/", vbNullString, , 1)
objStreamOut.WriteText Content & vbCrLf
Else
objStreamOut.WriteText Content & vbCrLf
End If
N = N + 1
Wend
objStreamOut.SaveToFile strFile, 2
objStreamIn.Close
objStreamOut.Close
Set objStreamIn = Nothing
Set objStreamOut = Nothing
DoCmd.TransferText _
TransferType:=acImportDelim, _
TableName:=Arr(I), _
FileName:=strFile, _
HasFieldNames:=True, _
CodePage:=65001
strFile = Dir()
I = I - 1
Wend
importExcelSheets = I
End Function
It works until the last section where I use TransferText to create the table.
It will get different results based on a few things I've tried:
Running the script after commenting out the entire objStream section gives me the data and table names, but the headers are [empty], "F2", "F3", ... "F27".
I suspected it was because there was a forward slash in the first column header, so I put in the Replace() to remove it.
Running the script as in above gives me an empty table.
I now suspect that the encoding header of the file is the reason for this.
Running the script after changing objStreamOut.Charset = "utf-8" to objStreamOut.Charset = "us-ascii" and updating the CodePage to 20127 gives me an empty table with black diamond question marks for a column header.
I want to blame the encoding characters but it ran one time almost flawlessly with the utf-8 encoding and CodePage 65001. Is there another way around this?
Here is the Byte Order Mark of the file showing the UTF-8 Encoding
Edit: changed CodeType to CodePage and added vbCrLf to append to Content
Edit: Included picture of Hex for files showing UTF-8 offest
With the help from Comments it looks like I got it to work after fixing the vbCrLf problem. I switched the objStreamOut charset to us-ascii and changed the CodePage to 20127 to reflect that as well. I now have headers, table names, and data working normally. Here is the final code:
Public Function importExcelSheets(Directory As String) As Long
On Error Resume Next
Dim strDir As String
Dim strFile As String
Dim I As Long
Dim N As Long
Dim FSO As Object, MyFile As Object
Dim FileName As String, Arr As Variant
Dim Content As String
Dim objStreamIn
Dim objStreamOut
'Prepare Table names-------------------------------------------------------------------------------------
FileName = "path/to/table/names.txt"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set MyFile = FSO.OpenTextFile(FileName, 1)
Arr = Split(MyFile.ReadAll, vbNewLine)
'Verify Directory and pull a file------------------------------------------------------------------------
If Left(Directory, 1) <> "\" Then
strDir = Directory & "\"
Else
strDir = Directory
End If
strFile = Dir(strDir & "*.csv")
'Fill Tables----------------------------------------------------------------------------------------------
I = UBound(Arr) - 1
While strFile <> ""
strFile = strDir & strFile
Set objStreamIn = CreateObject("ADODB.Stream")
Set objStreamOut = CreateObject("ADODB.Stream")
objStreamIn.Charset = "utf-8"
objStreamOut.Charset = "us-ascii"
objStreamIn.Open
objStreamOut.Open
objStreamIn.LoadFromFile (strFile)
objStreamOut.Open
N = 1
While Not objStreamIn.EOS
Content = objStreamIn.ReadText(-2)
If N = 1 Then
Content = Replace(Content, "/", vbNullString, , 1)
objStreamOut.WriteText Content & vbCrLf
Else
objStreamOut.WriteText Content & vbCrLf
End If
N = N + 1
Wend
objStreamOut.SaveToFile strFile, 2
objStreamIn.Close
objStreamOut.Close
Set objStreamIn = Nothing
Set objStreamOut = Nothing
DoCmd.TransferText _
TransferType:=acImportDelim, _
TableName:=Arr(I), _
FileName:=strFile, _
HasFieldNames:=True, _
CodePage:=20127
strFile = Dir()
I = I - 1
Wend
importExcelSheets = I
End Function
Still not entirely sure why VBA was not getting the correct data when I used utf-8 and 65001 for CodeType and works now for us-ascii. This will work for me however.
I am trying to make an outlook vba to download attachments from selected emails in outlook and rename them to include unique words to identify each sender. So far, I have managed to do so except for the last part.
For example,
if I receive an email from asdf#asdf.com(unique identifier: Company A) with an attachment(order.xlsx), then download the attachment and rename it to 'Company A - order.xlsx'.
It would be a great help if someone could solve this issue.
Thank you in advance!
Public Sub save_attchments()
Dim coll As VBA.Collection
Dim obj As Object
Dim Att As Outlook.attachment
Dim Sel As Outlook.Selection
Dim Path$
Dim i&
Dim itm As Outlook.MailItem
Path = "\\~~\~~\" & Format(Date, "yymmdd") & "\"
On Error Resume Next
MkDir Path
On Error GoTo 0
Set coll = New VBA.Collection
If TypeOf Application.ActiveWindow Is Outlook.Inspector Then
coll.Add Application.ActiveInspector.CurrentItem
Else
Set Sel = Application.ActiveExplorer.Selection
For i = 1 To Sel.Count
coll.Add Sel(i)
Next
End If
For Each obj In coll
For Each Att In obj.Attachments
Att.SaveAsFile Path & " - " & Att.FileName
Next
Next
Shell "Explorer.exe /n, /e, " & Path, vbNormalFocus
End Sub
Here is the code I use to save attachments from selected e-mails. I have updated it to allow a prefix addition to the file save names which you should be able to adapt to your needs. A suffix is more involved so currently omitted.
Public Sub SaveAttachmentsSelectedEmails()
Dim olItem As Outlook.MailItem
Dim olSelection As Outlook.Selection: Set olSelection = ActiveExplorer.Selection
Dim FilePath As String: FilePath = Environ("USERPROFILE") & "\Documents\Documents\Attachments"
If Dir(FilePath, vbDirectory) = "" Then
Debug.Print "Save folder does not exist"
Exit Sub
End If
For Each olItem In olSelection
SaveAttachments olItem, FilePath, RemoveAttachments:=False
Next olItem
End Sub
Private Function SaveAttachments(ByVal Item As Object, FilePath As String, _
Optional Prefix As String = "", _
Optional FileExtensions As String = "*", _
Optional Delimiter As String = ",", _
Optional RemoveAttachments As Boolean = False, _
Optional OverwriteFiles As Boolean = False) As Boolean
On Error GoTo ExitFunction
Dim i As Long, j As Long, FileName As String, Flag As Boolean
Dim Extensions() As String: Extensions = Split(FileExtensions, Delimiter)
If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"
For j = LBound(Extensions) To UBound(Extensions)
With Item.Attachments
If .Count > 0 Then
For i = .Count To 1 Step -1
FileName = FilePath & Prefix & .Item(i).FileName
Flag = IIf(LCase(Right(FileName, Len(Extensions(j)))) = LCase(Extensions(j)), True, False)
Flag = IIf(FileExtensions = "*" Or Flag = True, True, False)
If Flag = True Then
If Dir(FileName) = "" Or OverwriteFiles = True Then
.Item(i).SaveAsFile FileName
Else
Debug.Print FileName & " already exists"
Flag = False
End If
End If
If RemoveAttachments = True And Dir(FileName) <> "" And Flag = True Then .Item(i).Delete
Next i
End If
End With
Next j
SaveAttachments = True
ExitFunction:
End Function
I am creating a new database for where I work. It is creating quotes for jobs. When I click the save button its save the quote and opens a new folder which gets its name from three fields on the form. I want it to import or copy files from another folder in the directory to the newly created folder.
I have tried to use the copyfolder function and it does copy the files but to the main folder where all the quotes are held and not into the newly created folder.
On Error GoTo btnOK_Click_Error
Const strParent = "C:\Users\r.jones\Desktop\Quotes\ "
Dim Strquotenumber As String
Dim Strsite As String
Dim StrprojDesc As String
Dim strFolder As String
Dim Strspace As String
Strspace = Space(1) & "- "
Strquotenumber = Me.QuoteNumber
Strsite = Me.Txtsite
StrprojDesc = Me.Project_Description
strFolder = strParent & Strquotenumber & Strspace & Strsite & Strspace & StrprojDesc
If Dir(strFolder, vbDirectory) = "" Then MkDir strFolder
Shell "explorer.exe " & strFolder, vbNormalFocus
If Me.Dirty Then DoCmd.RunCommand acCmdSaveRecord
DoCmd.Close acForm, Me.Name
DoCmd.OpenForm "Frmquotebook"
btnOK_Click_Exit:
Exit Sub
btnOK_Click_Error:
MsgBox "Error" & " In Attempting To Create New Folder. All Fields Must Be Filled In." & vbCrLf_
Cancel = True
Resume btnOK_Click_Exit
Is it possible to do this as I have not been able to find anything on it.
Thanks for the help.
Here are some file system routines I use, wrapping the Scripting.FileSystemObject Object:
Public Function FileExists(FileName As String) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
FileExists = fso.FileExists(FileName)
End Function
Public Sub DeleteFile(FileName As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If FileExists(FileName) Then fso.DeleteFile FileName, True
End Sub
Public Sub CopyFile(Source As String, Destination As String, Optional force As Boolean = False)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If FileExists(Source) Then
fso.CopyFile Source, Destination, force
End If
End Sub
Public Sub CreateFolder(Folder As String)
Dim fso As Object
Dim Position As Integer
Dim TempFolder As String
Dim Folders As Object
Dim strArr() As String
Dim i As Integer
Position = 0
TempFolder = ""
strArr = Split(Folder, "\")
Set fso = CreateObject("Scripting.FileSystemObject")
For i = 0 To UBound(strArr)
If Not fso.FolderExists(TempFolder & strArr(i) & "\") Then
Set Folders = fso.GetFolder(TempFolder).subFolders
Folders.Add (strArr(i))
End If
TempFolder = TempFolder & strArr(i) & "\"
Next
End Sub
You will need to iterate over each file in the source directory and cop it over to the destination directory
Sub CopyFilesInDirectoryToFolder(SourceDirectory As String, DestinationDirectory As String)
Dim fileName As String
If Not Right(SourceDirectory, 1) = Application.PathSeparator Then SourceDirectory = SourceDirectory & Application.PathSeparator
If Not Right(DestinationDirectory, 1) = Application.PathSeparator Then DestinationDirectory = DestinationDirectory & Application.PathSeparator
fileName = Dir(SourceDirectory)
Do While Len(fileName) > 0
CopyFile SourceDirectory & fileName, DestinationDirectory & fileName
fileName = Dir()
Loop
End Sub
As in the Question: the task is to extract all files names from a folder, but the folder path needs to be hard coded into the macro, to prevent these dialog boxes asking me things and wasting my time.
I will not change this folder. It will be the same one until the end of time, and I want to extract the files names into the Excel column, starting from second row.
this is the folder I want to extract ALL files names from.
"C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\"
this is my portion of code:
Option Explicit
Sub GetFileNames()
Dim axRow As Long ' inside the Sheet("Lista") row#
Dim xDirectory As String
Dim xFname As String ' name of the file
Dim InitialFoldr$
Dim start As Double
Dim finish As Double
Dim total_time As Double
start = Timer
ThisWorkbook.Sheets("Lista").Range("D2").Activate
InitialFolder = "C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst"
If Right(InitialFolder, 1) <> "\" Then
InitialFolder = InitialFolder & "\"
End If
Application.InitialFolder.Show
If InitialFolder.SelectedItems.Count <> 0 Then
xDirectory = .SelectedItems(1) & "\"
xFname = Dir(xDirectory, vbArchive)
' Dir's job is to return a string representing
' the name of a file, directory, or an archive that matches a specified pattern.
Do While xFname <> "" ' there is already xFname value (1st file name) assigned.
ActiveCell.Offset(xRow) = xFname
xRow = xRow + 1 ' następny xRow
xFname = Dir()
Loop
End If
End With
finish = Timer ' Set end time.
total_time = Round(finish - start, 3) ' Calculate total time.
MsgBox "This code ran successfully in " & total_time & " seconds", vbInformation
End Sub
this is the line that crushes:
If InitialFolder.SelectedItems.Count <> 0 Then
xDirectory = .SelectedItems(1) & "\"
And two more important questions in the .png file.
Please, respond to them as well - it's very important 4 me.
Or if U guys know any other method to do this faster just don't hesitate and share Your Code with me - I'll be very grateful.
Sub Files()
Dim sht As Worksheet
Dim strDirectory As String, strFile As String
Dim i As Integer: i = 1
Set sht = Worksheets("Sheet1")
strDirectory = "C:\Users\User\Desktop\"
strFile = Dir(strDirectory, vbNormal)
Do While strFile <> ""
With sht
.Cells(i, 1) = strFile
.Cells(i, 2) = strDirectory + strFile
End With
'returns the next file or directory in the path
strFile = Dir()
i = i + 1
Loop
End Sub
See example below
Public Sub Listpng()
Const strFolder As String = "C:\SomeFolder\"
Const strPattern As String = "*.png"
Dim strFile As String
strFile = Dir(strFolder & strPattern, vbNormal)
Do While Len(strFile) > 0
Debug.Print strFile '<- view this in Immediate window; Ctrl+g will take you there
strFile = Dir
Loop
End Sub
There's a couple of procedures I use depending on whether I want subfolders as well.
This loops through the folder and adds path & name to a collection:
Sub Test1()
Dim colFiles As Collection
Dim itm As Variant
Set colFiles = New Collection
EnumerateFiles "C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\", "*.xls*", colFiles
For Each itm In colFiles
Debug.Print itm
Next itm
End Sub
Sub EnumerateFiles(ByVal sDirectory As String, _
ByVal sFileSpec As String, _
ByRef cCollection As Collection)
Dim sTemp As String
sTemp = Dir$(sDirectory & sFileSpec)
Do While Len(sTemp) > 0
cCollection.Add sDirectory & sTemp
sTemp = Dir$
Loop
End Sub
This second way goes through the subfolders as well returning path & name. For some reason if you change InclSubFolders to False it only returns the name - got to sort that bit out.
Sub Test2()
Dim vFiles As Variant
Dim itm As Variant
vFiles = EnumerateFiles_2("C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\", "xls*")
For Each itm In vFiles
Debug.Print itm
Next itm
End Sub
Public Function EnumerateFiles_2(sDirectory As String, _
Optional sFileSpec As String = "*", _
Optional InclSubFolders As Boolean = True) As Variant
EnumerateFiles_2 = Filter(Split(CreateObject("WScript.Shell").Exec _
("CMD /C DIR """ & sDirectory & "*." & sFileSpec & """ " & _
IIf(InclSubFolders, "/S ", "") & "/B /A:-D").StdOut.ReadAll, vbCrLf), ".")
End Function
I'm writing a macro to grab the current exchange rate from yahoo but I'm having trouble converting a html string into a HTMLDocument to allow me to search for the required element by id. Here is my code so far but it fails on the debug.print line.
Public Sub Forex(currency1 As String, currency2 As String)
Dim oXHTTP As Object
Dim doc As HTMLDocument
Dim url As String
Dim html As String
Dim id As String
Set oXHTTP = CreateObject("MSXML2.XMLHTTP")
url = "http://finance.yahoo.com/q?s=" & currency1 & currency2 & "=X"
oXHTTP.Open "GET", url, False
oXHTTP.send
html = oXHTTP.responseText
Set oXHTTP = Nothing
Set doc = New HTMLDocument
doc.body.innerHTML = html
id = "yfs_l10_" & currency1 & currency2
Debug.Print doc.getElementById("id").innerText
End Sub
What am I missing here?
I am making use of method from excel-vba-http-request-download-data-from-yahoo-finance:
Sub Forex(currency1 As String, currency2 As String)
Dim url As String, html As String, id As String
Dim oResult As Variant, oLine As Variant, sRate As String
url = "http://finance.yahoo.com/q?s=" & currency1 & currency2 & "=X"
id = "<span id=""yfs_l10_" & currency1 & currency2 & "=x"">"
html = GetHTTPResult(url)
oResult = Split(html, vbLf)
For Each oLine In oResult
If InStr(1, oLine, id, vbTextCompare) Then
sRate = Split(Split(oLine, "<span id=""yfs_l10_audusd=x"">")(1), "</span>")(0)
Exit For
End If
Next
End Sub
Function GetHTTPResult(sURL As String) As String
Dim XMLHTTP As Variant, sResult As String
Set XMLHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
XMLHTTP.Open "GET", sURL, False
XMLHTTP.send
sResult = XMLHTTP.responseText
Set XMLHTTP = Nothing
GetHTTPResult = sResult
End Function
You're almost there, you just have the id wrong:
id = "yfs_l10_" & currency1 & currency2 & "=X"
Debug.Print doc.getElementById(id).innerText