• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

Sayın Hocam,
Teşekkürler, View Code yapmamışım.
Saygılarımla
 
Rica ederim, saygı bizden ...

.
 
216375Sn Hilt Bey, 49# nolu mesajdaki dosyayı kullandım. Sistemle ilgili mi bilmiyorum ama bende görünüm bu şekil oluyor.216376
 
@Haluk, 64 bit çalıştı, artık HD olarak temiz. Eline sağlık üstat.

.
 
Bilgisayara windows ofis 2013 64 bit yükledim ve kodlar çalıştı
Kodları aşağıdaki siteden aldım


Kod:
Option Explicit
Option Compare Text

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type

Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type

#If Win64 = 1 And VBA7 = 1 Then
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#Else
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#End If

Function PastePicture() As IPicture
Dim h As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long
If IsClipboardFormatAvailable(2) Then
h = OpenClipboard(0&)
If h > 0 Then
hPtr = GetClipboardData(2)
hCopy = CopyImage(hPtr, 0, 0, 0, &H4)
h = CloseClipboard
If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, 2)
End If
End If
End Function

Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture
Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture
Const PICTYPE_BITMAP = 1
Const PICTYPE_ENHMETAFILE = 4
With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
With uPicInfo
.Size = Len(uPicInfo)
.Type = PICTYPE_BITMAP
.hPic = hPic
.hPal = hPal
End With
r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
Set CreatePicture = IPic
End Function

Private Sub UserForm_Activate()
Dim Adres2
Set Adres2 = ActiveSheet.Range(ActiveWindow.RangeSelection.Address)
ActiveSheet.Range(Adres2.Address).CopyPicture Appearance:=xlScreen, Format:=xlBitmap
'SavePicture PastePicture(xlBitmap), sPicFile

Me.Picture = LoadPicture("")
Me.Picture = PastePicture '(xlBitmap), sPicFile
Me.Height = Adres2.Height + 24
Me.Width = Adres2.Width + 10

End Sub

Yeni Bit Eşlem Resmi.jpg
 

Ekli dosyalar

Sayın Halit3 Hocam,
Bu dosya da bende çalışmadı. Belki 2010 Office farkı.
Saygılarımla
 

Ekli dosyalar

  • 2020-04-10_20-51-36.png
    2020-04-10_20-51-36.png
    27.7 KB · Görüntüleme: 2
Tevfik Bey dosyaya iki adet komut düğmesi ekledim
Form Aç 2 düğmesini tıkla ve aşılan userfordaki komut duğmesini tıkla gözlemliyelim.
 

Ekli dosyalar

Bilgisayara windows ofis 2013 64 bit yükledim ve kodlar çalıştı...

Yüklemişken Office 2016 yükleseydiniz. Office 2013 biraz sorunlu, Referansları otomatik düzenleyemiyor. Bazı vba kodlarında uyum sorunu var.

Office 2016 EN 64 bit de aşağıdaki şekilde sorunlu.

216420
 
Son düzenleme:
Yüklemişken Office 2016 yükleseydiniz. Office 2013 biraz sorunlu, Referansları otomatik düzenleyemiyor. Bazı vba kodlarında uyum sorunu var.
Office 2016 EN 64 bit de aşağıdaki şekilde sorunlu.

Ben genelde ofis 2003 ve ofis 2007 kullanırım ve terciğim hep bunlar olmuştur.
Bu konu başlığı altında sorulan soru ile ilgili ofis 2013 64 bit yüklemiştim şimdi de ofis 2016 64 bit yükledim kodlar bende çalışıyor.




Yeni Bit Eşlem Resmi2.jpgYeni Bit Eşlem Resmi.jpg
 

Ekli dosyalar

Son düzenleme:
Sizi de yorduk Halit Bey. Uğraşınız için teşekkür ederim.
 
Günaydın Halit3 Hocam,
Elinize sağlık. Bu sefer çalıştı. Çok teşekkür ederim. Yoruldunuz ama!
Saygılarımla
 

Ekli dosyalar

  • 2020-04-11_07-11-46.png
    2020-04-11_07-11-46.png
    68.1 KB · Görüntüleme: 2
Hangi mesajdaki dosya çalıştı
 
Sayın Hocam,
69. mesaj Dosya1e.xlsm
Saygılarımla
 
71 nolu mesaja dosya eklemeyi unutmuşum.
 
Sayın Halit3 Hocam,
Evet, 71 kesintisiz çalışıyor Elinize sağlık.
Burada ekrandaki bölgeyi UserForm'a alıyor. Klasördeki resim, benzer şekilde UserForm'a nasıl alınır? Böyle bir örnek bakıyorum.
Saygılarımla
 
Sayın Halit3 Hocam,
Evet, 71 kesintisiz çalışıyor Elinize sağlık.
Burada ekrandaki bölgeyi UserForm'a alıyor. Klasördeki resim, benzer şekilde UserForm'a nasıl alınır? Böyle bir örnek bakıyorum.
Saygılarımla

Form3 ekledim kontrol ediniz.
 

Ekli dosyalar

78 nolu dosyayı güncelledim
 
Geri
Üst