Userforma belirli alanın resmini yapıştırmak

[Muhammet Okumuş]

Arkadaşlar merhaba,

Userform'a kayıtlı resim ekleme ile ilgili çalışmalar buldum. Ama benim istediğim bu değil.

Düğmeye tıkladığımızda Userform açılacak ve B2:G16 (satır sayısı değişken) aralığının resmini Userform'a yapıştıracak. Dosyada nasıl görünmesi ile ilgili görsel paylaştım.
Userform yüksekliği ve genişliği resim boyutuna göre değişken olmalı.

 

[Zeki Gürsoy]

Bunun için resmin pixel yüksekliğini/genişliğini, Userform ebat ölçü birimi olan Point' e çevirerek yüksekliğini/genişliğini ayarlamanız gerekir.

Özetle araştırmanız gereken iki konu var:
- FileSystemObject nesnesi NameSpace özellikleriyle pixel büyüklükleri alınabiliyor.
- Pixel To Point için internette biraz araştırma yapın...

.

 

[Muhammet Okumuş]

Boyut ile ilgili kısmı araştıracağım. Peki kopyala/yapıştır yapabilir miyiz?

 

[Muhammet Okumuş]

Bununla ilgili yabancı sitelerden de araştırdım ama resmin bilgisayarda kayıtlı olması lazım diyor.

 

[Korhan Ayhan]

İnceleyiniz.

 

[Muhammet Okumuş]

Korhan Bey çok teşekkür ederim. Aradığım cevap buydu. Tekrardan teşekkür ederim.

 

[Muhammet Okumuş]

Resimde bozulma olmasının nedeni ne acaba? Reim netliğini sağlamak mümkün mü? Eğer genişlik ayarından kaynaklanıyorsa sabit değerlerde kullanabiliriz. Ben kodda değişkliikler yaptım ama netliği sağlayamadım. Soldaki veriler sağdaki ise resim olarak yapıştırılmış hali.

 

[Muhammet Okumuş]

 

[Korhan Ayhan]

Ben üstteki mesajımda ki dosyada küçük bir düzeltme yaptım. (Formatta bir değişiklik yoktur.)

Ek olarak daha önce forumda işlenen konuların içinden seçtiğim linkleri inceleyiniz.

Seçili Hücrelerin Ekran Görüntüsünü Almak

Merhabalar. Sitenizden faydalanarak yapmış olduğum bir programım var. Takıldığım bir noktada yardımlarınızı bekliyorum. "yazdır" isimli sayfamdaki A1:E20 aralığını userformumdaki image nesnesine almak istiyorum. Nasıl bir yol izlemeliyim ? Yardımlarınızı bekliyorum. Mutlu hafta sonları :)

www.excel.web.tr

https://www.excel.web.tr/threads/userform-uezerinde-worksheet-range-goesterme.93739

 

[muygun]

Merhaba;
Alternatif eksik çalışma
Resim alan aralığını , bu alana bağlı olarak userform en ve boy değerleri sayfada belirlenebilirse ekteki gibi olabilir.
İyi çalışmalar.

 

[Muhammet Okumuş]

Resim net olarak yerleşmiyor.

 

[Tevfik_Kursun]

Merhaba Arkadaşlar,
Korhan hocam, Resim_1 deki hatayı veriyor ve Userform açılmıyor
Muygun hocam, Resim_2 deki hatayı veriyor ve Userform boş geliyor
Neden olabilir?
Saygılarımla

 

[Korhan Ayhan]

@Tevfik_Kursun,

DEBUG dediğinizde kod bölümünde nereye gidiyor. Sarı renkli satırdaki değerin üstüne mouse ile geldiğinizde aldığı değer ne oluyor?

 

[Tevfik_Kursun]

Sayın Korhan Ayhan Hocam,
UserForm1=<Object variable or with block variable not set>
ibaresi geliyor.
Saygılarımla

 

[muygun]

Merhaba;
Deneme ve çalışmamı Ofis 2003 üzerinde yaptım ve böyle bir soruna rastlamadım.
NOT: alanı .jpg olarak kaydedip sonra form üzerine alıyorum. Dolayısıyla pc nin kayıt performansına bağlı olarak kaydetmeden userform aktif olabiliyor. Bunu engellemek için gecikme sağlamak adına 1-10000 aralığında boş döngü koydum. (bunun yerine dosyanın varlığı kontrol ettirilebilir)
Ama ihtimalle versiyon farkı olabilir.

 

[Tevfik_Kursun]

Sayın Muygun Hocam,
Teşekkür ederim, ama sayma bölgesi sanki önce değil. Saymayı 500000 e çıkardığım halde fark etmedi
Saygılarımla

 

[halit3]

Burada istenen userforma seçili alanın resmi mi yoksa bu seçili alanın resmini farklı bir kalasöre veya sayfaya kayıt yapmakmı ?
Eğer seçili alanı userforma resim olarak almaksa bu kodu bir deneyiniz.

#If Win64 Then
Private Declare PtrSafe Function OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare PtrSafe Function EmptyClipboard& Lib "user32" ()
Private Declare PtrSafe Function GetClipboardData& Lib "user32" (ByVal wFormat%)
Private Declare PtrSafe Function SetClipboardData& Lib "user32" (ByVal wFormat&, ByVal hMem&)
Private Declare PtrSafe Function CloseClipboard& Lib "user32" ()
Private Declare PtrSafe Function CopyImage& Lib "user32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare PtrSafe Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long

#Else
Private Declare Function OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare Function EmptyClipboard& Lib "user32" ()
Private Declare Function GetClipboardData& Lib "user32" (ByVal wFormat%)
Private Declare Function SetClipboardData& Lib "user32" (ByVal wFormat&, ByVal hMem&)
Private Declare Function CloseClipboard& Lib "user32" ()
Private Declare Function CopyImage& Lib "user32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long

#End If

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(8) As Byte
End Type

Private Type PICTDESC
cbSize As Long
picType As Long
hImage As Long
End Type
Private Sub ImageToMePicture()
Dim hCopy&: OpenClipboard 0&
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
CloseClipboard
If hCopy = 0 Then Exit Sub
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim IPic As IPicture, tIID As GUID, tPICTDEST As PICTDESC, Ret&
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID)
If Ret Then Exit Sub
With tPICTDEST
.cbSize = Len(tPICTDEST)
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(tPICTDEST, tIID, 1, IPic)
If Ret Then Exit Sub
UserForm1.Picture = LoadPicture("")
UserForm1.Picture = IPic

Set IPic = Nothing
End Sub


Private Sub UserForm_Activate()
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
sat = ActiveWindow.RangeSelection.Row
sut = ActiveWindow.RangeSelection.Column
Set Adres2 = ActiveSheet.Range(ActiveWindow.RangeSelection.Address)
ActiveSheet.Range(Adres2.Address).CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Cells(sat, sut).PasteSpecial
ActiveSheet.Shapes(Selection.Name).CopyPicture 1, 2

UserForm1.Height = ActiveSheet.Shapes(Selection.Name).OLEFormat.Object.ShapeRange.Height + 18
UserForm1.Width = ActiveSheet.Shapes(Selection.Name).OLEFormat.Object.ShapeRange.Width + 10

Call ImageToMePicture
ActiveSheet.Shapes(Selection.Name).Delete
OpenClipboard (0&)
EmptyClipboard
CloseClipboard

End Sub

 

[Haluk]

Alternatif bir dosya ekte verilmiş olup, UserForm'daki resim çözünürlüğü bence gayet güzeldir (HD kalitesinde ).... Ayrıca, UserForm'un yüksekliği sayfadan kopyalanan alanın boyutuna göre değişmektedir.




.

 

[Tevfik_Kursun]

Merhaba Halit3 Hocam,
İlginize çok teşekkür ederim. Aslında konu benim değil. Ama bu günlerde farklı bir konuya bakıyorum. Orada kullanabilir miyim diye merak etmiştim.
Oluşturmaya çalıştığım çalışmayı istediğim gibi sonuçlandıramazsam sizlere sorarım.
Saygılarımla

 

[Tevfik_Kursun]

Sayın Haluk Hocam,
Ekteki hata geldi. benim 64 bit Ofisi beğenmedi her halde.
Saygılarımla