toplu resim ekleme (var olan kodu güncelleme)

[deon4812]

merhaba kolay gelsin. elimde bir adet vba kodu var. ben bu kodla world toplu halde resim yüklüyorum. kodun normal yükelemeden farklı resimler yüklenirken adlarla beraber geliyor. fakat adlar gelirken hem uzantı hemde dosya yoluyla bereber geliyor.

var olan:
E:\dsdsdsdsdsdd\sdsdsdsdds\ddsdsdssdds\abc.jpg

istenilen:
abc

ctrl+h basarak karakterileri değiştirebiliyorum fakat bu işlemi çok fazla tekrar ediyorum. kodu düzenleyi direk adıyla beraber gelmesini sağlaya bilirmiyiz.
-----------------------------------------------------------------------------------------------------
Sub PicWithCaption()
Dim xFileDialog As FileDialog
Dim xPath, xFile As Variant
On Error Resume Next
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDialog.Show = -1 Then
xPath = xFileDialog.SelectedItems.Item(1)
If xPath <> "" Then
xFile = Dir(xPath & "\.")
Do While xFile <> ""
If UCase(Right(xFile, 3)) = "PNG" Or _
UCase(Right(xFile, 3)) = "TIF" Or _
UCase(Right(xFile, 3)) = "JPG" Or _
UCase(Right(xFile, 3)) = "GIF" Or _
UCase(Right(xFile, 3)) = "BMP" Then
With Selection
.InlineShapes.AddPicture xPath & "\" & xFile, False, True
.InsertAfter vbCrLf
.MoveDown wdLine
.Text = xPath & "\" & xFile & Chr(10)
.MoveDown wdLine
End With
End If
xFile = Dir()
Loop
End If
End If
End Sub

 

[ÖmerBey]

Merhaba,
Aşağıdaki satırı daha aşağıdaki şekilde değiştirip deneyiniz.

.Text = xPath & "\" & xFile & Chr(10)

.Text = Left(xFile, InStrRev(xFile, ".") - 1) & Chr(10)

 

[deon4812]

çok teşekkür ederim. çok güzel çalışıyor elinize sağlık. sizden bir ricada daha buluna bilir miyim.

 

[deon4812]

var olan kodu ihtiyaca göre düzenleme

Merhaba rica etsem aşağıdaki sorunumu çözer misiniz? Şimdiden çok teşekkür ederin. Açıklama: Kod1 resimleri toplu olarak adlarıyla beraber ekleme işlmemi yapıyor Kod2 resimlerin genişliklerini ayarlıyor (referans olarak kullanıla bilir) İstenilen: tek kod ile resimler eklensin (kod 1...

www.excel.web.tr

 

[ÖmerBey]

Tekrar merhaba,
Word makro kodlarına çok hakim değilim.
Umarım işinize yarar, aşağıdaki şekilde dener misiniz?

Sub PicWithCaption()
Dim xFileDialog As FileDialog
Dim xPath, xFile As Variant
Dim rsm As Object
Dim gen As Double: gen = CentimetersToPoints(10)

On Error Resume Next
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDialog.Show = -1 Then
    xPath = xFileDialog.SelectedItems.Item(1)
    If xPath <> "" Then
        xFile = Dir(xPath & "\.")
        Do While xFile <> ""
            If UCase(Right(xFile, 3)) = "PNG" Or _
                UCase(Right(xFile, 3)) = "TIF" Or _
                UCase(Right(xFile, 3)) = "JPG" Or _
                UCase(Right(xFile, 3)) = "GIF" Or _
                UCase(Right(xFile, 3)) = "BMP" Then

                With Selection
                    Set rsm = .InlineShapes.AddPicture(xPath & "\" & xFile, False, True)
                    rsm.LockAspectRatio = msoTrue
                    rsm.Width = gen
                    .InsertAfter vbCrLf
                    .MoveDown wdLine
                    .Text = Left(xFile, InStrRev(xFile, ".") - 1) & Chr(10)
                    .MoveDown wdLine
                    .InsertNewPage
                End With
            End If
            xFile = Dir()
        Loop
    End If
End If
End Sub

 

[deon4812]

güzel olmuş resimlerin boyutları değişmiş, elinize sağlık. Resimlerin sırası değişmiş ve tek sayfada 2 resim eklenmiş.

 

[deon4812]

tek sayfada 1 adet resim "sayfadan taşmayacak şekilde" ve resimlerin sırası değişmeyecek

 

[ÖmerBey]

Yukarıdaki kodu her resim yeni sayfaya gelecek şekilde güncelledim, deneyiniz. Ancak resimlerin sırasının değişmesini anlamadım, kodunuzda bunla ilgili bir değişiklik yapmamıştım. Resimlerin genişliği ile ilgili de gen = CentimetersToPoints(10) ifadesindeki 10 sayısını isteğinize göre değiştirebilirsiniz.

 

[deon4812]

şuan çok güzel oldu resim sonra 1 boşluk resim adı gelecek şekilde yapabilir miyiz? şuan adı kısa olursa ikisi aynı satırda yer alıyor

 

[ÖmerBey]

Bu haliyle yukarıdaki kodu kendi bilgisayarımda uyguladığımda isim ne kadar kısa olursa olsun resmin altında konumlanıyor. Araya satır ekleyince daha aşağı kayıyor. Belki bilgisayardan kaynaklı bir fark olabilir. Bu yüzden kodunuzda değişiklik yaptığım bölüme açıklamalar ekledim. İhtiyacınız olan değişikliği açıklamalara göre siz yaparsınız.

                With Selection
                    Set rsm = .InlineShapes.AddPicture(XPath & "\" & xFile, False, True) 'Resim ekleme
                    rsm.LockAspectRatio = msoTrue 'Resmin En-boy oranını sabitleme
                    rsm.Width = gen 'resmin genişliğini değiştir
                    .InsertAfter vbCrLf 'Satır ekle
                    .MoveDown wdLine 'alt satıra geç
                    .Text = Left(xFile, InStrRev(xFile, ".") - 1) & Chr(10) 'Metin ekle
                    .MoveDown wdLine 'alt satıra geç
                    .InsertNewPage 'Yeni sayfa ekle
                End With

 

[deon4812]

tamam teşekkür ederim

 

[ÖmerBey]

Rica ederim,
İyi çalışmalar diliyorum...