sayfadan userforma resim ekleme

[ekmekevi]

arkadaşlar merhaba sayfadaki bir alanı userformdaki imaje nesnesine nasıl getiririm yardımcı olabilirmisiniz

 

[AdemCan]

Sayın Korhan Beyin aşağıdaki bağlantıda yer alan dosyasından yola çıkarak örnek bir kod oluşturdum.

Çalışma sayfasından image'a resim alma

Merhaba, Ekteki userform'daki image nesnelerine,sayfadaki resimleri nasıl alabilirim.

www.excel.web.tr

Resim isimli bir sayfa oluşturunuz, bu sayfa dosyanızda kalıcı olarak durmalı, kopyalanan alanın resim olarak yapıştırılması için kullandım.
Resim olarak eklemek istediğiniz Hücre aralığını açılan Inputbox'lara yazınız.

Private Sub CommandButton1_Click()

Dim s1 As Worksheet, nesne As Shape
Set s1 = Sheets("Resim")
Application.ScreenUpdating = False

baslangic = InputBox("Başlangıç Hücresini Yazınız" & vbNewLine & "Örnek = A1", "Seçilecek Hücre Aralığı")
son = InputBox("Bitiş Hücresini Yazınız" & vbNewLine & "Örnek =  A2", "Seçilecek Hücre Aralığı")

If baslangic = "" Or son = "" Or Len(baslangic) < 2 Or Len(son) < 2 _
Or IsNumeric(Left(baslangic, 1)) Or IsNumeric(Left(son, 1)) Then
    MsgBox "Geçerli hücre seçimi yapmadınız", vbInformation, "Uyarı"
    Exit Sub
End If

s1.DrawingObjects.Delete

Range(baslangic & ":" & son).Copy
s1.Pictures.Paste

Application.CutCopyMode = False

Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
    Set XL_Chart = Charts.Add

For Each nesne In s1.Shapes
    resim = nesne.Name
    nesne.CopyPicture

    With XL_Chart
        .Paste
        .Export Filename:=Yol & resim & ".jpg", Filtername:="JPG"
    End With
        
    Image1.Picture = LoadPicture(Yol & resim & ".jpg")
    Kill (Yol & resim & ".jpg")
Next

    Application.DisplayAlerts = False
    XL_Chart.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[halit3]

Alternatif kod
'not referenslarda Clipboard.dll nesnesi yüklü olmalı

userforma
1 adet image1 nesnesi ekle
1 adet CommandButton1 ekle

aşağıdaki kodu çalıştır.

Private Sub CommandButton1_Click()
Dim myClp As clipboard
Set myClp = CreateObject("clipbrd.clipboard")
myClp.Clear
ActiveWindow.RangeSelection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Image1.Picture = myClp.GetData
MsgBox "İŞLEM TAMAM"""
End Sub

 

[tamer42]

Alternatif kod
'not referenslarda Clipboard.dll nesnesi yüklü olmalı

userforma
1 adet image1 nesnesi ekle
1 adet CommandButton1 ekle

aşağıdaki kodu çalıştır.

Private Sub CommandButton1_Click()
Dim myClp As clipboard
Set myClp = CreateObject("clipbrd.clipboard")
myClp.Clear
ActiveWindow.RangeSelection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Image1.Picture = myClp.GetData
MsgBox "İŞLEM TAMAM"""
End Sub

Halit Hocam burada Clipboard.dll nesnesini referanslarda bulamadım, nasıl yükleyeceğiz?
selamlar,

 

[Korhan Ayhan]

Alttaki linkten dll dosyasını edinebilirsiniz. Güvenilirmi emin değilim..

https://www.dlldosyaindir.com/clipboard-dll/

 

[Biolightant]

Merhaba,
PdfVBALib.dll ile çözümü

Private Sub CopyPictureToUserForm_Click()
    Dim ParcaFolder As String
    Dim PdfFile As Variant
    ParcaFolder = Environ("TEMP") & "\PDFaraclar"
    PdfFile = Environ("TEMP") & "\PDFaraclar\TempPdf.pdf"
       
    ' Geçici klasör varsa içini boşalt, yoksa klasörü oluştur
    If Dir(ParcaFolder, vbDirectory) <> "" Then
        CleanUpTempFiles ' Geçici dosyaları temizle
    Else
        MkDir ParcaFolder ' Klasörü oluştur
    End If
   
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality _
        :=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
   
    On Error GoTo ErrorHandler
   
    Dim PdfDoc As New PdfDocument
    PdfDoc.Open PdfFile
        Call GetPdfPageImage(PdfDoc, ParcaFolder)
    PdfDoc.Close
    PdfDoc.Dispose
       
    Me.Image1.Picture = LoadPicture(ParcaFolder & "\Resim 1.bmp")
   
    CleanUpTempFiles

Exit Sub
ErrorHandler:
    MsgBox "PDF işlemi için gerekli olan [ PdfVBALib.dll ] yükleyin.", vbCritical, "Hata"
    CleanUpTempFiles
End Sub

Private Sub GetPdfPageImage(inPdfDoc As PdfDocument, imgFolder As String)
    Dim imgs As PdfImageInfos
    Dim img As PdfImageInfo
    Dim counter As Long
    Dim l As Long

   
    For l = 0 To inPdfDoc.Pages.Count - 1
        Set imgs = inPdfDoc.Pages(l).GetImagesInfo
       
        If imgs.Count > 0 Then
            For Each img In imgs
                counter = counter + 1
                img.Save imgFolder & "\Resim " & counter & ".bmp", imgBmp
            Next
        End If
    Next
End Sub

Private Sub CleanUpTempFiles()
    On Error Resume Next
        Kill Environ("TEMP") & "\PDFaraclar\*.*"
    On Error GoTo 0
End Sub

 

[Zeki Gürsoy]

@Biolightant , resim alırken sayfa sınırlaması yoktur. Başlıkta bunu belirtmiştim.

.

 

[Biolightant]

resim alırken sayfa sınırlaması yoktur

Haklısınız pardon karıştırmışım, gereksiz kontrolü kaldırarak örnek kodları revize ettim.