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

[Tevfik_Kursun]

Merhaba Arkadaşlar,
Sizleri sıkıntıya sokmuş gibi hissediyorum. Ama sonuçları paylaşıyorum. Lütfen benim için üzerinde durmayın.
Haluk hocanın son dosya sonucu Resim1...
Halit3 hocanın dosya2 sonucu Resim2... ve Resim3... Form Aç 1
Halit3 hocanın dosya2 sonucu Resim3... ve Resim4... Form Aç 2
Halit3 hocanın dosya4 sonucu Resim5... ve Resim6... Form Aç 3
Saygılarımla

 

[halit3]

Sayın Muhammet Okumuş
userform1 seçli alandan büyük onun için ekran görüntüsü bozuluyor
eklemiş olduğunuz görüntü ilk başdaki kodlara ait olmalı
38 nolu mesajdaki dosyaya ait ekran görüntülerini paylaşırmısınız.

 

[Muhammet Okumuş]

Hiçbirinde resim oluşmadı.

 

[Haluk]

Merhaba Arkadaşlar,
Sizleri sıkıntıya sokmuş gibi hissediyorum. Ama sonuçları paylaşıyorum. Lütfen benim için üzerinde durmayın.
......
....

Tevfik Bey, siz üzülmeyin .... ben kafayı 64 Bit'e taktığım için uğraşıyorum..... 18 No'lu mesajdaki dosyaya birkaç ilave yapıp, bir de hata denetimi ekledim, çalıştırdığınızda aldığınız hata mesajını söylerseniz belki bir ipucu yakalarız....

.

 

[Korhan Ayhan]

@Tevfik_Kursun,

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

DEBUG dediğinizde oluşan ekran görüntüsünü paylaşabilir misiniz?

 

[halit3]

Profilinizde ofisin 2010 sürümü olduğu gözüküyor dosya ofis 2003 formatından ofis 2010 formatına değiştirip denermisiniz.

 

[halit3]

Fazlada israrcı olmayacağım farklı bir yöntem daha var. Bunda apiler yok.
clipbrd.dll nesnesi ile çok küçük bir kod ile bu işlem oluyor.

kod:

Private Sub UserForm_Activate()

Dim myClp As Object
Set myClp = CreateObject("clipbrd.clipboard")
myClp.Clear
adres = ActiveWindow.RangeSelection.Address
Set Adres2 = ActiveSheet.Range(adres)
ActiveSheet.Range(Adres2.Address).Copy
Me.Picture = myClp.GetData
Me.Height = Adres2.Height + 22
Me.Width = Adres2.Width
myClp.Clear
End Sub

kodun çalışması için referanslarda clipbrd.dll dosyası olmalı

 

[Tevfik_Kursun]

Sayın Korhan Ayhan Hocam,
Günaydın,
Resim10, bu sabah indirdiğim dosyanızdan
Gün içinde ne zaman isterseniz bağlanıp DEBUG için bakabilirsiniz.
Saygılarımla

 

[halit3]

Sayın Muhammet Okumuş

39 nolu mesajdaki dosya ve kodları. 17 nolu mesajdan aldığınız anlaşılıyor orada resim geliyor ama orantısı bozuk olarak görünüyor kad da genişlik ve yükseklik ayarları aktif ama dosyada aktif değildi şimdi aynı dosyayı ve kodu yeniden ekliyorum denermisiniz.

#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
Me.Picture = LoadPicture("")
Me.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
Me.Height = ActiveSheet.Shapes(Selection.Name).OLEFormat.Object.ShapeRange.Height + 18
Me.Width = ActiveSheet.Shapes(Selection.Name).OLEFormat.Object.ShapeRange.Width + 10
ActiveSheet.Shapes(Selection.Name).CopyPicture 1, 2
Call ImageToMePicture
ActiveSheet.Shapes(Selection.Name).Delete
Range(Adres2.Address).Select
OpenClipboard (0&)
EmptyClipboard
CloseClipboard

End Sub

 

[Tevfik_Kursun]

Günaydın Halit3 Hocam,
Saygılarımla

 

[Haluk]

@Tevfik_Kursun / @Zeki Gürsoy ... (Ya da, 64 Bit Excel kullanan bir üyemiz...)

18 No'lu mesajdaki dosyayı biraz önce tekrar revize ettim, tekrar deneyebilirmisiniz?

.

 

[Ömer]

Haluk Bey,

Bende sorunsuz çalıştı.
Bilginize, elinize sağlık.

 

[Haluk]

Ömer Bey, Excel 64 Bit kullanıyorsunuz, öyle değil mi?

.

 

[Tevfik_Kursun]

Sayın Haluk Hocam,
Sonuç mükemmel. Elinize sağlık. Dosyada makro da görünmüyor. Sistem nasıl çalışıyor?
Saygılarımla

 

[Ömer]

Ömer Bey, Excel 64 Bit kullanıyorsunuz, öyle değil mi?.

Evet Haluk Bey, şuan kullandığım bilgisayar 64 Bit.

 

[Haluk]

Vayyy..... hem Ömer Beyden hem de Tevfik Beyden olumlu geri dönüş olduğuna göre, bu iş 32 ve 64 Bit Excel'de tamamdır .....

Teşekkürler beyler,

.

 

[Asri]

@Tevfik_Kursun / @Zeki Gürsoy ... (Ya da, 64 Bit Excel kullanan bir üyemiz...)

18 No'lu mesajdaki dosyayı biraz önce tekrar revize ettim, tekrar deneyebilirmisiniz?

.

Hiç bir ayarlama yapmadan direkt çalıştı. Office 2016 EN 64 bit.

Formdaki resim daha mı net )

 

[Haluk]

Bilgi için teşekkürler Asri Bey, güzel haber ...

.

 

[Tevfik_Kursun]

Sayın Haluk Hocam,
Şunun bir de sırrını paylaşırsanız sevinirim.
Saygılarımla

 

[Haluk]

Tevfik Bey, UserForm modülünün içinde bir kamyon dolusu API ve kod var ....

.