|
|
Greetings:
Currently I am working on adding photos to my real estate database
(the current market conditions have given me some free time) and I am
stuck on one portion of the code. I cannot figure out how to resize
the selected JPG file prior to saving that file in a centralized
directory.
For clarity I have attached my code below, but in a nut shell what I
would like to have happen is this:
On a form, the user would click on a command button. At that point a
file picker box opens and the user can browse to the file they want to
"upload". The code should then, resize the image (while maintaining
the aspect ratio) to be a maximum of 180px x 135px. Once resized this
new image should be saved in a centralized location on our domain
server with a new name (created from the primary keys of the record it
is associated with).
After researching how to manipulate images in access I have only
become more confused. Any help, and or suggestions are appreciated.
Also, while I am relatively good at following the logic of code, I am
still a novice and struggle with coding terminology.
Current code:
Private Sub cbUploadPhoto_Click()
Dim dlgFilePick As FileDialog 'File Picker
Dim strSourceFile As String 'Source file path and name
Dim strDestFile As String 'Destination path and file name
Dim strDestFilePath As String 'UNC File Path for saving the new
picture
Dim strUniquePicName As String 'Calculated picture name based upon
primary keys
Dim strWebPath As String 'Web link
'Set standardized variables
strDestFilePath = "\\ntserver\WEBSITE\bldgpic\"
strWebPath = "http://www.cpiaz.com/bldgpic/"
'OPEN FILE DIALOG AND GET SOURCE FILE NAME
Set dlgFilePick = Application.FileDialog(msoFileDialogFilePicker)
'Use a With...End With block to reference the FileDialog object.
With dlgFilePick
.Title = "Select Photo to Upload"
'Change the contents of the Files of Type list.
'Empty the list by clearing the FileDialogFilters collection.
.Filters.Clear
'Add a filter that includes all files.
.Filters.Add "All files", "*.*"
'Add a filter that includes GIF and JPEG images and
'make it the first item in the list.
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg", 1
.AllowMultiSelect = False
.InitialFileName = "P:\" 'Set initial directory to property
folder
'Use the Show method to display the File Select
'dialog box and return the user's action.
'The user pressed the action button.
If .Show = -1 Then
strSourceFile = .SelectedItems(1)
Else
'The user pressed Cancel
strSourceFile = ""
MsgBox "Action Canceled, Picture not uploaded"
Exit Sub
End If
End With
'SET HasPicture Database field to true
Me.WHasPic = -1
'GENERATE file paths and new unique file name
strUniquePicName = [ProjID] & [BldgID] & ".jpg"
strDestFile = strDestFilePath & strUniquePicName
'RESIZE source picture to 180 pixels wide by 135 pixels high
'This is the area that I need help
'SAVE resized picture in central folder with new file name
If RenameFileOrDir(strSourceFile, strDestFile) Then
'SAVE destination picture links in database
Me.WPicName = strUniquePicName
Me.WebPicLink = strWebPath & strUniquePicName
Me.LocalPicLink = strDestFile
End If
'Update picture on form
CallDisplayImage
End Sub
=========================================
Public Function RenameFileOrDir(ByVal strSource As String, _
ByVal strTarget As String, Optional fOverwriteTarget As Boolean =
False) As Boolean
On Error GoTo PROC_ERR
Dim fRenameOK As Boolean
Dim fRemoveTarget As Boolean
Dim strFirstDrive As String
Dim strSecondDrive As String
Dim fOK As Boolean
If Not ((Len(strSource) = 0) Or (Len(strTarget) = 0) _
Or (Not (FileOrDirExists(strSource)))) Then
'Check if the target exists
If FileOrDirExists(strTarget) Then
'Target already exists, check if ok to overwrite
If fOverwriteTarget Then
fRemoveTarget = True
Else
If vbYes = MsgBox("Do you wish to overwrite the " & _
"target file?", vbExclamation + vbYesNo, _
"Overwrite confirmation") Then
fRemoveTarget = True
End If
End If
'Remove target file if ok to overwrite
If fRemoveTarget Then
'Check that it's not a directory
If ((GetAttr(strTarget) And vbDirectory)) <>
vbDirectory Then
Kill strTarget
fRenameOK = True
Else
MsgBox "Cannot overwrite a directory", vbOKOnly, _
"Cannot perform operation"
End If
End If
Else 'The target does not exist
'Check if source is a directory
If ((GetAttr(strSource) And vbDirectory) = vbDirectory)
Then
' Source is a directory, see if drives are the same
strFirstDrive = Left(strSource, InStr(strSource, ":
\"))
strSecondDrive = Left(strTarget, InStr(strTarget, ":
\"))
If strFirstDrive = strSecondDrive Then
fRenameOK = True
Else
MsgBox "Cannot rename directories across drives",
_
vbOKOnly, "Cannot perform operation"
End If
Else 'It's a file, ok to proceed
fRenameOK = True
End If
End If
If fRenameOK Then
Name strSource As strTarget
fOK = True
End If
End If
RenameFileOrDir = fOK
PROC_EXIT:
Exit Function
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, ,
"RenameFileOrDir"
Resume PROC_EXIT
End Function
==========================================
Public Function FileOrDirExists(strDest As String) As Boolean
Dim intLen As Integer
Dim fReturn As Boolean
fReturn = False
If strDest <> vbNullString Then
On Error Resume Next
intLen = Len(Dir$(strDest, vbDirectory + vbNormal))
On Error GoTo PROC_ERR
fReturn = (Not Err And intLen > 0)
End If
PROC_EXIT:
FileOrDirExists = fReturn
Exit Function
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"FileOrDirExists"
Resume PROC_EXIT
End Function
Anyway, there is the code that I am using. Any help would be
appreciated.
Jeff Bassett
|
|
P.S.
I am also not married to using the following code, or the logic
behind
it, to create the new file:
Name strSource As strTarget
as I just realized that this line was moving, rather than creating a
copy, of my file.
Thank you,
Jeff Bassett
|
|
|