08.03.2018, 07:35
Hallo VBA-Freunde,
ich habe eine Foto-Doku erstellt und möchte gern die Bilder mit dem Bildnamen (z.B. IMG_0006, IMG_0007 usw.) mittels VBA-Lösung unter die Fotos betiteln.
Eine Möglichkeit funktioniert schon:
Jedoch möchte ich nicht den ganzen Pfad als Bildtitel haben (aber erstmal besser als gar nichts)
Wäre es möglich, den Code zu modifizieren oder hat jemand noch eine Idee?
Eine zweite Möglichkeit wäre (gefunden J):
Jedoch werden dort Laufzeichenfehler angezeigt!
Würde mich über eine Anmerkung und vllt einschneidenden Tipp freuen.
Gruß,
Philipp
ich habe eine Foto-Doku erstellt und möchte gern die Bilder mit dem Bildnamen (z.B. IMG_0006, IMG_0007 usw.) mittels VBA-Lösung unter die Fotos betiteln.
Eine Möglichkeit funktioniert schon:
Code:
Sub PfadDateiNamenEinfügen()
Dim fso, d1, file, fileName
Set fso = CreateObject("Scripting.FileSystemObject")
fileName = "-------"
' Pfad anpassen
Set d1 = fso.GetFolder(fileName)
For Each file In d1.Files
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.TypeParagraph
Selection.InlineShapes.AddPicture fileName:= _
file, LinkToFile:=True, SaveWithDocument:=False
Selection.TypeParagraph
Selection.InsertCaption Label:="Abbildung", TitleAutoText:="", Title:=" - " + file, _
Position:=wdCaptionPositionBelow, ExcludeLabel:=0
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.TypeParagraph
Next
End SubJedoch möchte ich nicht den ganzen Pfad als Bildtitel haben (aber erstmal besser als gar nichts)
Wäre es möglich, den Code zu modifizieren oder hat jemand noch eine Idee?
Eine zweite Möglichkeit wäre (gefunden J):
Code:
Sub Bildüberschrift()
'strPfad = UF03_BilderDiagramme.TextBox03_PfadBilder.Value + "\"
CaptionLabels.Add Name:=Bildueberschrift
Endung = "jpg"
sBilddateiname = Dir(strPfad & "*." & Endung)
Set Position = ActiveDocument.Sections(9).Range.Characters(10)
Do While sBilddateiname <> ""
Bildname = Left$(sBilddateiname, Len(sBilddateiname) - 4)
Set Bild = ActiveDocument.InlineShapes.AddPicture(fileName:= _
strPfad & sBilddateiname, LinkToFile:=False, SaveWithDocument:=True, Range:=Position)
Bild.Select
Bild.LockAspectRatio = msoTrue
Bild.Width = CentimetersToPoints(12)
Selection.InsertCaption Label:=Bildueberschrift, _
Title:=": " + Bildname, Position:=wdCaptionPositionAbove
Selection.TypeText Chr$(13)
Selection.TypeText Chr$(13)
sBilddateiname = Dir()
Loop
End SubJedoch werden dort Laufzeichenfehler angezeigt!
Würde mich über eine Anmerkung und vllt einschneidenden Tipp freuen.
Gruß,
Philipp