Forma birden fazla resim ekleme

  • Konuyu başlatan Konuyu başlatan spacebar
  • Başlangıç tarihi Başlangıç tarihi

spacebar

Kullanıcı
Excel Versiyonu
Excel 2016
Excel Sürümü
64 Bit
Excel Dili
Türkçe
değerli üstadlarım. aşağıda paylaştığım kodlarla resmi B3 : D6 aralığına ekliyor ve sorunsuz çalışıyor. ancak ben bu aralıkla birlikte (aynı zamanda) B17 : D20 aralığına da aynı resmi eklemek istiyorum. kodlarda nasıl bir revizyon yapmak gereklidir. yardımlarınız için teşekkür ederim.

bir diğer sorunum: 3-4 gün önce dev excel arşivini almak istedim ancak üyeliğiniz pasife alınmıştır şeklinde bir uyarı geldi. sorunu iki kere yazdım ancak cevap veren olmadı. şu an fiyatının da arttığını görüyorum. en azından pasife alınmanın çözülmesini rica ederim.

Kod: 
Sub logoEkle()

Dim eskizoom As Integer
eskizoom = ActiveWindow.Zoom
On Error GoTo hata
Dosya1 = Application.GetOpenFilename(FileFilter:="," & _
        "*.jpeg;*.png;*.bmp;*.jpg;*.gif", _
        Title:="Resim seçimi yapınız")
    If Dosya1 = False Then
    MsgBox "Resim seçmediniz.", vbCritical, "                     ## UYARI ##"  'vbInformation
    Exit Sub
    Else
    End If
    Application.ScreenUpdating = False
    Range("B3:D6").Select
ActiveWindow.Zoom = 100   'Sayfa Yakınlaştırma Ayarı
Set Alan1 = ActiveCell 'Range("C3,G3,K3,O3,S3")    'Range("C3:C9")
    For Each Resim1 In ActiveSheet.Pictures
    If Not Intersect(Resim1.TopLeftCell, Alan1) Is Nothing Then
    Resim1.Delete
    End If
    Next
    Set Alan1 = Nothing
    ActiveCell.Select 'Cells(3, "C").Select
    Set Adres1 = Range(ActiveWindow.RangeSelection.Address)
    ActiveSheet.Shapes.AddPicture(Filename:=Dosya1, linktofile:=msoFalse, _
            savewithdocument:=msoCTrue, Left:=0, Top:=0, Width:=-1, Height:=-1).Select
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.Weight = 0  'Çerçeve Kalınlığı
    Selection.ShapeRange.Line.ForeColor.RGB = RGB(0, 112, 192)
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = Adres1.Height * 0.85 'Yükseklik Aralığı
    Selection.ShapeRange.Width = Adres1.Width * 0.85   'Saş - Sol Aralık
    Selection.Top = Adres1.Top + 2 + (Adres1.Height - Selection.ShapeRange.Height) / 2
    Selection.Left = Adres1.Left + (Adres1.Width - Selection.ShapeRange.Width) / 2
        ActiveWindow.Zoom = eskizoom
        Application.ScreenUpdating = True
        Application.CutCopyMode = False
  
    'MsgBox "Firma Bilgilerini Girmeyi Unutmayınız.", vbCritical, "UYARI"

    Exit Sub
hata:
    MsgBox "Resim Ekleme için Hatalı İşlem Yapıldı.", vbCritical, "UYARI"
  
End Sub
 
Üç bölüme veri aktarımı yapmak hakkında
VBA üç koşulun kontrol edilmesi

Ekli dosyalar

Tarihe göre sırala Oylamaya göre sırala
Kırmızı satırın üstüne yeşil olan satırın eklenmesi yeterli olur sanırım, denersiniz.

VBA: 
[COLOR=rgb(43, 84, 44)][B]        [B3:D6].Copy [B17][/B][/COLOR]
[B][COLOR=rgb(132, 53, 52)]        ActiveWindow.Zoom = eskizoom[/COLOR][/B]
 
Oyla 0 Olumsuz oyla
Test etmek lazım ama şöyle bir deneyin isterseniz.
VBA: 
Set Adres1 = Range(ActiveWindow.RangeSelection.Address)
                    hg = Adres1.Width
                    hy = Adres1.Height
                    ActiveSheet.Shapes.AddPicture(Filename:=Dosya1, linktofile:=msoFalse, _
                        savewithdocument:=msoCTrue, Left:=0, Top:=0, Width:=-1, Height:=-1).Select
                        With Selection
                            oran = WorksheetFunction.Min((hg - 2) / .Width, (hy - 2) / .Height)
                            .ShapeRange.ScaleWidth WorksheetFunction.RoundDown(oran, 4), msoFalse, msoScaleFromTopLeft
                            .ShapeRange.Line.Visible = msoTrue
                            .ShapeRange.Line.Weight = 0  'Çerçeve Kalınlığı
                            .ShapeRange.Line.ForeColor.RGB = RGB(0, 112, 192)
                            .ShapeRange.LockAspectRatio = msoFalse
                            .ShapeRange.Height = Adres1.Height * 0.85 'Yükseklik Aralığı
                            .ShapeRange.Width = Adres1.Width * 0.85   'Saş - Sol Aralık
                            .Top = Adres1.Top + 2 + (Adres1.Height - Selection.ShapeRange.Height) / 2
                            .Left = Adres1.Left + (Adres1.Width - Selection.ShapeRange.Width) / 2
                            .Placement = xlMoveAndSize
                        End With
                        Selection.Copy Range("B17:D20").Select
                        ActiveWindow.Zoom = eskizoom
 
Oyla 0 Olumsuz oyla
@spacebar
Mevcut kodu aşağıdakiyle değiştirerek deneyin.

VBA: 
Sub logoEkle()
Dim eskizoom As Integer
eskizoom = ActiveWindow.Zoom
On Error GoTo hata
Dosya1 = Application.GetOpenFilename(FileFilter:="," & _
        "*.jpeg;*.png;*.bmp;*.jpg;*.gif", Title:="Resim seçimi yapınız")
If Dosya1 = False Then
    MsgBox "Resim seçmediniz.", vbCritical, "                     ## UYARI ##"  'vbInformation
    Exit Sub
End If
Application.ScreenUpdating = False
ActiveWindow.Zoom = 100   'Sayfa Yakınlaştırma Ayarı
Set Alan1 = Range("B3:D6") 'ActiveCell 'Range("C3,G3,K3,O3,S3")    'Range("C3:C9")
Set Alan2 = Range("B17:B20") 'ActiveCell 'Range("C3,G3,K3,O3,S3")    'Range("C3:C9")

For Each Resim1 In ActiveSheet.Pictures
    If Not Intersect(Resim1.TopLeftCell, Alan1) Is Nothing Or _
        Not Intersect(Resim1.TopLeftCell, Alan2) Is Nothing Then Resim1.Delete
Next
ActiveSheet.Shapes.AddPicture(Filename:=Dosya1, linktofile:=msoFalse, _
            savewithdocument:=msoCTrue, Left:=0, Top:=0, Width:=-1, Height:=-1).Select
With Selection
    .ShapeRange.Line.Visible = msoTrue
    .ShapeRange.Line.Weight = 0  'Çerçeve Kalınlığı
    .ShapeRange.Line.ForeColor.RGB = RGB(0, 112, 192)
    .ShapeRange.LockAspectRatio = msoFalse
    .ShapeRange.Height = Alan1.Height * 0.85 'Yükseklik Aralığı
    .ShapeRange.Width = Alan1.Width * 0.85   'Saş - Sol Aralık
    .Top = Alan1.Top + 2 + (Alan1.Height - Selection.ShapeRange.Height) / 2
    .Left = Alan1.Left + (Alan1.Width - Selection.ShapeRange.Width) / 2
    .Placement = xlMoveAndSize
End With
For Each r In Alan2: r.RowHeight = r.Offset(-14, 0).RowHeight: Next
Alan1.Copy [B17]
ActiveWindow.Zoom = eskizoom
Application.ScreenUpdating = True
Application.CutCopyMode = False
Alan1.Activate
    'MsgBox "Firma Bilgilerini Girmeyi Unutmayınız.", vbCritical, "UYARI"
Exit Sub
hata: MsgBox "Resim Ekleme için Hatalı İşlem Yapıldı.", vbCritical, "UYARI"
End Sub
 
Oyla 0 Olumsuz oyla
Yanıt için giriş yapmanız veya üye olmanız gerekir.
Benzer Konular Popüler İçerikler Daha Fazlası
Geri
Üst