• DİKKAT

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

Klasörden resim çekme (Yaka Kartı) Yardım Lütfen

  • Konbuyu başlatan Konbuyu başlatan lion3535
  • Başlangıç tarihi Başlangıç tarihi
L

lion3535

Katılım
13 Ocak 2008
Mesajlar
103
Excel Vers. ve Dili
Office 2016 Türkçe
Arkadaşlar, personel yaka kartı için sizlerden bir ricam var, yardımcı olursanız sevinirim.

Klasördeki vesikalık resimlerin yaka kartına otomatik yerleşmesini rica ediyorum, forumda konuyla ilgili örnekler var ama ben beceremedim, bir A4 kağıdına 8 tane yaka kartı sığacak şekilde ayarladım, yaka kartına yerleşecek resim boyutları kartın resim bölümündeki kutucuğun büyüklüğünde olması lazım, klasördeki resimlere sicil no yazdım yani sicil nosuna göre resim çağıracak, resimgetir butonuna basınca resimleri çağıracak, üstadlarım yardımlarınızı bekliyorum, şimdiden Allah razı olsun.

http://www.dosya.tc/server11/lcwwo4/Personel_Yaka_Karti.rar.html
 

Ekli dosyalar

kod:


Kod: 
Sub resimgetir()

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes

If Picture.Type = 11 Or Picture.Type = 12 Or Picture.Type = 13 Then
Picture.Delete
End If
Next Picture

sut = 3
sat = 5
For i = 1 To 8

Set Adres = Range(Cells(sat, sut), Cells(sat + [COLOR="red"]7[/COLOR], sut))

klasor = ThisWorkbook.Path & "\PersonelResimler\"
isim = Cells(sat + 1, sut + 1).Value

    If CreateObject("Scripting.FileSystemObject").FileExists(klasor & isim & ".jpg") = True Then
    ActiveSheet.Pictures.Insert(klasor & isim & ".jpg").Select
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.Top = Adres.Top + 2
    Selection.Left = Adres.Left + 2
    Selection.ShapeRange.Height = Adres.Height - 3
    Selection.ShapeRange.Width = Adres.Width - 6
    Selection.Name = isim
    Else
    
        If CreateObject("Scripting.FileSystemObject").FileExists(klasor & "ResimYok.jpg") = True Then
        ActiveSheet.Pictures.Insert(klasor & "ResimYok.jpg").Select
        Selection.ShapeRange.LockAspectRatio = msoFalse
        Selection.Top = Adres.Top + 2
        Selection.Left = Adres.Left + 2
        Selection.ShapeRange.Height = Adres.Height - 3
        Selection.ShapeRange.Width = Adres.Width - 6
        Selection.Name = isim
        End If
    End If

sut = sut + 5
If sut > 18 Then
sut = 3
sat = sat + [COLOR="Red"]17[/COLOR]
End If
Next
Cells(1, 1).Select
End Sub
 
Sayın halit3 süper oldu vallahi Allah sizden razı olsun, minnettarım.
 
Herkese iyi akşamlar. Öncelikle konuyu başlatan, cevap veren ve excel.web.tr ailesine teşekkürler. Güzel bir çalışma olmuş dosyayı indirdim ama bende hata verdi. Print Screen görüntüsünü attım sebebi ne olabilir acaba?
 

Ekli dosyalar

Son düzenleme:
Muhtemelen resim adının bulunduğu formüllerde YOK# hata değeri oldugundan olmuyordur.
 
Ne yapmamız gerekir?

Ne yapmamız gerekir sorun çözülemez mi?
 
Siz dosyanın içindeki kodu 2 nolu mesajdaki kod ile değiştirmemişsiniz.

Ayrıca Hücrelerde Adı soyadı yazan yerlerde formüllerde #YOK yazan yerler varmı?
 
Sayın halit3 şimdi oldu ben ek içerisindeki dosyadan makroyu değiştirmemiştim. Değiştirdim şimdi çalışıyor. Teşekkürler güzel bir çalışma olmuş.
 
Son düzenleme:
Sayın Halit Bey, bu güzel bir çalışma olmuş, ellerinize sağlık. Bu benimde işime yarayacak.

Sayfa üzerindeki resim sil butonuna bastığımda sayfa üzerindeki resimleri silmiyor.

Aşağıdaki kodlar butonda bulunan kodlar, bu kodları nasıl değiştirmemiz gerekiyor?
Yardımcı olur musunuz?

Kod: 
Sub sil()
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If Picture.Type = 1 Or Picture.Type = 12 Or Picture.Type = 13 Then
Picture.Delete
End If
Next Picture
End Sub
 
ASLAN7410' Alıntı:
Sayın Halit Bey, bu güzel bir çalışma olmuş, ellerinize sağlık. Bu benimde işime yarayacak.

Sayfa üzerindeki resim sil butonuna bastığımda sayfa üzerindeki resimleri silmiyor.

Aşağıdaki kodlar butonda bulunan kodlar, bu kodları nasıl değiştirmemiz gerekiyor?
Yardımcı olur musunuz?
Genişletmek için tıkla ...


Kod: 
Sub sil()

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
MsgBox Picture.Type
If Picture.Type = [COLOR="Red"]11[/COLOR] Or Picture.Type = 12 Or Picture.Type = 13 Then
Picture.Delete
End If
Next Picture
End Sub

Kırmızı yere dikkat ediniz.
 
Sayın Halit Bey ilginiz için çok teşekkür ediyorum, kod tam istediğim gibi çalışmıyor, sürekli mesaj geliyor, mesaja tamam dedikçe mesaj açıyor, mesajlar bitince de resimlerin olduğu yer boş kalıyor.

Göndermiş olduğum örnekte, sil butonuna bastığımda resimlerin hepsini kaldırıp, bu resimlerin yerine 6.sıradaki Resim Yok Klasöre Resim Ekleyin resminin eklenmesini istemiştim.

Bu şekilde yardımcı olur musunuz?
.
 

Ekli dosyalar

Son düzenleme:
Tam olarak ne demek istediğinizi analayamadım göndermiş olduğunuz dosyadaki kodları silin bu kodları yapıştırın

Kod: 
Sub sil()

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If Picture.Type = 11 Or Picture.Type = 12 Or Picture.Type = 13 Then
Picture.Delete
End If
Next Picture
End Sub

Kod: 
Sub resimgetir()

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes

If Picture.Type = 11 Or Picture.Type = 12 Or Picture.Type = 13 Then
Picture.Delete
End If
Next Picture

sut = 3
sat = 5
For i = 1 To 8

Set Adres = Range(Cells(sat, sut), Cells(sat + 7, sut))

klasor = ThisWorkbook.Path & "\PersonelResimler\"
isim = Cells(sat + 1, sut + 1).Value

    If CreateObject("Scripting.FileSystemObject").FileExists(klasor & isim & ".jpg") = True Then
    ActiveSheet.Pictures.Insert(klasor & isim & ".jpg").Select
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.Top = Adres.Top + 2
    Selection.Left = Adres.Left + 2
    Selection.ShapeRange.Height = Adres.Height - 7
    Selection.ShapeRange.Width = Adres.Width - 4
    Selection.Name = isim
    Else
    
        If CreateObject("Scripting.FileSystemObject").FileExists(klasor & "ResimYok.jpg") = True Then
        ActiveSheet.Pictures.Insert(klasor & "ResimYok.jpg").Select
        Selection.ShapeRange.LockAspectRatio = msoFalse
        Selection.Top = Adres.Top + 2
        Selection.Left = Adres.Left + 2
        Selection.ShapeRange.Height = Adres.Height - 7
        Selection.ShapeRange.Width = Adres.Width - 4
        Selection.Name = isim
        End If
    End If

sut = sut + 5
If sut > 18 Then
sut = 3
sat = sat + 17
End If
Next
Cells(1, 1).Select
End Sub
 
Sayın Halit Bey, göndermiş olduğum excel dosyasında resimler bağlantılı olduğundan oraları boş çıkmış, ekran alıntısını gönderiyorum.

Sil butonuna bastığımda resimlerin bulunduğu yerlere bu şekilde gelmesini istiyorum.
 

Ekli dosyalar

  • Örnek.jpg
    Örnek.jpg
    342.2 KB · Görüntüleme: 13
Sil komut duğmesini bununla değiştir.

Kod: 
Sub sil()

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If Picture.Type = 11 Or Picture.Type = 12 Or Picture.Type = 13 Then
Picture.Delete
End If
Next Picture
sut = 3
sat = 5
For i = 1 To 8

Set Adres = Range(Cells(sat, sut), Cells(sat + 7, sut))

klasor = ThisWorkbook.Path & "\PersonelResimler\"
[COLOR="Red"]isim = sat & " " & sut & " " & Cells(sat + 1, sut + 1).Value[/COLOR]

If CreateObject("Scripting.FileSystemObject").FileExists(klasor & "ResimYok.jpg") = True Then
ActiveSheet.Pictures.Insert(klasor & "ResimYok.jpg").Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Top = Adres.Top + 2
Selection.Left = Adres.Left + 2
Selection.ShapeRange.Height = Adres.Height - 7
Selection.ShapeRange.Width = Adres.Width - 4
Selection.Name = isim
End If

sut = sut + 5
If sut > 18 Then
sut = 3
sat = sat + 17

End If
Next
Cells(1, 1).Select



End Sub
 
Sayın Halit Bey, kusura bakmayın uğraştırıyorum.

Sil butonuna bastığımda debug çıkıyor, debug'a bastığımda kod içerisinde Selection.Name = isim burayı sarıya boyuyor.
.
 

Ekli dosyalar

  • Ekran Alıntısı.jpg
    Ekran Alıntısı.jpg
    21 KB · Görüntüleme: 2
  • Ekran Alıntısı1.jpg
    Ekran Alıntısı1.jpg
    17.9 KB · Görüntüleme: 2
yukarıdaki mesajdaki kodu düzelttim
 
Sayın Halit Bey, çok teşekkür ediyorum, hayırlı çalışmalar, hayırlı geceler diliyorum.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst