UserForm'a Resim Getirip CommandButton ile Hücreye yapıştırma

cocoa35

Altın Üye
Katılım
6 Eylül 2007
Mesajlar
654
Excel Vers. ve Dili
excel 2016 32 Bit ve Excel 2020 32 Bit Türkçe ve İngilizce
Altın Üyelik Bitiş Tarihi
10-12-2024
Merhaba üstatlar ekli örnek dosyada UserForm'a bilgisayardaki herhangi bir resmi alabiliyorum ancak userform üstündeki commandbutton ile o resmi hücreye göndermek istiyorum ama kod hata veriyor nasıl düzeltilebilir acaba?
 

Ekli dosyalar

cocoa35

Altın Üye
Katılım
6 Eylül 2007
Mesajlar
654
Excel Vers. ve Dili
excel 2016 32 Bit ve Excel 2020 32 Bit Türkçe ve İngilizce
Altın Üyelik Bitiş Tarihi
10-12-2024
Merhaba üstatlar ekli örnek dosyada UserForm'a bilgisayardaki herhangi bir resmi alabiliyorum ancak userform üstündeki commandbutton ile o resmi hücreye göndermek istiyorum ama kod hata veriyor nasıl düzeltilebilir acaba?
Bu konuda yardım lütfen
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,798
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Kodun çalışması için referanslara clipbrd.dll dosyası yüklü olmalı

Rich (BB code):
Private Sub CommandButton2_Click()

Dim myClp As Object

Set myClp = CreateObject("clipbrd.clipboard")
myClp.Clear
myClp.setData UserForm1.Image1.Picture, 2 '‘The 2 is for bitmaps

If Not Image1.Picture Is Nothing Then
myClp.setData Image1.Picture
Else
MsgBox "Resim yok"
Exit Sub
End If

Worksheets(ActiveSheet.Name).Paste Destination:=Worksheets(ActiveSheet.Name).Range("d8")
say = Worksheets(ActiveSheet.Name).Shapes.Count
ad1 = Worksheets(ActiveSheet.Name).Shapes(say).Name



Dim sat, sat2, sut, sut2
sut = 4
sat = 8
sut2 = 7
sat2 = 16

Set adres = Worksheets(ActiveSheet.Name).Range(Worksheets(ActiveSheet.Name).Range(Worksheets(ActiveSheet.Name).Cells(sat, sut), Worksheets(ActiveSheet.Name).Cells(sat2, sut2)).Address)

Worksheets(ActiveSheet.Name).Shapes(ad1).OLEFormat.Object.Top = adres.Top + 2
Worksheets(ActiveSheet.Name).Shapes(ad1).OLEFormat.Object.Left = adres.Left + 2
Worksheets(ActiveSheet.Name).Shapes(ad1).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
Worksheets(ActiveSheet.Name).Shapes(ad1).OLEFormat.Object.ShapeRange.Height = adres.Height - 4
Worksheets(ActiveSheet.Name).Shapes(ad1).OLEFormat.Object.ShapeRange.Width = adres.Width - 4

MsgBox "Soru kağıda aktarıldı.", vbInformation, "      Bilgi"

End Sub
 

cocoa35

Altın Üye
Katılım
6 Eylül 2007
Mesajlar
654
Excel Vers. ve Dili
excel 2016 32 Bit ve Excel 2020 32 Bit Türkçe ve İngilizce
Altın Üyelik Bitiş Tarihi
10-12-2024
Merhaba Halit3 "clipbrd.dll " dosyasını nasıl referanslara yüklerim baktım listede yok
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,798
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
size bir adet clipboard.dll dosyası gönderiyorum bunu
c:\windows\SysWOW64\ ve c:\windows\System32\ dosyalarına kopyalayın.

daha sonra aşağıdaki işlemleri yapın

Bilgisayardan başlangıçdaki uygulamalardan cmd yazıp arama yaparak komut istemi dosyasını yönetici olarak aç.

1-klasöre giriş
cd c:\windows\SysWOW64\
yazım entere basın sonra altdaki bölümü yapıştırın ve entere basın
regsvr32 c:\windows\SysWOW64\clipboard.dll


2-klasöre giriş
cd c:\windows\System32\
yazım entere basın sonra altdaki bölümü yapıştırın ve entere basın
regsvr32 c:\windows\System32\clipboard.dll

not: komut istemi dosyasını yönetici olarak çalıştırmazsanız bu işlemler olmaz.
 

Ekli dosyalar

cocoa35

Altın Üye
Katılım
6 Eylül 2007
Mesajlar
654
Excel Vers. ve Dili
excel 2016 32 Bit ve Excel 2020 32 Bit Türkçe ve İngilizce
Altın Üyelik Bitiş Tarihi
10-12-2024
Tamam çok teşekkürler :)
 
Üst