• 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ı)

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 istiyorum, 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, üstadlarım yardımlarınızı bekliyorum, şimdiden Allah razı olsun.

http://s8.dosya.tc/server5/fydjyw/Personel_Yaka_Karti.rar.html
 

Ekli dosyalar

Mevcut dosyanız ile ilgili (PersonelResimler) klasöründe tablonuzdaki isimler ile aynı olmalı sizin tablonuzdaki isimler A , B ,C vb gitmekte klasörün içindeki resimlerde 1 , 2 diye gitmekte resimlerin adını tablonuzdaki isimlerle aynı yapın

kod:

Kod: 
Sub resimgetir()

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

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

Set Adres = Range(Cells(sat, sut), Cells(sat + 5, 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
Else
ActiveSheet.Pictures.Insert(klasor & "ResimYok.jpg").Select
End If
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

sut = sut + 5
If sut > 18 Then
sut = 3
sat = sat + 15
End If
Next
Cells(1, 1).Select
End Sub
 

Ekli dosyalar

Alternatif;

Kart sayfasında bir kaç ekleme ve değişiklik yapıldı.
Resimler , personel listesindeki isimler ile yanı olmalıdır.
Kart sayfasındaki A3 hücresi değiştiğinde program çalışacaktır.
Kontrol ediniz.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Or Target.Value = "" Then Exit Sub
    If Intersect(Target, Range("A3:A3")) Is Nothing Then Exit Sub
    On Error Resume Next
    Call resimleri_sil
    yol = ActiveWorkbook.Path & "\PersonelResimler\"
    satir = 3
    For i = 3 To 24 Step 6
      resimyolu = yol & Cells(satir + 3, i + 2).Value & ".jpg"
      If Not dosyavarmi(resimyolu) Then resimyolu = yol & "ResimYok.jpg"
      Set Rng = Cells(satir + 2, i)
      Rng.Select
      Set sShape = ActiveSheet.Shapes.AddPicture(resimyolu, msoFalse, msoCTrue, Selection.Left, Selection.Top, Selection.Width, Selection.Height)
    Next i
    
    satir = 18
    For i = 3 To 24 Step 6
      resimyolu = yol & Cells(satir + 3, i + 2).Value & ".jpg"
      If Not dosyavarmi(resimyolu) Then resimyolu = yol & "ResimYok.jpg"
      Set Rng = Cells(satir + 2, i)
      Rng.Select
      Set sShape = ActiveSheet.Shapes.AddPicture(resimyolu, msoFalse, msoCTrue, Selection.Left, Selection.Top, Selection.Width, Selection.Height)
    Next i
    
End Sub

Sub resimleri_sil()
      Set MyRange = Range("A1:Z30")
      For Each sShape In ActiveSheet.Shapes
        If Not Intersect(Range(sShape.TopLeftCell.Address), MyRange) Is Nothing Then
           If sShape.Type <> 8 And sShape.Type <> 12 Then
              sShape.Delete
           End If
        End If
      Next
End Sub

Function dosyavarmi(dosya)
  Dim ds, a
  Set ds = CreateObject("Scripting.FileSystemObject")
  a = ds.FileExists(dosya)
  If a = True Then
    dosyavarmi = True
  Else
    dosyavarmi = False
  End If
End Function
 

Ekli dosyalar

halit3' Alıntı:
Mevcut dosyanız ile ilgili (PersonelResimler) klasöründe tablonuzdaki isimler ile aynı olmalı sizin tablonuzdaki isimler A , B ,C vb gitmekte klasörün içindeki resimlerde 1 , 2 diye gitmekte resimlerin adını tablonuzdaki isimlerle aynı yapın

kod:

Kod: 
Sub resimgetir()

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

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

Set Adres = Range(Cells(sat, sut), Cells(sat + 5, 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
Else
ActiveSheet.Pictures.Insert(klasor & "ResimYok.jpg").Select
End If
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

sut = sut + 5
If sut > 18 Then
sut = 3
sat = sat + 15
End If
Next
Cells(1, 1).Select
End Sub
Genişletmek için tıkla ...

Sayın halit3 Allah sizden razı olsun, minnettarım.
 
asri' Alıntı:
Alternatif;

Kart sayfasında bir kaç ekleme ve değişiklik yapıldı.
Resimler , personel listesindeki isimler ile yanı olmalıdır.
Kart sayfasındaki A3 hücresi değiştiğinde program çalışacaktır.
Kontrol ediniz.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Or Target.Value = "" Then Exit Sub
    If Intersect(Target, Range("A3:A3")) Is Nothing Then Exit Sub
    On Error Resume Next
    Call resimleri_sil
    yol = ActiveWorkbook.Path & "\PersonelResimler\"
    satir = 3
    For i = 3 To 24 Step 6
      resimyolu = yol & Cells(satir + 3, i + 2).Value & ".jpg"
      If Not dosyavarmi(resimyolu) Then resimyolu = yol & "ResimYok.jpg"
      Set Rng = Cells(satir + 2, i)
      Rng.Select
      Set sShape = ActiveSheet.Shapes.AddPicture(resimyolu, msoFalse, msoCTrue, Selection.Left, Selection.Top, Selection.Width, Selection.Height)
    Next i
    
    satir = 18
    For i = 3 To 24 Step 6
      resimyolu = yol & Cells(satir + 3, i + 2).Value & ".jpg"
      If Not dosyavarmi(resimyolu) Then resimyolu = yol & "ResimYok.jpg"
      Set Rng = Cells(satir + 2, i)
      Rng.Select
      Set sShape = ActiveSheet.Shapes.AddPicture(resimyolu, msoFalse, msoCTrue, Selection.Left, Selection.Top, Selection.Width, Selection.Height)
    Next i
    
End Sub

Sub resimleri_sil()
      Set MyRange = Range("A1:Z30")
      For Each sShape In ActiveSheet.Shapes
        If Not Intersect(Range(sShape.TopLeftCell.Address), MyRange) Is Nothing Then
           If sShape.Type <> 8 And sShape.Type <> 12 Then
              sShape.Delete
           End If
        End If
      Next
End Sub

Function dosyavarmi(dosya)
  Dim ds, a
  Set ds = CreateObject("Scripting.FileSystemObject")
  a = ds.FileExists(dosya)
  If a = True Then
    dosyavarmi = True
  Else
    dosyavarmi = False
  End If
End Function
Genişletmek için tıkla ...

Sayın asri Allah sizden razı olsun, minnettarım.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst