• DİKKAT

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

UserForm dan Excel Çalışma Sayfasına resim aktarma

O

onurcan1979

Katılım
29 Mayıs 2010
Mesajlar
186
Excel Vers. ve Dili
2003 tr
merhaba arkadaşlar ben bir personel veri sistemi yapmaya çalışıyorum ve bir yerde takıldım UserForma resim getire biliyorum fakat UserFormdan Excel Çalışma Sayfasına resmi bir türlü aktaramadım forum içerisinde arama yaptım ama sisteme uyarlayamadım bana bu konuda yardım edebilirseniz çok sevinirim dosya ektedir
 

Ekli dosyalar

onurcan1979' Alıntı:
merhaba arkadaşlar ben bir personel veri sistemi yapmaya çalışıyorum ve bir yerde takıldım UserForma resim getire biliyorum fakat UserFormdan Excel Çalışma Sayfasına resmi bir türlü aktaramadım forum içerisinde arama yaptım ama sisteme uyarlayamadım bana bu konuda yardım edebilirseniz çok sevinirim dosya ektedir
Genişletmek için tıkla ...

Kod:
Kod: 
Private Sub RESIMBUL2_Click()
Dim Resim As OLEObject
Dim Adres As Range
Set s1 = Sheets("BİLGİ.KARTI")
sat1 = 2
sat2 = 11
sut1 = "C"
sut2 = "D"
Set Adres = s1.Range(s1.Cells(sat1, sut1).Address, s1.Cells(sat2, sut2).Address)
Dim Picture As Object
For Each Picture In s1.Shapes
If Not Intersect(s1.Range(Picture.TopLeftCell.Address & ":" & Picture.BottomRightCell.Address), Adres) Is Nothing Then
Picture.Delete
End If
Next Picture
Dim uzanti(3)
uzanti(1) = "bmp": uzanti(2) = "jpg": uzanti(3) = "gif"
Klasör = ThisWorkbook.Path & "\Resimler\"
isim = TextBox3.Text
For i = 1 To 3
resimadi = Klasör & isim & "." & uzanti(Val(i))
If CreateObject("Scripting.FileSystemObject").FileExists(resimadi) = True Then
ad = s1.Pictures.Insert(resimadi).Name
s1.Shapes(ad).OLEFormat.Object.Select
s1.Shapes(ad).OLEFormat.Object.Top = Adres.Top + 1
s1.Shapes(ad).OLEFormat.Object.Left = Adres.Left + 1
s1.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height - 1
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width - 1
Exit For
End If
Next
End Sub
 

Ekli dosyalar

halit3' Alıntı:
Kod:
Kod: 
Private Sub RESIMBUL2_Click()
Dim Resim As OLEObject
Dim Adres As Range
Set s1 = Sheets("BİLGİ.KARTI")
sat1 = 2
sat2 = 11
sut1 = "C"
sut2 = "D"
Set Adres = s1.Range(s1.Cells(sat1, sut1).Address, s1.Cells(sat2, sut2).Address)
Dim Picture As Object
For Each Picture In s1.Shapes
If Not Intersect(s1.Range(Picture.TopLeftCell.Address & ":" & Picture.BottomRightCell.Address), Adres) Is Nothing Then
Picture.Delete
End If
Next Picture
Dim uzanti(3)
uzanti(1) = "bmp": uzanti(2) = "jpg": uzanti(3) = "gif"
Klasör = ThisWorkbook.Path & "\Resimler\"
isim = TextBox3.Text
For i = 1 To 3
resimadi = Klasör & isim & "." & uzanti(Val(i))
If CreateObject("Scripting.FileSystemObject").FileExists(resimadi) = True Then
ad = s1.Pictures.Insert(resimadi).Name
s1.Shapes(ad).OLEFormat.Object.Select
s1.Shapes(ad).OLEFormat.Object.Top = Adres.Top + 1
s1.Shapes(ad).OLEFormat.Object.Left = Adres.Left + 1
s1.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height - 1
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width - 1
Exit For
End If
Next
End Sub
Genişletmek için tıkla ...

Halit hocam herzamanki gibi hemen yetiştinin imdadıma çok teşekkür ederim. emeğinize bilginize sağlık
 
halit3' Alıntı:
Kod:
Kod: 
Private Sub RESIMBUL2_Click()
Dim Resim As OLEObject
Dim Adres As Range
Set s1 = Sheets("BİLGİ.KARTI")
sat1 = 2
sat2 = 11
sut1 = "C"
sut2 = "D"
Set Adres = s1.Range(s1.Cells(sat1, sut1).Address, s1.Cells(sat2, sut2).Address)
Dim Picture As Object
For Each Picture In s1.Shapes
If Not Intersect(s1.Range(Picture.TopLeftCell.Address & ":" & Picture.BottomRightCell.Address), Adres) Is Nothing Then
Picture.Delete
End If
Next Picture
Dim uzanti(3)
uzanti(1) = "bmp": uzanti(2) = "jpg": uzanti(3) = "gif"
Klasör = ThisWorkbook.Path & "\Resimler\"
isim = TextBox3.Text
For i = 1 To 3
resimadi = Klasör & isim & "." & uzanti(Val(i))
If CreateObject("Scripting.FileSystemObject").FileExists(resimadi) = True Then
ad = s1.Pictures.Insert(resimadi).Name
s1.Shapes(ad).OLEFormat.Object.Select
s1.Shapes(ad).OLEFormat.Object.Top = Adres.Top + 1
s1.Shapes(ad).OLEFormat.Object.Left = Adres.Left + 1
s1.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height - 1
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width - 1
Exit For
End If
Next
End Sub
Genişletmek için tıkla ...

Halit hocam farklı iki resmi aynı çalışma sayfasına nasıl aktara biliriz yapmaya çalıştım ama Userformda getire bildim fakat ikisinide aktartamadım ikisinden birini çıkartıyor çalışma sayfasından bana bu konuda yardımcı olursanız?
 
onurcan1979' Alıntı:
Halit hocam farklı iki resmi aynı çalışma sayfasına nasıl aktara biliriz yapmaya çalıştım ama Userformda getire bildim fakat ikisinide aktartamadım ikisinden birini çıkartıyor çalışma sayfasından bana bu konuda yardımcı olursanız?
Genişletmek için tıkla ...

Sayfaya iki edet image resmi ekle ve bu kodları kullan

Kod: 
Sheets("BİLGİ.KARTI").Image1.Picture = UserForm1.Image1.Picture
Sheets("BİLGİ.KARTI").Image2.Picture = UserForm1.Image2.Picture
 
halit3' Alıntı:
Sayfaya iki edet image resmi ekle ve bu kodları kullan

Kod: 
Sheets("BİLGİ.KARTI").Image1.Picture = UserForm1.Image1.Picture
Sheets("BİLGİ.KARTI").Image2.Picture = UserForm1.Image2.Picture
Genişletmek için tıkla ...

Dim Resim As OLEObject
Dim Adres As Range
Set s1 = Sheets("PERSONEL_BİLGİKARTI")
sat1 = 7
sat2 = 14
sut1 = "N"
sut2 = "O"
Set Adres = s1.Range(s1.Cells(sat1, sut1).Address, s1.Cells(sat2, sut2).Address)
Dim Picture As Object
For Each Picture In s1.Shapes
If Not Intersect(s1.Range(Picture.TopLeftCell.Address & ":" & Picture.BottomRightCell.Address), Adres) Is Nothing Then
Picture.Delete
End If
Next Picture
Dim uzanti(3)
uzanti(1) = "bmp": uzanti(2) = "jpg": uzanti(3) = "gif"
Klasör = ThisWorkbook.Path & "\Resimler\"
isim = TextBox8.Text
For i = 1 To 3
resimadi = Klasör & isim & "." & uzanti(Val(i))
If CreateObject("Scripting.FileSystemObject").FileExists(resimadi) = True Then
ad = s1.Pictures.Insert(resimadi).Name
s1.Shapes(ad).OLEFormat.Object.Select
s1.Shapes(ad).OLEFormat.Object.Top = Adres.Top + 1
s1.Shapes(ad).OLEFormat.Object.Left = Adres.Left + 1
s1.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height - 1
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width - 1

Exit For
End If
Next

kodları nereye yazmam gerek
 
onurcan1979' Alıntı:
iyi günler hayırlı Ramazanlar
Genişletmek için tıkla ...

İkinci resimi ve birinci resimi nerden nereye aldığınıza dair örnek bir dosya ekleyin ve userformunuza resimleri alan kodlarınızda mevcutmu bunları bilelim ona göre bir çözüm sunalım.

Bu birinci ve ikinci resimleri userformda nerereye alıyorsunuz. Sonra buresimler hangi sayfada nerelerde gözükecek bunlara dair açıklamalarınızı yapın
 
Halit bey tekrar göz gezdirince hatamı gördüm şu şekide yapım doğruluğunu teyit ederseniz çok sevinirim ilginiz için çok teşekkürler
 

Ekli dosyalar

onurcan1979' Alıntı:
Halit bey tekrar göz gezdirince hatamı gördüm şu şekide yapım doğruluğunu teyit ederseniz çok sevinirim ilginiz için çok teşekkürler
Genişletmek için tıkla ...

Sizinki olmuş ama ben farklı bir uygulama ekliyorum. Ayrıca saat içinde bir nesne ekliyorum.diğer türlü döngü exceli kasıyor.
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst