I tried to download the image from the URL and it worked normally.
but if it is run on a 64 bit computer then an error message
"Compile error in hidden module: Module 10.
This error commonly occurs when code is incompatible with the version,platform"
I don't know what to do, any ideas?
this is my code
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
Sub Download()
Dim strPath As String
Dim FolderName As String
Dim x As Integer
Dim i As Long
Dim sData As Worksheet: Set sData = Sheets("Sheet17")
Application.DisplayAlerts = False
FolderName = "C:\Try"
With sData
For i = 1 To 100
For x = 5 To 12
Application.Calculation = xlCalculationManual
If Sheet17.Cells(i, x).Value <> "" Then
strPath = FolderName & "\" & i & "-" & x - 4 & ".jpg"
Ret = URLDownloadToFile(0, Sheet17.Cells(i, x).Value, strPath, 0, 0)
End If
Next x
Next i
Application.Calculation = xlCalculationAutomatic
End With
Application.DisplayAlerts = True
End Sub
Related
I created a macro for a file and first it was working fine, but today I've been opening and restarting the file and macro hundreds of times and I'm always getting the following error:
Excel VBA Run-time error '13' Type mismatch
I didn't change anything in the macro and don't know why am I getting the error. Furthermore it takes ages to update the macro every time I put it running (the macro has to run about 9000 rows).
ERROR is somewhere "FileData = WHTTP.ResponseBody"
Sub Test2()
Dim A As Long
Dim FileNum As Long
Dim FileData() As Byte
Dim MyFile As String
Dim WHTTP As Object
On Error Resume Next
Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5")
If Err.Number <> 0 Then
Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5.1")
End If
On Error GoTo 0
If Dir("C:\MyDownloads", vbDirectory) = Empty Then MkDir "C:\MyDownloads"
For A = 1 To 228
MyFile = Cells(A, 1).Text
TempFile = Right(MyFile, InStr(1, StrReverse(MyFile), "/") - 1)
WHTTP.Open "GET", MyFile, False
WHTTP.Send
FileData = WHTTP.ResponseBody
FileNum = FreeFile
Open "C:\MyDownloads\" & TempFile For Binary Access Write As #FileNum
Put #FileNum, 1, FileData
Close #FileNum
Next
Set WHTTP = Nothing
MsgBox "Open the folder [ C:\MyDownloads ] for the downloaded file..."
End Sub
Put On Error Resume Next above the line causing an error (probably this line WHTTP.Send). Put this block of code after your line with an error.
Files/Web Addresses/Registry keys - YOU MUST ASSUME IT MAY NOT WORK and trap errors so you know why (and where it's not working). Usually these are not programming questions.
If err.number <> 0 then
ERRString = ErrString & ""
ERRString = ErrString & "Error getting file"
ERRString = ErrString & "=================="
ERRString = ErrString & ""
ERRString = ErrString & "Error " & err.number & "(0x" & hex(err.number) & ") " & err.description
ERRString = ErrString & "Source " & err.source
ERRString = ErrString & ""
ERRString = ErrString & "HTTP Error " & WHTTP.Status & " " & WHTTP.StatusText
ERRString = ErrString & WHTTP.getAllResponseHeaders
Msgbox ErrString
End If
Just download direct using API call and URL
Option Explicit
#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
Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "Wininet.dll" _
Alias "DeleteUrlCacheEntryA" ( _
ByVal lpszUrlName As String _
) 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
Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" _
Alias "DeleteUrlCacheEntryA" ( _
ByVal lpszUrlName As String _
) As Long
#End If
Public Const BINDF_GETNEWESTVERSION As Long = &H10
Public Const folderName As String = "C:\Users\User\Desktop\Blah.zip" '<== Change to destination
Public Sub downloadIFolder()
Dim ret As Long
ret = URLDownloadToFile(0, "http://www.bseindia.com/BSEDATA/margins/VAR290716.zip", folderName, BINDF_GETNEWESTVERSION, 0)
MsgBox ret
End Sub
#If Win64 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" _
(ByRef pCaller As LongPtr, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserve As Long, _
ByRef lpfnCB As LongPtr) _
As LongPtr
#Else
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" _
(ByRef pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserve As Long, _
ByRef lpfnCB As Long) _
As Long
#End If
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
EndSub
enter image description here
Error is given below:
After correcting the parameter in the API function, this is what I used.
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
Const FolderName As String = "C:\Temp\"
Sub Sample()
Dim ws As Worksheet
Dim LastRow As Long, i As Long
Dim strPath As String
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
To have the file path if the download was successfull, try it.
So if the file is downloaded successfully the path will be placed in column C and the msg "File successfully downloaded" in column D otherwise column C will contain "Unable to download the file".
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 = strPath
ws.Range("D" & i).Value = "File successfully downloaded"
Else
ws.Range("C" & i).Value = "Unable to download the file"
End If
Next i
This worked for me. For more info have a look e.g. here.
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
Const FolderName As String = "C:\Temp"
Sub Sample()
Dim Ret As Long
Dim ws As Worksheet
Dim LastRow As Long, i As Long
Dim strPath As String
Dim urlFileName As String
Set ws = Sheets("Sheet1")
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
strPath = FolderName & "\" & ws.Range("A" & i).Value & ".jpg"
urlFileName = ws.Range("B" & i).Value
Ret = URLDownloadToFile(0, urlFileName, 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
Data on Sheet
HeaderA | HeaderB
SomeImage1 | http://www.someaddress.com/Imgs/SomeImage1.jpg
Hello can you help me please with code in VBA ? I would like create a log file from text in cells ("C2" and "C3 " + date and time ) when I press button "zadat" Thank you
My code for implementation is:
Module 1
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub zadat()
Dim reg, check As String
Dim i, j, done As Integer
reg = Cells(2, 3).Value
check = Cells(4, 3).Value
If check = "True" Then
i = 2
j = 1
done = 0
Do While Sheets("data").Cells(i, j) <> ""
If Sheets("data").Cells(i, j) = reg Then
vytisteno = ZkontrolovatAVytiskoutSoubor()
done = Sheets("data").Cells(i, j + 3)
done = done + 1
Sheets("data").Cells(i, j + 3) = done
Exit Do
End If
i = i + 1
Loop
Else
MsgBox ("Opravit, špatný štítek!!!")
End If
Cells(3, 3) = ""
Cells(3, 3).Select
ActiveWindow.ScrollRow = Cells(1, 1).row
End Sub
Module 2:
Option Explicit
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
Public Function ZkontrolovatAVytiskoutSoubor() As Boolean
Dim printThis
Dim strDir As String
Dim strFile As String
strDir = "W:\Etikety\Štítky\Krabice\Testy"
strFile = Range("C2").Value & ".lbe"
If Not FileExists(strDir & "\" & strFile) Then
MsgBox "soubor neexistuje!"
ZkontrolovatAVytiskoutSoubor = False
Else
printThis = PrintThisDoc(0, strDir & "\" & strFile)
ZkontrolovatAVytiskoutSoubor = True
End If
End Function
Private Function FileExists(fname) As Boolean
'Returns TRUE if the file exists
Dim x As String
x = Dir(fname)
If x <> "" Then FileExists = True _
Else FileExists = False
End Function
If you don't want to use FSO, there is a simple solution using only VBA statements: Open, Print # and Close:
Sub Log2File(Filename As String, Cell1, Cell2)
Dim f As Integer
f = FreeFile
Open Filename For Append Access Write Lock Write As #f
Print #f, Now, Cell1, Cell2
Close #f
End Sub
I've put the filename and the cells refs as arguments of the sub for re-usability purpose. I also use default (local) formatting, but this can be easily changed.
Note that you don't have to check for existence of the file, it will be created if it doesn't exist.
Try this. Below code will create a new log file every time
Public Function LogDetails()
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim logFile As Object
Dim logFilePath As String
Dim logFileName As String
'Replace 'TestLog' with your desired file name
logFileName = "TestLog" & ".txt"
myFilePath = "C:\Users\..\Desktop\" & logFileName 'Modify the path here
If fso.FileExists(myFilePath) Then
Set logFile = fso.OpenTextFile(myFilePath, 8)
Else
' create the file instead
Set logFile = fso.CreateTextFile(myFilePath, True)
End If
logFile.WriteLine "[" & Date & " " & Time & "] " & Worksheet("yoursheetnamehere").Cells(2, 3) & " " & Worksheet("yoursheetnamehere").Cells(3, 3)
logFile.Close ' close the file
End Function
In VBA, I have a function that opens a text file. This allows me to place a button on a form and have it show a file when clicked.
The function works fine, however the aforementioned button is clicked multiple times, it will open the same document over and over, rather than just the once.
How can I make it so that a file is only opened once?
Sub OpenTextFile(ByVal filePath As String)
If Len(Dir(filePath)) = 0 Then Exit Sub ' Ensure that the file to open actaully exists
Dim txtFile As Variant
txtFile = Shell("C:\WINDOWS\notepad.exe " & filePath, 1)
End Sub
First check if a Shell ID has previously been assigned to the Workbooks .CustomDocumentProperties property. If it has, then we need to check if that Shell ID instance is still open. We can do that by using the Shell ID and passing it into the WHERE clause of a query against Win32_Process.
If there is no Shell ID assigned to the property, we can go straight to opening the text file. Once we open the text file, we update the .CustomDocumentProperties Property with the new text file Shell ID.
Option Explicit
Sub OpenTextFile()
Dim filePath As String
Dim txtFile As Long
Dim txtOpenCount As Integer
Dim wb As Workbook
Dim wmiService As Object, winQry As Object
Set wb = ThisWorkbook
On Error Resume Next
txtFile = CLng(wb.CustomDocumentProperties("txtFileNum"))
If Err.Number = 0 Then '' If CustomDocumentProperty returned _
without an error then use this to close txt file.
Set wmiService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" _
& ".\root\cimv2")
Set winQry = wmiService.ExecQuery _
("SELECT * from Win32_Process WHERE ProcessID = " & txtFile)
txtOpenCount = winQry.Count
End If
On Error GoTo 0
If txtOpenCount = 0 Then '' If the txtFile is not found, then open.
filePath = "F:\test.txt"
If txtFile > 0 Then
wb.CustomDocumentProperties("txtFileNum").Delete
End If
txtFile = Shell("C:\WINDOWS\notepad.exe " & filePath, vbNormalFocus)
'' Update CustomDocumentProperty with the new txtFile number.
wb.CustomDocumentProperties.Add Name:="txtFileNum", _
Value:=txtFile, _
LinkToContent:=False, _
Type:=msoPropertyTypeString
End If
End Sub
If you are in Access, you can take advantage of the .CreateProperty method, and then the .Properties.Append method. You have to pass the property created from .CreateProperty into the .Properties.Append method. Updated code below.
Option Explicit
Sub OpenTextFile()
Dim filePath As String
Dim txtFile As Long, oTxt As Object
Dim txtOpenCount As Integer
Dim db As Database
Dim wmiService As Object, winQry As Object
Set db = CurrentDb
On Error Resume Next
txtFile = db.Properties("txtFileNum").Value
If Err.Number = 0 Then '' If CustomDocumentProperty returned _
without an error then use this to close txt file.
Set wmiService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" _
& ".\root\cimv2")
Set winQry = wmiService.ExecQuery _
("SELECT * from Win32_Process WHERE ProcessID = " & txtFile)
txtOpenCount = winQry.Count
End If
On Error GoTo 0
If txtOpenCount = 0 Then '' If the txtFile is not found, then open.
filePath = "F:\test.txt"
If txtFile > 0 Then
db.Properties.Delete "txtFileNum"
End If
txtFile = Shell("C:\WINDOWS\notepad.exe " & filePath, vbNormalFocus)
'' Update db Properties with the new txtFile number.
Set oTxt = db.CreateProperty("txtFileNum", dbLong, txtFile, False)
db.Properties.Append oTxt
End If
End Sub
If you need it. Here is a function to see if notepad is running.
Declare these up top.
Private Declare Function OpenProcess Lib "kernel32" ( _
ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
ByVal hObject As Long) As Long
Private Declare Function EnumProcesses Lib "PSAPI.DLL" ( _
lpidProcess As Long, ByVal cb As Long, cbNeeded As Long) As Long
Private Declare Function EnumProcessModules Lib "PSAPI.DLL" ( _
ByVal hProcess As Long, lphModule As Long, ByVal cb As Long, lpcbNeeded As Long) As Long
Private Declare Function GetModuleBaseName Lib "PSAPI.DLL" Alias "GetModuleBaseNameA" ( _
ByVal hProcess As Long, ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long
Private Const PROCESS_VM_READ = &H10
Private Const PROCESS_QUERY_INFORMATION = &H400
Then send this the process name. b = IsProcessRunning("notepad.exe")
Private Function IsProcessRunning(ByVal sProcess As String) As Boolean
'Check to see if a process is currently running
Const MAX_PATH As Long = 260
Dim lProcesses() As Long
Dim lModules() As Long
Dim N As Long
Dim lRet As Long
Dim hProcess As Long
Dim sName As String
sProcess = UCase$(sProcess)
ReDim lProcesses(1023) As Long
If EnumProcesses(lProcesses(0), 1024 * 4, lRet) Then
For N = 0 To (lRet \ 4) - 1
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, lProcesses(N))
If hProcess Then
ReDim lModules(1023)
If EnumProcessModules(hProcess, lModules(0), 1024 * 4, lRet) Then
sName = String$(MAX_PATH, vbNullChar)
GetModuleBaseName hProcess, lModules(0), sName, MAX_PATH
sName = Left$(sName, InStr(sName, vbNullChar) - 1)
If sProcess = UCase$(sName) Then
IsProcessRunning = True
Exit Function
End If
End If
End If
CloseHandle hProcess
Next N
End If
End Function
I am currently using this code using the developer console to try to mass download all of the images off the hyperlinks I have in my excel document.
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
It seems that it will download the images if the pic name column I have in column A is something like this - "calculator.jpg"
However, I would like the picture name to be the hyperlink I am using to download the images, aka something like www.hyperlink.com/calculator.jpg
My code seems to not download the images when the hyperlink is in the picture name column, even though it does print in column C "download successful."
If someone could help me I would really appreciate it!
However, I would like the picture name to be the hyperlink I am using to download the images, aka something like www.hyperlink.com/calculator.jpg
Like I said in the comments above, "You can't have the pic name as hyperlink as "/" is not a valid character for a file name. You have to extract "calculator.jpg" from col A and then use it in the code"
Is this what you are trying?
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 = "D:\Temp\"
Sub Sample()
Dim ws As Worksheet
Dim LastRow As Long, i As Long
Dim strPath As String
Dim MyAr
'~~> 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
MyAr = Split(ws.Range("A" & i).Value, "/")
'~~> C:\Temp\Calculator.jpg
strPath = FolderName & MyAr(UBound(MyAr))
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