Excel Forum

Excel Forum (http://www.excel.web.tr/index.php)
-   Excel'e Yeni Başlayanlar (http://www.excel.web.tr/forumdisplay.php?f=14)
-   -   Klasörden resim çekme (Yaka Kartı) Yardım Lütfen (http://www.excel.web.tr/showthread.php?t=169449)

lion3535 02-01-2018 19:48

Klasörden resim çekme (Yaka Kartı) Yardım Lütfen
 
1 Eklenti(ler)
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/...Karti.rar.html

halit3 02-01-2018 20:00

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 + 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 - 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 + 17
End If
Next
Cells(1, 1).Select
End Sub


lion3535 02-01-2018 20:23

Sayın halit3 süper oldu vallahi Allah sizden razı olsun, minnettarım.

yyhy 07-01-2018 18:47

1 Eklenti(ler)
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?

halit3 07-01-2018 18:55

Muhtemelen resim adının bulunduğu formüllerde YOK# hata değeri oldugundan olmuyordur.

yyhy 07-01-2018 19:05

Ne yapmamız gerekir?
 
Ne yapmamız gerekir sorun çözülemez mi?

halit3 07-01-2018 20:01

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ı?

yyhy 07-01-2018 20:29

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ş.

ASLAN7410 07-01-2018 22:17

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


halit3 08-01-2018 07:58

Alıntı:

ASLAN7410 tarafından gönderildi (Mesaj 925011)
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
MsgBox Picture.Type
If Picture.Type = 11 Or Picture.Type = 12 Or Picture.Type = 13 Then
Picture.Delete
End If
Next Picture
End Sub

Kırmızı yere dikkat ediniz.


Saat 19:53

Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.