Wie kann man per Macro vba Code ein Foto in Word automatisch auf die Größe 100% zurücksetzen.
Problem:
Es kann sein, dass Fotos beim Einfügen automatisch scheinbar verkleinert werden.
Dabei ist in wirklichkeit nur die Size-Größe auf 30% eingestellt. Die Ursache für die Vordefinition weiß ich noch nicht.
Jedenfalls kann man mit vba-Word Makro Code alle Fotos wieder auf die dargestellte 100% anpassen.
Hierzu setzt man einfach die ScaleWidth auf 100
objInlineShape.ScaleWidth = 100 |
Problem: beim Einfügen wird das Foto automatisch verkleinert.
'--< replace as Thumb.jpg >-- '*pasteBitmap is much smaller cell_Range.PasteSpecial DataType:=wdPasteBitmap, Placement:=wdInLine Set objInlineShape = cell_Range.Cells(1).Range.InlineShapes(1) objInlineShape.ScaleWidth = 100 '--</ replace as Thumb.jpg >--
|
Kompletter Word Code
Option Explicit On
'----< Setup Parameters >---- Const const_Path_Photos_Default As String = "B:\2017" Const const_int_maxLength_Photos As String = 6 Const Show_Filenames As Boolean = False Const Show_ImageNr As Boolean = False Const Add_Empty_Textline As Boolean = False
Private Nr_Table_with_Fotos As Integer Private intRow_Match As Integer Private intColumn_Match As Integer
Sub Insert_Photos() '-----------------< Fotos_einfuegen() >----------------- '*Description: '*This macro inserts photos in a table at column 3 and creates for each picture one row '*The selection is by a folder dialog and imports the entire folder '*Table: it searchs for the first table, which has the text: "foto" in the table-header
'*Reference Microsoft Scripting Runtime http://www.codedocu.de/Details?d=1076
'------< Insert Pictures From Folder >------ '--< Import-Dialog >-- Dim objFiledialog As FileDialog Set objFiledialog = Application.FileDialog(msoFileDialogFilePicker) objFiledialog.AllowMultiSelect = True objFiledialog.ButtonName = "Import Images" objFiledialog.Filters.Add "Images Photos", "*.jpg;*.png;*.tiff;*.gif" objFiledialog.Title = "Fotos auswählen.." objFiledialog.InitialView = msoFileDialogViewTiles objFiledialog.InitialFileName = const_Path_Photos_Default objFiledialog.AllowMultiSelect = True If Not objFiledialog.Show() = True Then Exit Sub End If '--< Import-Dialog >--
'-< check >- '</ Ordner ist leer > If objFiledialog.SelectedItems().Count = 0 Then Exit Sub End If '</ Ordner ist leer > '-</ check >-
'--< Init Document >-- '< get Document > Dim doc As Document Set doc = Application.ActiveDocument '</ get Document >
'< find Table > '* Bild in Header Nr_Table_with_Fotos = fx_find_Table() '</ find Table >
Dim tblPictures As Table Set tblPictures = doc.Tables(Nr_Table_with_Fotos) '--</ Init Document >--
'On Error Resume Next
'-------< @Loop: Insert all Images >-------- Dim objInlineShape As InlineShape Dim sFilename As String Dim iPicture As Integer iPicture = 0 Dim iCol As Integer iCol = 0 Dim iFile As Integer For iFile = 1 To objFiledialog.SelectedItems.Count '------< Loop.Item >------ DoEvents
'< get selection > sFilename = objFiledialog.SelectedItems(iFile) '</ get selection >
'< get Extension > Dim sExtension As String Dim intLen_Extension As Integer intLen_Extension = InStrRev(sFilename, ".", -1, vbBinaryCompare) sExtension = Mid(LCase(sFilename), intLen_Extension) '</ get Extension >
If InStr(1, "*.jpg;*.png;*.tiff;*.gif", sExtension) > 0 Then 'JPG-Datei '----< IsPhoto >---- iPicture = iPicture + 1 Dim iRow As Integer iRow = tblPictures.Rows.Count iCol = intColumn_Match
'-< new Row >- If iPicture > 1 Then Dim new_Row As Row Set new_Row = tblPictures.Rows.Add() End If '-</ new Row >-
'< set Cell > Dim cell_Range As Range Set cell_Range = tblPictures.Cell(iRow + 1, iCol).Range cell_Range.Select Selection.EndKey '</ set Cell >
'< Title Row > 'Selection.TypeText Text:=Chr(11) '</ Title Row >
DoEvents
'refresh Style 'tblPictures.Style = tblPictures.Style
'< insert Photo after Bookmark > '*SaveWithDocument:= True to save the linked picture with the document. The default value is False. '*LinkToFile: True to link the picture to the file from which it was created. False to make the picture an independent copy of the file. The default value is False. Set objInlineShape = doc.InlineShapes.AddPicture(FileName:=sFilename, LinkToFile:=False, SaveWithDocument:=True, Range:=cell_Range) '</ insert Photo after Bookmark >
'< scale > objInlineShape.LockAspectRatio = msoTrue If objInlineShape.Width > objInlineShape.Height Then objInlineShape.Width = CentimetersToPoints(const_int_maxLength_Photos) 'in Centimeters Else objInlineShape.Height = CentimetersToPoints(const_int_maxLength_Photos) 'in Centimeters End If '</ scale >
'--< replace as png >-- '*reduce memory 1 MB to 1kb '< cut > objInlineShape.Select Selection.Cut DoEvents '</ cut >
'--< replace as Thumb.jpg >-- '*pasteBitmap is much smaller cell_Range.PasteSpecial DataType:=wdPasteBitmap, Placement:=wdInLine Set objInlineShape = cell_Range.Cells(1).Range.InlineShapes(1) objInlineShape.ScaleWidth = 100 '--</ replace as Thumb.jpg >--
'--< Filename >-- If Show_Filenames = True Or Show_ImageNr = True Then Dim sLabel As String sLabel = ""
If Show_Filenames Then Dim pos As Integer pos = InStrRev(sFilename, "\") If pos < 0 Then pos = InStrRev(sFilename, "/") End If
sLabel = Mid(sFilename, pos + 1) sLabel = Replace(sLabel, ".jpg", "", , , vbTextCompare) End If
If Show_ImageNr Then sLabel = iPicture & ": " & sLabel End If
'cell_Range.Select Selection.EndKey Selection.InsertBreak wdLineBreak Selection.TypeText Text:=sLabel DoEvents End If '--< Filename >--
'< Empty TextLine > If Add_Empty_Textline = True Then Selection.TypeText Text:=Chr(11) DoEvents End If '</ Empty TextLine >
If Err.Number <> 0 Then MsgBox Err.Description Err.Clear End If '----</ Insert Image >----
'----</ IsPhoto >---- End If Next '----</ @Loop: all Files >---- '------</ Insert Pictures From Folder >------
'-----------------< Fotos_einfuegen() >----------------- End Sub
Private Function fx_find_Table() As Integer '--------< fx_find_Table() >-------- '< init > Dim iTable As Integer '</ init >
'----< @Loop: Tables >---- For iTable = 1 To Tables.Count
Dim tbl As Table Set tbl = Tables(iTable)
'--< @Loop: Rows >-- Dim iRow As Integer For iRow = 0 To tbl.Rows.Count - 1 '--< @Loop: Columns >-- Dim iColumn As Integer For iColumn = 0 To tbl.Columns.Count - 1 '< Cell > Dim varCell As Variant Set varCell = tbl.Cell(iRow, iColumn) If varCell.Range.Text Like "Bild*" Then '< match > intRow_Match = iRow intColumn_Match = iColumn
'< out > fx_find_Table = iTable Exit For '</ out >
'</ match > End If '</ Cell > Next '--</ @Loop: Columns >-- Next '--</ @Loop: Rows >-- Next '----</ @Loop: Tables >----
'< out > 'fx_get_Table = '</ out > '--------</ fx_find_Table() >-------- End Function
|