Hücre içine resmi ortalama

[hamza02]

İndir Evrak Alma Verme Yetki Kartı xlsm

Dosyayı indir Evrak Alma Verme Yetki Kartı xlsm

dosya.co

Arkadaşlar merhaba,

Linkini eklediğim dosyada,
1-Resmi hücre içine yatay ve dikey ortalamak
2-Resmin belirtilen hücre dışına taşmamasını sağlamak
3-Sadece jpg değil diğer resim dosyalarınıda desteklesin
4-Belirtilen sicile ait resim yoksa işleme devam etsin

Ben uğraştım bu işlemleri yapamadım yardımcı olursanız sevinirim.

 

[Biolightant]

Merhaba,

Private Sub ComboBox1_Change()
    
        Dim Resim As Shape
        Dim Hucre As Range

        On Error Resume Next
        Set Hucre = Range("E5:E10")
        On Error GoTo 0
        
        If Hucre Is Nothing Then Exit Sub
        
        For Each Resim In ActiveSheet.Shapes
            If Not Intersect(Resim.TopLeftCell, Hucre) Is Nothing Then
                If Resim.Type = msoPicture Or Resim.Type = msoLinkedPicture Then
                    Resim.Delete
                End If
            End If
        Next Resim
 
    Sayfa1.Range("P14").Value = ComboBox1.Text          ' ComboBox ile Seçilen Suç Numarasını yazar
        
    Sayfa1.Range("D5") = ": " & WorksheetFunction.VLookup(Sayfa1.Range("P14"), Sayfa2.Range("B2:H50"), 4, 0)  'D5 hücresine ... yazar
    Sayfa1.Range("D6") = ": " & WorksheetFunction.VLookup(Sayfa1.Range("P14"), Sayfa2.Range("B2:H50"), 3, 0)  'D6 hücresine ... yazar
    Sayfa1.Range("D7") = ": " & WorksheetFunction.VLookup(Sayfa1.Range("P14"), Sayfa2.Range("B2:H50"), 5, 0)  'D7 hücresine ... yazar
    Sayfa1.Range("D8") = ": " & WorksheetFunction.VLookup(Sayfa1.Range("P14"), Sayfa2.Range("B2:H50"), 2, 0) & " / " & Sayfa1.Range("P14")
    Sayfa1.Range("D9") = ": " & WorksheetFunction.VLookup(Sayfa1.Range("P14"), Sayfa2.Range("B2:H50"), 6, 0)
    
    Sayfa1.Range("K9") = WorksheetFunction.VLookup(Sayfa1.Range("P14"), Sayfa2.Range("B2:H50"), 6, 0)

    Range("D9").NumberFormat = ": dd.mm.yyyy"

    'dosya = ActiveWorkbook.Path & "\RESIMLER\" & Sayfa2.Cells(2, 2).Value & ".jpg"      'parantez içi 2.satırı, 2.sütunu ifade eder

    Sayfa1.Cells(5, 5).Select
    
    '***** YENİ KODLAR *****
    
    Dim ws As Worksheet
    Dim fotoPath As String
    
    Set ws = Sayfa1
    
    fotoPath = ResimYolunuBul(ThisWorkbook.Path & "\Foto\", Sayfa1.Cells(14, 16).Value)
    
    If fotoPath = "" Then
        MsgBox "Resim bulunamadı: " & Sayfa1.Cells(14, 16).Value, vbExclamation
        Exit Sub
    End If
    
    ResmiEkle ws, ws.Range("E5:E9"), fotoPath
    
    Sayfa1.Range("A1").Select

End Sub

Private Function ResimYolunuBul(klasor As String, dosyaAdi As String) As String

    Dim uzanti As Variant
    Dim tamYol As String
    
    dosyaAdi = Trim(dosyaAdi)
    
    If dosyaAdi = "" Then Exit Function
    
    For Each uzanti In Array("jpg", "jpeg", "png", "bmp", "gif", "tif", "tiff")
        
        tamYol = klasor & dosyaAdi & "." & uzanti
        
        If Dir(tamYol) <> "" Then
            ResimYolunuBul = tamYol
            Exit Function
        End If
        
    Next uzanti

End Function

Private Sub ResmiEkle(ws As Worksheet, hedef As Range, FilePath As String)

    Dim shp As Shape
    
    Set shp = ws.Shapes.AddPicture( _
        FilePath, _
        msoFalse, _
        msoTrue, _
        hedef.Left, _
        hedef.Top, _
        -1, _
        -1 _
    )
    
    shp.Name = "Resim_" & Format(Now, "hhmmss")
    
    ResmiHucreyeSigdir shp, hedef

End Sub
Private Sub ResmiHucreyeSigdir(shp As Shape, hedef As Range)

    Dim oranW As Double
    Dim oranH As Double
    Dim oran As Double
    Dim bosluk As Double
    
    bosluk = 10
    
    shp.LockAspectRatio = msoTrue
    
    oranW = (hedef.Width - bosluk) / shp.Width
    oranH = (hedef.Height - bosluk) / shp.Height
    
    If oranW < oranH Then
        oran = oranW
    Else
        oran = oranH
    End If
    
    shp.Width = shp.Width * oran
    
    shp.Left = hedef.Left + (hedef.Width - shp.Width) / 2
    shp.Top = hedef.Top + (hedef.Height - shp.Height) / 2
    
    shp.Placement = xlMoveAndSize

End Sub

 

[hamza02]

Sayın Biolightant hocam eline emeğine sağlık çok güzel olmuş. Çok teşekkür ederim.

 

[hamza02]

Hocam D9 ve K9 hücrelerine tarih çekiyorum. Hücreye sadece tarih çekince sorun yok, ama tarihin önüne ":" iki nokta koyunca tarih formatından çıkıyor. Bunun için kodda nasıl bir değişiklik yapmam lazım.

 

[Biolightant]

Merhaba,

Sayfa1.Range("D9") = ": " & WorksheetFunction.VLookup(Sayfa1.Range("P14"), Sayfa2.Range("B2:H50"), 6, 0)

yukarıdaki yazdığım satırı, aşağıda yazığım ile değiştirip kontrol edermisin

Sayfa1.Range("D9") = ": " & Format(WorksheetFunction.VLookup(Sayfa1.Range("P14"), Sayfa2.Range("B2:H50"), 6, 0), "dd.mm.yyyy")