Here is something that might help you. First to subs go into your frmMyProfile form code, the rest in a new standard module.
Cheers,
Vlad
Code:
Private Sub cmdAddImage_Click()
Dim sOrigFile As String, sFilePath As String
Dim sFileName as string,sLocalFolder as string
Dim fDialog As Object 'FileDialog
Set fDialog = Application.FileDialog(3) 'msoFileDialogFilePicker
'Show the dialog. -1 means success!
If fDialog.Show = -1 Then
sOrigFile = fDialog.SelectedItems(1) 'The full path to the file selected by the user
End If
sFileName =SplitLast(sOrigFile)
'check if folder exists and create it if not
sLocalFolder= Environ$("USERPROFILE") & "\Documents\AccountModule\images
If Len(Dir(sLocalFolder, vbDirectory)) = 0 Then MyMkDir sLocalFolder
sFilePath = sLocalFolder & "\" & sFileName
'lets copy the file to the new location
Call vcCopyFIle(sOrigFile, sFilePath)
If Len(Dir(sFilePath)) > 0 Then
Me.ImagePath = sFilePath
Else
Me.ImagePath = Null
End If
Me.Dirty = False
'now lets show the picture
If Len(Dir(sFilePath)) > 0 Then
Me.ctrlImage.Picture = sFilePath
Else
Me.ctrlImage.Picture = "(none)"
End If
End Sub
Private Sub Form_Current()
On Error Resume Next 'vlad
if Not IsNull(Me.ImagePath) then
'still check if file exists
If Len(Dir(Me.ImagePath)) > 0 Then
Me.ctrlImage.Picture = Me.ImagePath
Else
Me.ctrlImage.Picture = "(none)"
End If
Me.Dirty = False 'vlad
End Sub
'''<<<<<<<<<<<<<<<<<<<<<<<<this goes into a standard module >>>>>>>>>>>>>>>>>
Option Compare Database
Option Explicit
Const FO_COPY = &H2
Const FO_DELETE = &H3
Const FO_MOVE = &H1
Const FO_RENAME = &H4
Const FOF_ALLOWUNDO = &H40
Const FOF_SILENT = &H4
Const FOF_NOCONFIRMATION = &H10
Const FOF_RENAMEONCOLLISION = &H8
Const FOF_NOCONFIRMMKDIR = &H200
Const FOF_FILESONLY = &H80
Private Type SHFILEOPSTRUCT
hwnd As LongPtr
wFunc As LongPtr
pFrom As String
pTo As String
fFlags As Integer
fAborted As Boolean
hNameMaps As LongPtr
sProgress As String
End Type
Private Declare PtrSafe Function SHFileOperation Lib "shell32.dll" _
Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As LongPtr
Public Function vcCopyFIle(sSource As String, sDest As String)
Dim lFileOp As LongPtr
Dim lresult As LongPtr
Dim lFlags As Long
Dim SHFileOp As SHFILEOPSTRUCT
lFileOp = FO_COPY
lFlags = lFlags Or FOF_NOCONFIRMATION
lFlags = lFlags Or FOF_SILENT
With SHFileOp
.wFunc = lFileOp
.pFrom = sSource & vbNullChar & vbNullChar
.pTo = sDest & vbNullChar & vbNullChar
.fFlags = lFlags
End With
lresult = SHFileOperation(SHFileOp)
End Function
Public Function StripLast(Path As String) As String
On Error Resume Next
Dim x As Long
Dim Y As Long
Y = Len(Path) + 1
x = 1
x = InStr(x, Path, "\", vbDatabaseCompare)
Do While x > 0
Y = x
x = InStr(x + 1, Path, "\")
Loop
StripLast = Right(Path, Len(Path) - Y)
End Function
Public Function vcGetPathFromFullName(strFullName As String) As String
On Error Resume Next
vcGetPathFromFullName = Left(strFullName, Len(strFullName) - Len(StripLast(strFullName)))
End Function
Public Sub MyMkDir(sPath As String)
Dim iStart As Integer
Dim aDirs As Variant
Dim sCurDir As String
Dim i As Integer
If sPath <> "" Then
aDirs = Split(sPath, "\")
If Left(sPath, 2) = "\\" Then
iStart = 3
Else
iStart = 1
End If
sCurDir = Left(sPath, InStr(iStart, sPath, "\"))
For i = iStart To UBound(aDirs)
sCurDir = sCurDir & aDirs(i) & "\"
If Dir(sCurDir, vbDirectory) = vbNullString Then
MkDir sCurDir
End If
Next i
End If
End Sub
Windows 10 
Access 2016
Reply With Quote
Originally Posted by Gicu
