resmi almak ve ilgili satırlara yerlestirmek

[BG]

vba bölümünde konuyu actim fakat yanit gelmeyince bu bolumde konuyu tekrar aciyorum, sorum dosya ekindedir, tesekkur ederim.

 

[Ferhat Pazarçevirdi]

Sayfada gösterdiğiniz butona aşağıdaki kodları atayınız.

Sub ResimEkle()
    Dim reS As Variant
    Dim Str1 As Variant
    Dim Str2 As Variant
    Dim sh As Worksheet
    Dim rg As Range
    Dim kls As String
 
    kls = "C:\Resimler\" [COLOR=darkgreen]'Bu klasör yolunu değiştirebilirsiniz.[/COLOR]
 
    reS = InputBox("Resmin adını girin", "Resim Dosyası")
 
    If StrPtr(reS) > 0 Then
 
        If Len(Dir(kls & reS & ".jpg")) = 0 Then
            MsgBox "Bu isimde bir dosya bulunamadı", _
                        vbCritical, _
                            "UYARI"
            Exit Sub
        End If
 
fpc1:
        Str1 = InputBox("Birinci satır numarasını girin", "İlk Satır Satır nO")
 
        If StrPtr(Str1) = 0 Then
            Exit Sub
        Else
            If Not IsNumeric(Str1) Then
                MsgBox "Sayısal bir değer girmelisiniz", _
                            vbCritical, _
                                "UYARI"
                GoTo fpc1
            Else
                If Val(Application.Version) <= 11 Then
                    If Str1 > 65536 Then
                        MsgBox "Satır no, 65536'dan büyük olamaz", vbCritical, "UYARI"
                        GoTo fpc1
                    End If
                Else
                    If Str1 > 1048576 Then
                        MsgBox "Satır no, 1.048.5766'dan büyük olamaz", vbCritical, "UYARI"
                        GoTo fpc1
                    End If
                End If
            End If
        End If
fpc2:
        Str2 = InputBox("Son satır numarasını girin", "Son Satır Satır nO")
 
        If StrPtr(Str2) = 0 Then
            Exit Sub
        Else
            If Not IsNumeric(Str2) Then
                MsgBox "Sayılsal bir değer girmelisiniz", _
                            vbCritical, _
                                "UYARI"
                GoTo fpc2
            Else
                If Val(Application.Version) <= 11 Then
                    If Str2 > 65536 Then
                        MsgBox "Satır no, 65536'dan büyük olamaz", vbCritical, "UYARI"
                        GoTo fpc2
                    End If
                Else
                    If Str2 > 1048576 Then
                        MsgBox "Satır no, 1.048.5766'dan büyük olamaz", vbCritical, "UYARI"
                        GoTo fpc2
                    End If
                End If
            End If
 
        End If
 
 
        Set sh = ActiveSheet
        Set rg = sh.Range("A" & Str1 & ":A" & Str2)
        Set pic = sh.Pictures.Insert(kls & reS & ".jpg")
 
        With pic
            .Top = rg.Top
            .Left = rg.Left
            .Width = rg.Width
            .Height = rg.Height
        End With
 
        Set sh = Nothing
        Set pic = Nothing
        Set rg = Nothing
    End If
End Sub

Not : Sorunuzu dosya içerisinde açıkladığınız gibi; bu mesajı okurken bir fikir sahibi olabilmemiz için, mesaj içeriğine de ekleyiniz.

 

[BG]

sayın Ferhat Pazarçevirdi

hocam ilginize tesekkur ederim, cok emek sarfetmissiniz teskkur ederim, fakat ekli dosyada degerli arkadaslarimizin yardmiyla problemi cozduk