#

Download:

Datei 1: word_Fotos_Importieren_03.doc

In Word Bilder skaliert verkleinern


In dem folgenden script werden Bilder aus einem Verzeichnis eingefügt und diese sollen dann auch gleich verkleinert werden.
Wenn Bilder eingefügt werden über vba mit .addPicture, dann sind die Bilder zunächst so Breit wie die gesamte Document Breite.
Deshalb kann man am einfachsten die Größenanpassung in Höhe zu Weite verriegeln
Und anschliessen die Weite halbieren.

Der folgende Code macht das..

'----< File als Bitmap einfuegen >----

Set objInlineShape = newDoc.InlineShapes.AddPicture(FileName:=sDateiname, LinkToFile:=False, SaveWithDocument:=True, Range:=Selection.Range)

'< groeße anpassen >

objInlineShape.LockAspectRatio = msoTrue

objInlineShape.Width = objInlineShape.Width * varScale

'</ groeße anpassen >



Hier das beigefügte Word dokument mit einem Button und einer Scalierungseingabe (eine Combobox, die beim Öffnen von 10 bis 100 geladen wird)


Zunächts werden die Bilder an der untersten Position eingefügt
Und dann im schritt 2 verkleinert

Wie man sieht werden dann alle Bilder verkleinert untereinander eingefügt




Hier der gesamte Beispiel code

Private Sub btnFotos_importiern_Click()

'--------------------< btnFotos_importiern_Click() >--------------------

' makro_Bilder_einfuegen Makro

' füge 6 Bilder in das Word-Dokument ein

'--< Dateidialog >--

Dim objFiledialog As FileDialog

objFiledialog = Application.FileDialog(msoFileDialogFilePicker)

objFiledialog.AllowMultiSelect = True

objFiledialog.ButtonName = "Importieren"

objFiledialog.Filters.Add("Bilder", "*.jpg")

objFiledialog.Title = "doppelklicken Sie auf ein Foto"

'objFiledialog.InitialFileName = "C:\Users\Besitzer\Desktop"

Dim sFilename As String

If objFiledialog.Show() = True Then

sFilename = objFiledialog.SelectedItems(1)

End If

'--< Dateidialog >--

'< Ordner bestimmen >

Dim sFolder As String

sFolder = Left(sFilename, InStrRev(sFilename, "\", , vbTextCompare))

'</ Ordner bestimmen >

'--< Kontrolle >--

'< Ordner ist leer >

If sFolder Like "" Then

Exit Sub

End If

'</ Ordner ist leer >

'< Kontrolle: ist Ordner >

Dim objFilesystem As New FileSystemObject

If Not objFilesystem.FolderExists(sFolder) = True Then

MsgBox("Der eingegebene Pfad ist kein Ordner", vbOKOnly, "Ordner prüfen")

Exit Sub

End If

'</ Kontrolle: ist Ordner >

'--</ Kontrolle >--

'< Ordner laden >

Dim objFolder As Folder

objFolder = objFilesystem.GetFolder(sFolder)

'</ Ordner laden >

'----< sortierbare Tabelle erstellen >----

Dim recOrder As New ADODB.Recordset

recOrder.Fields.Append("FileName", adVarChar, 255, adFldIsNullable)

recOrder.Open()

'----</ sortierbare Tabelle erstellen >----

'-------< @Loop: Eingabe-Files >--------

Dim objFile As File

For Each objFile In objFolder.Files

'----< File >----

If objFile.Type Like "JP*G*" Then

'----< File ist Foto >----

'< Datei eintragen >

recOrder.AddNew()

sFilename = objFile.Path

recOrder("FileName") = sFilename

recOrder.Update()

'</ Datei eintragen >

'----</ File ist Foto >----

End If

'----</ File >----

Next

'-------</ @Loop: Eingabe-Files >--------

'< Tabelle sortieren >

'*nach Dateinamen

recOrder.Sort = "FileName"

'</ Tabelle sortieren >

'< neues Dokument ersetellen >

Dim newDoc As Document

newDoc = Application.Documents.Add

'</ neues Dokument ersetellen >

'< Scalierung anpassen >

Dim varScale As Double

varScale = ctlScalePercent / 100

'</ Scalierung anpassen >

'-------< @Loop: Sortierte Ausgabe-Files einfuegen >--------

Dim objInlineShape As InlineShape

recOrder.MoveFirst()

Do Until recOrder.EOF

Dim sDateiname As String

sDateiname = recOrder("FileName")

On Error Resume Next

Selection.MoveEnd()

'----< File als Bitmap einfuegen >----

objInlineShape = newDoc.InlineShapes.AddPicture(FileName:=sDateiname, LinkToFile:=False, SaveWithDocument:=True, Range:=Selection.Range)

'< groeße anpassen >

objInlineShape.LockAspectRatio = msoTrue

objInlineShape.Width = objInlineShape.Width * varScale

'</ groeße anpassen >

objInlineShape.Select()

Selection.Cut()

'< als png einfuegen >

'*ist dann schon kleiner auch fuer den Speicher

Selection.PasteSpecial(Link:=False, DataType:=wdPasteBitmap, Placement:=wdInLine, DisplayAsIcon:=False)

'</ als png einfuegen >

'----</ File als Bitmap einfuegen >----

'< Filename schreiben >

sFilename = Mid(sDateiname, InStrRev(sDateiname, "\", , vbTextCompare) + 1)

Selection.InsertParagraph()

Selection.TypeText(sFilename)

Selection.InsertParagraph()

Selection.TypeParagraph()

'</ Filename schreiben >

'< next >

recOrder.MoveNext()

'</ next >

Loop

'-------</ @Loop: Sortierte Ausgabe-Files einfuegen >--------

On Error Resume Next

newDoc.Save()

'--------------------</ btnFotos_importiern_Click() >--------------------

End Sub

Private Sub Document_Open()

Dim intPercent As Integer

For intPercent = 10 To 100 Step 10

ctlScalePercent.AddItem(intPercent)

Next

ctlScalePercent = 100

End Sub


Mobile

.

0123movie.net