Save a picture to disk

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

I have a form with a MS Web Browser ActiveX control that displays a picture
from a URL that's stored in my database.

If I want to save a particular picture to disk, I have to right-click on the
pic, select Save Picture As and then give it a filename. Can that right-click
menu procedure be automated, or is there another way I could save the picture
with VBA?

Thanks much for any assistance.

JBHansen
 
If the form is bound to a table etc. containing a field with the full file
path then you could use the FileSystemObject to copy the file to a new
location like this:

Private Function CopyFile(ByVal strDirectory, ByVal strFileOriginal As String)
As String
'Copy source file (strFileOriginal) to destination folder (strDirectory).
On Error GoTo Err_CopyFile
Dim fsoCurrent As FileSystemObject
Dim fOriginal As File
Dim strFileCopy As String

Set fsoCurrent = New FileSystemObject
Set fOriginal = fsoCurrent.GetFile(strFileOriginal)
'Create file copy path.
strFileCopy = strDirectory & "\" & fOriginal.Name
fOriginal.Copy strFileCopy
'Return new file path.
CopyFile = strFileCopy

Exit_CopyFile:
'Close reference variables.
Set fOriginal = Nothing
Set fsoCurrent = Nothing
Exit Function

Err_CopyFile:
MsgBox "CopyFile Error: " & Err.Number & ": " & Err.Description
Resume Exit_CopyFile
End Function

Regards

Ian
 
Thanks Ian.

I'm getting a "file not found" error 53 on the line
Set fOriginal = fsoCurrent.GetFile(strFileOriginal)

Here's the cmd code I'm using to run the function. 'Pic' is the bound field
containing the full URL of the picture (it's online). Am I calling the
function incorrectly?

Private Sub cmdSavePic_Click()
strDirectory = "C:\Documents and Settings\All Users\Desktop\ms pics\"
strFileOriginal = Pic
CopyFile strDirectory, strFileOriginal
End Sub

Thanks so much for your help. If I can get this working it will be a huge
timesaver.
JBHansen
 
Sorry JB, I'd assumed that you'd be using absolute file paths re local or
network files. Passing a URL to the FileSystemObject just won't work.
However if you write this in the declarations section of a general module:
.....
Option Compare Database

Public Declare Function IsValidURL Lib "URLMON.DLL" (ByVal pbc As Long, ByVal
szURL As String, ByVal dwReserved As Long) As Long
Public Declare Function URLDownloadToFile Lib "URLMON.DLL" Alias
"URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal
szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Public Enum HRESULT
S_OK = &H0
S_FALSE = &H1
E_NOTIMPL = &H80004001
E_INVALIDARG = &H80070057
E_NOINTERFACE = &H80004002
E_FAIL = &H80004005
E_UNEXPECTED = &H8000FFFF
End Enum
....

Add these functions:

Public Function IsURL(ByVal URL As String) As Integer
'***Return -1 if passed URL is valid.***
On Error GoTo Err_IsURL

'Covert to unicode string
URL = StrConv(URL, vbUnicode)
Select Case IsValidURL(ByVal 0&, URL, 0)
Case S_OK
IsURL = -1
Case S_FALSE
IsURL = 0
Case Else
FormattedMsgBox "Cannot validate URL@Please check input
parameters and internet connection@", vbInformation
IsURL = 1
End Select

Exit_IsURL:
Exit Function

Err_IsURL:
MsgBox "IsURL Error: " & Err.Number & ": " & Err.Description
IsURL = 1
Resume Exit_IsURL
End Function

Public Function GetFileURL(ByVal FilePath As String) As String
'***Get URL from FilePath.***
On Error GoTo Err_GetFileURL
Dim strCharacter As String
Dim strFile As String
Dim strFolder As String
Dim intCharacter As Integer

If Len(FilePath) > 0 Then
'If local file FilePath passed parse string.
If InStr(FilePath, "\") > 0 Then
If (Left(FilePath, 7) = "file://") And Not (Left(FilePath, 8) =
"file:///") Then
FilePath = Replace(FilePath, "file://", "file:///")
Else
FilePath = "file:///" & FilePath
End If
FilePath = Replace(FilePath, "\", "/")
End If
FilePath = Replace(FilePath, " ", "%20")
GetFileURL = FilePath
End If

Exit_GetFileURL:
Exit Function

Err_GetFileURL:
MsgBox "GetFileURL Error: " & Err.Number & ": " & Err.Description
Resume Exit_GetFileURL
End Function

Public Function CopyURLFile(ByVal URL As String, ByVal strDirectory) As
String
'***Create URL File.***
On Error GoTo Err_CopyURLFile
Dim strCharacter As String
Dim strFile As String
Dim intCharacter As Integer

If Len(URL) > 0 Then
URL = GetFileURL(URL) 'If local file path passed URL is returned.
For intCharacter = Len(URL) To 1 Step -1
strCharacter = Mid(URL, intCharacter, 1)
If strCharacter = "/" Then
Exit For
End If
strFile = strCharacter & strFile
Next intCharacter
strFile = strDirectory & "\" & strFile
If IsURL(FilePath) Then
URLDownloadToFile 0, URL, strFile, 0, 0
CopyURLFile = strFile
End If
End If

Exit_CopyURLFile:
Exit Function

Err_CopyURLFile:
MsgBox "CopyURLFile Error: " & Err.Number & ": " & Err.Description
Resume Exit_CopyURLFile
End Function

You should be able to pass FilePaths or URLs to the last function. File
paths will be parsed by GetFileURL to give a URL of the form you'd get if you
open a file in Firefox - different to that in IE but it'll be handled the
same. If you're doing bulk transfers you might want to change the error
message in IsURL - a pop up box could be a pain. If you get any probs give
me a shout.

Ian
Thanks Ian.

I'm getting a "file not found" error 53 on the line
Set fOriginal = fsoCurrent.GetFile(strFileOriginal)

Here's the cmd code I'm using to run the function. 'Pic' is the bound field
containing the full URL of the picture (it's online). Am I calling the
function incorrectly?

Private Sub cmdSavePic_Click()
strDirectory = "C:\Documents and Settings\All Users\Desktop\ms pics\"
strFileOriginal = Pic
CopyFile strDirectory, strFileOriginal
End Sub

Thanks so much for your help. If I can get this working it will be a huge
timesaver.
JBHansen
If the form is bound to a table etc. containing a field with the full file
path then you could use the FileSystemObject to copy the file to a new
Click to expand...
[quoted text clipped - 42 lines]
Click to expand...
 
Back
Top