Soru Makro İle Resim Al ve Birleştir.

[Hsn55]

İyi akşamlar;
Ekli dosyada Userform1 üzerindeki ResimAl butonu ile hem Userform üzerindeki Image1 sayfasına hemde Suç Tutanağı sayfasında B10:X60 hücre aralığına tekli ve çoklu resim çağırabilir miyiz. ?. Örneğin ben 2 resim çağırdığım zaman bu resimleri birleştirerek hem userform üzerine hemde suç tutanağı sayfasındaki B10:X60 aralığa aldırmak mümkün müdür. Destek olursanız sevinirim.

İndir RESİM BİRLEŞTİR xlsm

Dosyayı indir RESİM BİRLEŞTİR xlsm

dosya.co

 

[Trilenium]

Birleştirmekten kastınız nedir? yan yana koymak gibi mi?

Eğer öyle ise Image nesnesi sadece 1 fotoğrafı taşıyabiliyor.

 

[Hsn55]

Evet hocam. .Resim fazla ise örneğin 4 adet ise 2 yana 2 alta gibi

 

[Biolightant]

Merhaba,
Birleştirilecek olan resimler en ve boy (width ve height) değerleri aynı mı ?

 

[Hsn55]

Merhabalar;

Farklı hocam

 

[Biolightant]

Olası Kurgu
kullanıcıya GetOpenFilename ile jpg dosya seçimi yaptır (MultiSelect şeçenegi True olsun)
seçim sayısı kadar döngüye gir 2'şerli olarak (step 2)
her iki fotoyu Grup yap (tek foto)
her oluşan grubu bir önceki grubun height değerini yeni oluşan grubun top değeri yap
döngü bitince tüm grupları seç ve yeni bir AnaGrup oluştur (tüm gruplar tek fotoya dönüştür)
AnaGrubun genişliğini B10:X10 genişliği kadar yap
AnaGrubun yüksekliğini B10:B60 yüksekliği kadar yap
sayfaya foto koyma işlemi bitince

UserFromun Image1 nesnesine B10:X60 hücre aralığının fotosunu koymak için.

Private Function Hucrelere_Resim_Cek(ResimHucre As Range) Dim Grafik As Object ' Hücre aralığının resim olarak kopyalanması ResimHucre.CopyPicture xlScreen, xlBitmap ActiveSheet.Paste Selection.Cut ' Geçici grafik nesnesi oluştur ve resimi içine yapıştır Set Grafik = ActiveSheet.ChartObjects.Add(Left:=0, Top:=0, Width:=ResimHucre.Width, Height:=ResimHucre.Height) Grafik.Activate Grafik.Chart.Paste Grafik.Chart.Export Environ$("temp") & "\ExcelHucreResim.jpg" ' Resmi JPG olarak kaydet Grafik.Delete ' Geçici grafik nesnesini sil End Function

Kodlarını kullanabilirsin.

 

[Hsn55]

Hocam ben makro konusunda zayıfım. Eğer sizi uğraştırmayacaksa yaparmısınız?

 

[Hsn55]

Sayın Biolightant bey günaydın. Ekli dosya ile RESİM BİRLEŞTİR sayfasına seçilen resimleri çoklu birleşik şekilde alıyorum. Bu kod işime yarıyor. Bu resimleri aynı zaman da userform üzerine de paralel olarak aldırabilir miyiz. Ayrıca Resim Birleştir sayfasına resimler eklediğim zaman bu resimlerde siliniyor. Silinmemesi için kodu revize edebilir misiniz?

İndir RESİM BİRLEŞTİR xlsm

Dosyayı indir RESİM BİRLEŞTİR xlsm

dosya.co

 

[Biolightant]

Merhaba,
Kodlar UserForm içine

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

Set Sht = Sheets("RESİM BİRLEŞTİR"): Set RngArr = Sht.[B10:x59]
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
SmFl = UBound(File)
For FlCnt = 1 To SmFl Step 1
    On Error GoTo HataYakala
    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 = 16777215 'çerçeve rengi
    .Weight = 3 'çerçeve kalınlığı
    End With
    
    End With
Next FlCnt

    ' Şeklin veya Resmin fotoğrafını oluştur
    Call Hucrelere_Resim_Cek(Sheets("RESİM BİRLEŞTİR").Range("B10:X60"))
    
    ' Fotoğrafın temp klasöründeki TamYolu
    FotoAdres = Environ$("temp") & "\ExcelHucreResim.jpg"
    
    ' ***** Hücre fotoğrafını Image1 e ekle *****
    Me.Image1.Picture = LoadPicture(FotoAdres)

    Exit Sub

HataYakala:
    ' Hata Mesajı ve Temizlik
    MsgBox "Bir hata oluştu!" & vbCrLf & _
           "Hata Numarası: " & Err.Number & vbCrLf & _
           "Açıklama: " & Err.Description, vbCritical, "Hata"
    Err.Clear
End Sub
Private Sub Hucrelere_Resim_Cek(ResimHucre As Range)
    Dim Grafik As Object

    ' Hücre aralığının resim olarak kopyalanması
    ResimHucre.CopyPicture xlScreen, xlBitmap
    ActiveSheet.Paste
    Selection.Cut

    ' Geçici grafik nesnesi oluştur ve resimi içine yapıştır
    Set Grafik = ActiveSheet.ChartObjects.Add(Left:=0, Top:=0, Width:=ResimHucre.Width, Height:=ResimHucre.Height)

    Grafik.Activate
    Grafik.Chart.Paste
    Grafik.Chart.Export Environ$("temp") & "\ExcelHucreResim.jpg" ' Resmi JPG olarak kaydet
    DoEvents
    Grafik.Delete ' Geçici grafik nesnesini sil

End Sub

 

[Hsn55]

Hocam çok teşekkür ediyorum. Tam istediğim şekilde oldu.Dosyadam çıkarken alınan resimlerin silinmesi için ne yapabiliriz?

 

[Hsn55]

Hocam sizi devamlı olarak rahatsız ettiğim için çok özür diliyorum. Resim çağırdığım zaman bir önceki alınan resimler silinmiyor. Devamlı üzerine üzerine kayıt yapıyor. Buna bir çözüm getirebilir misiniz?. Not: Kayıtlı resimler kalacak. Sadece makro ile çağırdıklarım silinecek

 

[Hsn55]

Sayın hocam aşağıdaki kodu aktif edince bir önceki seçilen resmi siliyor. Buraya kadar sıkıntı yok. Acaba Sayfa üzerinde Resim-1,Resim-2,Resim-3 olarak isimlendirdiğim resimlerin silinmemesi için makroya şart koyabilir misiniz.Bu resimler silinmeyecek. Diğerleri silinecek

For Each Pic In Sht.Shapes
'    If Pic.Type <> 1 Then
'        Sht.Shapes(Pic.Name).Delete
'    End If
'Next Pic

 

[Biolightant]

Bu kodların yerine

'For Each Pic In Sht.Shapes
'    If Pic.Type <> 1 Then
'        Sht.Shapes(Pic.Name).Delete
'    End If
'Next Pic

Bu kodları kullanın

For Each Pic In Sht.Shapes
    If Pic.Type <> 1 Then
        Select Case Pic.Name
            Case "Resim-1", "Resim-2", "Resim-3"
                ' Belirtilen resimler için bir şey yapma
            Case Else
                Pic.Delete
        End Select
    End If
Next Pic

 

[Hsn55]

Hocam bazen şöyle bir hata veriyor. Neden acaba resmi sayfaya alıyor. Fakat Userforma almıyor. Excelden çıkıp tekrar girdiğinde düzeliyor.
Bir Hata Oluştu
Hata Numarası:1004
Açıklama: Microsoft Excel Yapıştıramıyor şeklinde

 

[Biolightant]

'For Each Pic In Sht.Shapes
'    If Pic.Type <> 1 Then
'        Sht.Shapes(Pic.Name).Delete
'    End If
'Next Pic

yeni kodları bu satırların olduğu yere yapıştırdınız di mi ?

Hata verdiğinde Debug Tıklayın hatalı satırı buraya yazın

 

[Hsn55]

Satırda hata vermiyor. Sadece uyarı veriyor hocam
kod şu şekilde ekledim

For Each Pic In Sht.Shapes
    If Pic.Type <> 1 Then
        Select Case Pic.Name
            Case "Resim-1", "Resim-2", "Resim-3"
                ' Belirtilen resimler için bir şey yapma
            Case Else
                Pic.Delete
        End Select
    End If
Next Pic

 

[Hsn55]

Hata vermesine rağmen sayfaya resmi alıyor. Fakat userforma resimler gelmiyor

 

[Hsn55]

Hocam şurayı silsem düzelir mi?

HataYakala:
    ' Hata Mesajı ve Temizlik
    MsgBox "Bir hata oluştu!" & vbCrLf & _
           "Hata Numarası: " & Err.Number & vbCrLf & _
           "Açıklama: " & Err.Description, vbCritical, "Hata"