Function ResimEkle(alanadi As String, cerceveadi As String)
Dim gzt As FileDialog
Dim DosyaAdi As String
Dim SeciliNesne As Variant
Set trz = Application.FileDialog(msoFileDialogFilePicker)
With trz
    .AllowMultiSelect = False
    .ButtonName = "Resim Seç"
    .Filters.Add "Resimler", _
                  "*.gif; *.jpg; *.jpeg; *.bmp; *.png"
    .FilterIndex = 0
    .InitialFileName = Environ("UserProfile") & "\My Documents\"
    .InitialView = msoFileDialogViewThumbnail
    .Title = "Resim Seç..."
        If .Show = True Then
            For Each SeciliNesne In .SelectedItems
            DosyaAdi = SeciliNesne
            Next SeciliNesne
            Controls(alanadi) = DosyaAdi
            Controls(cerceveadi).Picture = DosyaAdi
        End If
End With
 
 
On Error Resume Next
 
asil = Controls(alanadi)
 
kopya = CurrentProject.Path & _
"\\resim\" _
& Me.PersonelNo & Me.Ad & Right(cerceveadi, 1) _
& Right(Dir(asil), 4) 'Buradaki alan isimlerini kendinize göre güncelleyiniz..
 
Dim aa
Set aa = CreateObject("Scripting.FileSystemObject")
 
aa.CopyFile asil, kopya
Controls(alanadi) = kopya
Controls(cerceveadi).Picture = kopya
If MsgBox("Resim klasöre kopyalandı.. " _
& "İlk dosyayı silmek ister misiniz?", vbYesNo, "Uyarı") = vbYes Then
Kill asil
End If
 
End Function

Function ResmiBoyutlandir(DosyaYolu)
Dim YResim As WIA.ImageFile, _
trz As WIA.ImageProcess, Kopya As String
 
Kopya = DosyaYolu
Set YResim = CreateObject("WIA.ImageFile")
Set trz = CreateObject("WIA.ImageProcess")
 
YResim.LoadFile (Kopya)
trz.Filters.Add (trz.FilterInfos("Scale").FilterID)
trz.Filters(1).Properties("MaximumWidth").Value = 1366 'Genişlik
trz.Filters(1).Properties("MaximumHeight").Value = 768 'Yükseklik
Set YResim = trz.Apply(YResim)
 
If Not Dir(Kopya) = vbNullString Then Kill Kopya
YResim.SaveFile (Kopya)
 
End Function

'........
'................
'........................
            Next SeciliNesne
            Controls(alanadi) = DosyaAdi
            Call ResmiBoyutlandir(DosyaAdi) 'BU KISMI İLAVE ETMELİSİNİZ.. 
          Me.cerceve.Picture = DosyaAdi
        End If
End With
 
'........
'................
'........................