Soru User Form Üzerine Resim Çağırma

Hsn55 · 11 Kasım 2021

İyi akşamlar
Ekli makro ile anasayfa üzerindeki resim butonu ile seçilen resmi hem ana sayfa üzerinde N4:U29 hücre aralığına hem de resim sayfasında C12:V50 hücre aralığına alıyoruz. Benim istediğim Ana Sayfa üzerinde bulunan Userform 1 üzerinde bulunan resim aç butonunu tıklayıp resmi seçtiğimde ilgili resmin hem resim sayfasına hem de Userform1 de İmage resminin içerisine aldırabilir miyiz ?
Not: Anasayfa ya resim gelmeyecek.Userform1 ve Resim sayfasına gelecek
https://dosyam.org/Zmj/RESİM_BİRLEŞTİR.xlsm

Kod:

Sub PicturesInsertMultiMerge()


Dim Pic As Object, File As Variant, Sht As Worksheet
Dim RngArr, RngArr1 As Range, FlCnt&, SmFl&
ChDrive Environ("SystemDrive"): ChDir Environ("UserProfile") & "\Desktop"

Set Sht = Sheets("RESİM"): Set RngArr = Sht.[C12:V50]
Set s1 = Sheets("ANA SAYFA"): Set RngArr1 = s1.[N4:U29]

File = Application.GetOpenFilename( _
    "Resim Dosyaları (*.jfif;*.jpg;*.jpeg;*.png;*.bmp),*.jpg;*.jpeg;*.png;*.bmp ;*.jfif" & _
    ",Tüm Dosyalar (*.*),*.*", , "Resim Dosyası Seçin...", , True)
If Not IsArray(File) Then Exit Sub
For Each Pic In Sht.Shapes
    If Pic.Type <> 1 Then
        Sht.Shapes(Pic.Name).Delete
    End If
Next Pic

For Each Pic1 In s1.Shapes
    If Pic1.Type <> 1 Then
        s1.Shapes(Pic1.Name).Delete
    End If
Next Pic1
SmFl = UBound(File)
For FlCnt = 1 To SmFl Step 1
    On Error GoTo ExitSub
    Set Pic = Sht.Pictures.Insert(File(FlCnt))
    With Pic
        .ShapeRange.LockAspectRatio = msoFalse
        .Placement = xlFreeFloating
        .Width = IIf(SmFl < 3, RngArr.Width, IIf(SmFl Mod 2 And SmFl = FlCnt, RngArr.Width, RngArr.Width / 2))
        .Height = RngArr.Height / IIf(SmFl > 2, (SmFl - ((SmFl + 1) Mod 2) + 1) / 2, 1) * IIf(SmFl = 2, 0.5, 1)
        .Top = RngArr.Top + (.Height * (FlCnt - ((FlCnt - 1) Mod 2) - 1) / 2) + IIf(SmFl = 2 And SmFl = FlCnt, .Height, 0)
        .Left = RngArr.Left + (.Width * ((FlCnt - 1) Mod 2)) - IIf(SmFl = 2 And SmFl = FlCnt, .Width, 0)
     With .ShapeRange.Line 'çerçeve
    .Visible = msoTrue 'çerçeveyi göster
    .ForeColor.RGB = 16772515 'çerçeve rengi
    .Weight = 1 'çerçeve kalınlığı
     End With
    End With
    
        Set Pic1 = s1.Pictures.Insert(File(FlCnt))
    With Pic1
        .ShapeRange.LockAspectRatio = msoFalse
        .Placement = xlFreeFloating
        .Width = IIf(SmFl < 3, RngArr1.Width, IIf(SmFl Mod 2 And SmFl = FlCnt, RngArr1.Width, RngArr1.Width / 2))
        .Height = RngArr1.Height / IIf(SmFl > 2, (SmFl - ((SmFl + 1) Mod 2) + 1) / 2, 1) * IIf(SmFl = 2, 0.5, 1)
        .Top = RngArr1.Top + (.Height * (FlCnt - ((FlCnt - 1) Mod 2) - 1) / 2) + IIf(SmFl = 2 And SmFl = FlCnt, .Height, 0)
        .Left = RngArr1.Left + (.Width * ((FlCnt - 1) Mod 2)) - IIf(SmFl = 2 And SmFl = FlCnt, .Width, 0)
     With .ShapeRange.Line 'çerçeve
    .Visible = msoTrue 'çerçeveyi göster
    .ForeColor.RGB = 1677915 'çerçeve rengi
    .Weight = 3 'çerçeve kalınlığı
     End With
    End With
    
    
Next FlCnt
ExitSub:
Set Pic = Nothing: Set Sht = Nothing: Set File = Nothing

End Sub

halit3 · 11 Kasım 2021

kod:

Kod:

Sub CommandButton1_Click()
Dim fPath  As String
Dim fdgPicker As FileDialog

fPath = CreateObject("wscript.Shell").SpecialFolders.Item("Desktop")
ChDrive fPath

Set fdgPicker = Application.FileDialog(msoFileDialogFilePicker)
With fdgPicker
.InitialView = msoFileDialogViewThumbnail
.Filters.Add "Graphics Files (*.bmp; *.gif; *.jpg; *.jpeg)", "*.bmp;*.gif;*.jpg;*.jpeg"
.FilterIndex = 1
If .Show = -1 Then
UserForm1.Image1.Picture = LoadPicture(.SelectedItems(1))

Dosya = .SelectedItems(1)

Dim s1
Set s1 = Sheets("RESİM") 'ActiveSheet.Name

Set Adres = Range(s1.Cells(12, "c"), s1.Cells(49, "v"))

Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then

Set yer = Range(s1.Cells(Picture.TopLeftCell.Row, Picture.TopLeftCell.Column), s1.Cells(Picture.BottomRightCell.Row - 1, Picture.BottomRightCell.Column))
MsgBox yer.Address & Chr(10) & Adres.Address
If yer.Address = Adres.Address Then
Picture.Delete
Exit For
End If
End If
Next Picture

ad = s1.Pictures.Insert(Dosya).Name
's1.Shapes(ad).OLEFormat.Object.Select
s1.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(ad).OLEFormat.Object.Top = Adres.Top + 2
s1.Shapes(ad).OLEFormat.Object.Left = Adres.Left + 2
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height - 4
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width - 4

Dim Img 'As ImageFile
Set Img = CreateObject("WIA.ImageFile")
Img.LoadFile Dosya
MsgBox "Resim Boyutları " & Img.Width & " x " & Img.Height

Else
MsgBox "Seçili Resim Yok"
End If
End With
End Sub

Hsn55 · 12 Kasım 2021

Halit bey çok teşekkür ederim. Dosya userform1 e veri çekiyor fakat istediğim özellikleri almıyor.
1- Userform1 e resim aldığımda tekrar 2. bir sesim aldığımda resim sayfasına alınan bir önceki resmi silmeden tekrar üzerine alıyor.
2-Userform 1 e dosyadan örneğin 3 adet resim aldığımda bunları birleştirmeyerek tek resim alıyor. Benim dosyadaki makroda kaç adet resim aldıysam bunları birleştiriyor.
3-Resim çerçeve rengi, kalınlığı gibi ayarlar yok

halit3 · 12 Kasım 2021

Sorularınızı anlayamadım sizin dosyadaki kod resimleri nasıl birleştiriyor.

CSS:

Sub CommandButton1_Click()
Dim fPath  As String
Dim fdgPicker As FileDialog

fPath = CreateObject("wscript.Shell").SpecialFolders.Item("Desktop")
ChDrive fPath

Set fdgPicker = Application.FileDialog(msoFileDialogFilePicker)
With fdgPicker
.InitialView = msoFileDialogViewThumbnail
.Filters.Add "Graphics Files (*.bmp; *.jpg; *.jpeg)", "*.bmp;*.jpg;*.jpeg"
.FilterIndex = 1
If .Show = -1 Then
UserForm1.Image1.Picture = LoadPicture(.SelectedItems(1))

Dosya = .SelectedItems(1)

Dim s1
Set s1 = Sheets("RESİM")

Set Adres = Range(s1.Cells(12, "c"), s1.Cells(49, "v"))

Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then

Set yer = Range(s1.Cells(Picture.TopLeftCell.Row, Picture.TopLeftCell.Column), s1.Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column))
If yer.Address = Adres.Address Then
Picture.Delete
Exit For
End If
End If
Next Picture

ad = s1.Pictures.Insert(Dosya).Name
s1.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(ad).OLEFormat.Object.Top = Adres.Top + 2
s1.Shapes(ad).OLEFormat.Object.Left = Adres.Left + 2
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height - 4
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width - 4

With s1.Shapes(ad).OLEFormat.Object.ShapeRange.Line
.Visible = msoTrue
.ForeColor.RGB = 1677915
.Weight = 3
End With


Else
MsgBox "Seçili Resim Yok"
End If
End With
End Sub

halit3 · 13 Kasım 2021

Hsn55' Alıntı:
Halit bey çok teşekkür ederim. Dosya userform1 e veri çekiyor fakat istediğim özellikleri almıyor.
1- Userform1 e resim aldığımda tekrar 2. bir sesim aldığımda resim sayfasına alınan bir önceki resmi silmeden tekrar üzerine alıyor.
2-Userform 1 e dosyadan örneğin 3 adet resim aldığımda bunları birleştirmeyerek tek resim alıyor. Benim dosyadaki makroda kaç adet resim aldıysam bunları birleştiriyor.
3-Resim çerçeve rengi, kalınlığı gibi ayarlar yok

Sorunuzun bu bölümünü anlayamadım

2-Userform 1 e dosyadan örneğin 3 adet resim aldığımda bunları birleştirmeyerek tek resim alıyor. Benim dosyadaki makroda kaç adet resim aldıysam bunları birleştiriyor.

sizin kod birden fazla resimleri nasıl birleştiriyor.

Hsn55 · 13 Kasım 2021

Halit bey merhabalar, ilk mesajımda ki dosyadaki kod dosya seçten örneğin 5 adet resim seçtiğinde bunları birleştirerek tanımlı hücre aralığına alıyor.

halit3 · 13 Kasım 2021

Tamam anladım kod birden fazla resim seçildiğinde ekleme yapıyor.

Soru User Form Üzerine Resim Çağırma

Hsn55

halit3

Uzman

Hsn55

halit3

Uzman

halit3

Uzman

Hsn55

halit3

Uzman