Resim Dosyası Yolunun Kopyalanması

[1Al2Ver]

Merhaba,

Kitap2 klasöründe "Veriler" sayfası O2:O100 arasında .jpg uzantılı resimlerin yolu var,

Resimler; O2:O100 aralığında, C:\Documents and Settings\1Al2Ver\Belgelerim\Resimlerim\Yemekler \aşure.jpg şeklide kayıtlı

Kitap2 ile beraber resimlerin olduğu klasörüde (ymkresimler) vermekteyim,

Kitap2 isimli klasörü, bir başka bilgisayara kopyaladığımızda,

1) "Veriler" sayfasında O2:O100 aralığındaki resimlerin yolunu, kopyalanan bilgisayarın masaüstünde "YMKRESİMLER" isimli bir klasör açarak kopyalanmasını

2) Kitap2 klasörü, "Veriler" sayfasındaki O2:O100 aralığındaki yolunda, otomatik (yada veriler sayfasına koyulacak bir buton ile) yerleşmesini arzuluyorum,

Bunun için gereken kodu rica ediyorum,

Teşekkür ederim.

 

[halit3]

ekli dosyaya bakınız

 

[1Al2Ver]

ekli dosyaya bakınız

Sayın halit3 merhaba, cevap için teşekkür ederim,

Sub Makro1()
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
kopyalanacak = "C:\Documents and Settings\1Al2Ver\Belgelerim\Resimlerim\Yemekler\"
kopya_yeri = "C:\Documents and Settings\Taner Sakarya\Desktop\YMKRESİMLER"
On Error Resume Next
If Dir(kopya_yeri) = "" Then MkDir kopya_yeri
For i = 2 To WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A2:A65000")) + 2
değer = Worksheets(ActiveSheet.Name).Cells(i, 1).Value & ".jpg"
If Worksheets(ActiveSheet.Name).Cells(i, 1).Value <> "" Then
On Error Resume Next
DosyaSistemi.CopyFile kopyalanacak & değer, kopya_yeri & "\" & değer
End If
Next i
End Sub

Bu aralığı ( A2:A65000 ) O2:O100 yaparsak sorun olmaz sanırım, çünkü kopyalanmasını istediğim aralık budur,

Farklı bilgisayarlarda Taner Sakarya adı değişken olduğundan, aşağıdaki kodda Taner Sakarya yerine, kod bu yolu kendisi bulabilir mi, yani kopyalanan bilgisayarın masaüstündeki yolunu bulup yazabilir mi ?

Örneğin ; bu yol C:\Documents and Settings\........\Desktop\ YMKRESİMLER şeklinde olup ...... olan yeri kendisi bulup yazabilir mi ?

Tekrar teşekkür ederim.

 

[halit3]

a sutunundaki dosya adlarına göre kopyalıyor sen dosya adlarına O sutununa yazarsan onuda yapar
burada yanlızca O sutununa A sutunundaki gibi dosya adlarını yaz dosya yolunu yazma
aşağıdaki koduda
değer = Worksheets(ActiveSheet.Name).Cells(i, 1).Value & ".jpg"
If Worksheets(ActiveSheet.Name).Cells(i, 1).Value <> "" Then
bununla değiştir

değer = Worksheets(ActiveSheet.Name).Cells(i, 15).Value & ".jpg"
If Worksheets(ActiveSheet.Name).Cells(i, 15).Value <> "" Then

 

[1Al2Ver]

a sutunundaki dosya adlarına göre kopyalıyor sen dosya adlarına O sutununa yazarsan onuda yapar
burada yanlızca O sutununa A sutunundaki gibi dosya adlarını yaz dosya yolunu yazma
aşağıdaki koduda
değer = Worksheets(ActiveSheet.Name).Cells(i, 1).Value & ".jpg"
If Worksheets(ActiveSheet.Name).Cells(i, 1).Value <> "" Then
bununla değiştir

değer = Worksheets(ActiveSheet.Name).Cells(i, 15).Value & ".jpg"
If Worksheets(ActiveSheet.Name).Cells(i, 15).Value <> "" Then

Bir önceki kodu yanlış anlamış olabilirim, yemek isimleri A2:A100 de zaten, dosya yolu da O2:O100 arasında olacak,

Şayet bir önceki kod bu mantıkla çalışıyorsa sorun yok, yok çalışmıyor ise bu durumda da,

değer = Worksheets(ActiveSheet.Name).Cells(i, 15).Value & ".jpg"
If Worksheets(ActiveSheet.Name).Cells(i, 15).Value <> "" Then bu kodu mu kullanmalıyım ?

Şayet ; Kopyalanacak = " F:\Yemekler klasöründe ve Kitap2 olsaydı, kodun ; = " F:\ Yemekler\Kitap2.xls" mi olması gerekirdi ?

NOT ; Kodu başka bilgisayarda deneme şansım olmadı, test edemedim, bu nedenle sorularımı mazur görünüz,

Tekrar teşekkür ederim,

 

[halit3]

aslında dosyaları kapyalamaktansa klasörü kopyalamak daha mantıklı geliyor

Sub kopyala()
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
kopyalanacak = "C:\Documents and Settings\1Al2Ver\Belgelerim\Resimlerim\Yemekler"
kapya_yeri = "C:\Documents and Settings\Taner Sakarya\Desktop\YMKRESİMLER"
On Error Resume Next
DosyaSistemi.CopyFolder kopyalanacak, kapya_yeri
End Sub

 

[1Al2Ver]

aslında dosyaları kapyalamaktansa klasörü kopyalamak daha mantıklı geliyor

Sub kopyala()
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
kopyalanacak = "C:\Documents and Settings\1Al2Ver\Belgelerim\Resimlerim\Yemekler"
kapya_yeri = "C:\Documents and Settings\Taner Sakarya\Desktop\YMKRESİMLER"
On Error Resume Next
DosyaSistemi.CopyFolder kopyalanacak, kapya_yeri
End Sub

Sayın halit3 merhaba,

Haklısınız, böyle yapacağım, ama kopyalama sistemim şöyle olsun arzularım,

Bilgisayımda; "C:\Documents and Settings\1Al2Ver\Belgelerim\Resimlerim\ Yemekler" klasöründe kayıtlı "Kitap2.xls" ile "Yemekler" dosyalarını, flashdisk veya CD'de "Yemekler" klasörüne kayıt ederek, bir başka bilgisayara kopyalatmak,

Kopyalama işlemi yapıldıktan sonra, "Kitap2.xls'de Veriler" sayfası A2:A100 arasında isimleri, O2:O100 arasında da uzantısı *.jpg olan veriyi (yemekleri), klasörün kopyalandığı bilgisayarda bir buton ile yeni yoluna göre düzenlemek,

Yani bende "Kitap2.xls Veriler" sayfası O2:O100 arasında olan veriler (C:\Documents and Settings\1Al2Ver\Belgelerim\Resimlerim\Yemekler\aşure.jpg"), yeni bilgisayarda "Kitap2.xls Veriler" sayfasında O2:O100 aralığında C:\Documents and Settings\Taner Sakarya\Desktop\YMKRESİMLER\aşure.jpg şekline dönüşsün

Kopyalanacak bilgisayarın yolu çoğu zaman bilinemiyor ve veri 100 ile sınırlı kalamayabiliyor, kopyalayan kişi tek tek bu verileri kendi bilgisayarında düzelmek zorunda kalmasın, yapacağı bir küçük hata bile veri alamamasına neden oluyor,

Kısaca klasörü verdiğimiz kişi bendeki yolu, kendi bilgisayarında, O2:O100 aralığında, bir buton ile değiştirebilsin,

Tekrar teşekkür ederim,

 

[halit3]

ben tam anlıyamadım buradaki amaç klasörün içindeki dosyaların kopyalanması değilmi bunun yollarını excel sayfasına yazması önemlimi

 

[1Al2Ver]

ben tam anlıyamadım buradaki amaç klasörün içindeki dosyaların kopyalanması değilmi bunun yollarını excel sayfasına yazması önemlimi

Sayın halit3 merhaba,

Amaç sadece klasördeki dosyayı kopyalamak olsa, bilinen yöntemlerle olabilir, sonuçta klasör yada dosya flashdisk yada CD'ye kopyalanıyor,

Senaryo şu ;

-Kişi bu klasörü kendi bilgisayarında masa üstüneki adı YMKRESİMLER olan klasöre kayıt eder, ( bu klasörde .jpg uzantılı 100 adet resim ile Kitap2.xls isimli bir dosya var )

-Kitap2.xls dosyasında da "Sayfa1" ve "Veriler" sayfaları var,

-Benden aldığı bu klasörde , Kitap2.xls dosyası Veriler sayfası O2:O100 aralığında, veriler var ( bu veriler benim bilgisayarıma özgü )

-Kitap2.xls dosyası Veriler sayfası O2:O100 aralığında, bana özgü olan verileri
( ki bu bir adrestir ; C:\Documents and Settings\1Al2Ver\Belgelerim\Resimlerim \Yemekler\aşure.jpg gibi ) kendi bilgisayarındaki yol (C:\Documents and Settings\Taner Sakarya\Desktop\YMKRESİMLER") ile değiştirmesi gerekiyor,

-Bu işlemin bir buton ile yapılması gerekiyor,

Sebep ; Sayfa1'deki B2 hücresinde yemek adı seçildiğinde, Veriler sayfasında O2:O100 aralığında yolu verilen yemeğin resmi A1'e gelmektedir,

Dolayısıyla bu yol'un kopyalanan bilgisayardaki yol olması gerekmektedir,

Tekrar teşekkür ederim.

 

[halit3]

ekli dosyaya bakarmısınız

komut düğmesini tıklayın ve resimlerin bulunduğu klasörü seçin tamamı tıklayın

 

[1Al2Ver]

ekli dosyaya bakarmısınız

komut düğmesini tıklayın ve resimlerin bulunduğu klasörü seçin tamamı tıklayın

Sayın halit3 merhaba,

Zahmetleriniz için teşekkür ederim, küçük bir sorum olacak,

Aktarmanın O2:O100 olması için aşağıdaki kodda, kırmızı renkli aralığın ;

Columns("A:B,O2:O100").ClearContents
On Error Resume Next

şekline olması çözüm olur mu ?

Şayet olamıyor ise ben orj.dosyadaki O2:O100'ü C2:C100 yapacağım,

Tekrar teşekkür ederim.

Private Sub CommandButton1_Click()
Columns("A:C").ClearContents
On Error Resume Next
Dim Baslik As String
Baslik = "Kaynak Dosyaları İçeren Klasörü Seçin"
Set Obj = CreateObject("shell.application")
Set Klasor = Obj.browseforfolder(0, Baslik, 50, &H0)
Kaynak = Klasor.Items.Item.Path

 

[halit3]

bu kodu denermisin


Dim Klasor As Object
Dim Obj As Object
Dim Kaynak As String
Private Sub Listele(Klasor As String, Uzanti As String)
Dim Dosya As String
Dim Say As Integer
'Dosya = Dir(Klasor & "\*.**" & Uzanti)
Dosya = Dir(Klasor & "\*." & "jpg")
'Dosyalar = Dir(sklasor & "\*." & ComboBox2)
Do While Dosya <> ""
Worksheets(ActiveSheet.Name).Cells(Say + 1, 1).Value = Mid(Dosya, 1, Len(Dosya) - 4)
'Worksheets(ActiveSheet.Name).Cells(Say + 1, 2).Value = Dosya
Worksheets(ActiveSheet.Name).Cells(Say + 1, 15).Value = Kaynak & "\" & Dosya
Say = Say + 1
Dosya = Dir
Loop
End Sub
Private Sub CommandButton1_Click()

Range("A:A,O:O").ClearContents
On Error Resume Next
Dim Baslik As String
Baslik = "Kaynak Dosyaları İçeren Klasörü Seçin"
Set Obj = CreateObject("shell.application")
Set Klasor = Obj.browseforfolder(0, Baslik, 50, &H0)
Kaynak = Klasor.Items.Item.Path
If Not Klasor Is Nothing Then
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
On Error Resume Next
Call Listele(Kaynak, "")
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

Set Obj = Nothing
Set Klasor = Nothing
Exit Sub
hata: MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
End Sub

 

[omerceri]

Kodlar aşağıda
1- Dosyanızı yedekleyin.
2- Bu makronun bulunduğu Excel dosyasını masa üstüne yapıştırın
3- Yeni Dosya yolunu P sütununa yazıyor denedikten sonra Kodlardaki P'yi O olarak değiştirin.
Sub a()
Set fs = CreateObject("Scripting.FileSystemObject")
yol = ThisWorkbook.Path
If fs.FolderExists(yol & "/YMKRESİMLER") = True Then
MsgBox "Masa Üstünde Bu Klasör Var"
Exit Sub
End If
fs.CreateFolder (yol & "/YMKRESİMLER")
say = Range("o1").CurrentRegion.Rows.Count
For i = 2 To say
Kes = Split(Range("O" & i), "/")
Son = UBound(Kes)
Range("P" & i).Value = yol & "/YMKRESİMLER" & "/" & Kes(Son)
Range("P" & i).ClearFormats
Next

End Sub

 

[1Al2Ver]

bu kodu denermisin


Dim Klasor As Object
Dim Obj As Object
Dim Kaynak As String
Private Sub Listele(Klasor As String, Uzanti As String)
Dim Dosya As String
Dim Say As Integer
'Dosya = Dir(Klasor & "\*.**" & Uzanti)
Dosya = Dir(Klasor & "\*." & "jpg")
'Dosyalar = Dir(sklasor & "\*." & ComboBox2)
Do While Dosya <> ""
Worksheets(ActiveSheet.Name).Cells(Say + 1, 1).Value = Mid(Dosya, 1, Len(Dosya) - 4)
'Worksheets(ActiveSheet.Name).Cells(Say + 1, 2).Value = Dosya
Worksheets(ActiveSheet.Name).Cells(Say + 1, 15).Value = Kaynak & "\" & Dosya
Say = Say + 1
Dosya = Dir
Loop
End Sub
Private Sub CommandButton1_Click()

Range("A:A,O:O").ClearContents
On Error Resume Next
Dim Baslik As String
Baslik = "Kaynak Dosyaları İçeren Klasörü Seçin"
Set Obj = CreateObject("shell.application")
Set Klasor = Obj.browseforfolder(0, Baslik, 50, &H0)
Kaynak = Klasor.Items.Item.Path
If Not Klasor Is Nothing Then
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
On Error Resume Next
Call Listele(Kaynak, "")
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

Set Obj = Nothing
Set Klasor = Nothing
Exit Sub
hata: MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
End Sub

Sayın halit3 merhaba,

Kodu deneyip sonucu bildireceğim, zahmetleriniz için çok çok teşekkür ederim,

Saygılarımla.

 

[1Al2Ver]

Kodlar aşağıda
1- Dosyanızı yedekleyin.
2- Bu makronun bulunduğu Excel dosyasını masa üstüne yapıştırın
3- Yeni Dosya yolunu P sütununa yazıyor denedikten sonra Kodlardaki P'yi O olarak değiştirin.
Sub a()
Set fs = CreateObject("Scripting.FileSystemObject")
yol = ThisWorkbook.Path
If fs.FolderExists(yol & "/YMKRESİMLER") = True Then
MsgBox "Masa Üstünde Bu Klasör Var"
Exit Sub
End If
fs.CreateFolder (yol & "/YMKRESİMLER")
say = Range("o1").CurrentRegion.Rows.Count
For i = 2 To say
Kes = Split(Range("O" & i), "/")
Son = UBound(Kes)
Range("P" & i).Value = yol & "/YMKRESİMLER" & "/" & Kes(Son)
Range("P" & i).ClearFormats
Next

End Sub

Sayın omerceri merhaba,

İlginiz ve kod için teşekkür ederim,

Başka bir bilgisayarda deneyince sonuçları hakkında size bilgi sunacağım,

Saygılarımla.

 

[omerceri]

Kusura Bakmayın İşaret yanlış olmuş
Kes = Split(Range("O" & i), "/") yerine
aşağıdaki gibi değiştirin
Kes = Split(Range("O" & i), "\")

 

[1Al2Ver]

Kusura Bakmayın İşaret yanlış olmuş
Kes = Split(Range("O" & i), "/") yerine
aşağıdaki gibi değiştirin
Kes = Split(Range("O" & i), "\")

Sayın omerceri, tekrar merhaba,

İlginiz için çok teşekkür ederim, gözümden kaçabilirdi, ikaz etmeniz iyi oldu ayrıca son derecede memnun oldum,

Saygılarımla.