#

Ein paar sinnvolle Makros für Word
die ich täglich benutze




Den folgenden Code einfach in die vba Seite von Word legen.
Alt-F11 oder über Makros->bearbeiten..



Sub Convert_Fotos_von_FotoGallery()
'-----------------< Convert_Fotos_von_FotoGallery() >-----------------
Dim objImageShape As InlineShape
Dim iShape As Integer
For iShape = ActiveDocument.InlineShapes.Count To 1 Step -1
objImageShape = ActiveDocument.InlineShapes(iShape)
objImageShape.Select()
Selection.Cut()
Selection.PasteSpecial(Link:=False, DataType:=wdPasteBitmap, Placement:=wdInLine, DisplayAsIcon:=False)
'Datatype:=15,wdPasteShape,wdPasteBitmap,wdPasteDeviceIndependentBitmap
Next
'-----------------</ Convert_Fotos_von_FotoGallery() >-----------------
End Sub


Public Sub a0_Fotos_aus_Ordner_einfuegen()
'-----------------< Fotos_aus_Ordner_einfuegen() >-----------------
'< Ordner bestimmen >
Dim sFolder As String
sFolder = InputBox("Bitte Ordner eingeben, aus dem die Fotos geholt werden sollen:", "Alle Fotos aus Ordner in Word einfügen")
'</ 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()
recOrder("FileName") = objFile.Path
recOrder.Update()
'</ Datei eintragen >
'----</ File ist Foto >----
End If
'----</ File >----
Next
'-------</ @Loop: Eingabe-Files >--------


'< Tabelle sortieren >
'*nach Dateinamen
recOrder.Sort = "FileName"
'</ Tabelle sortieren >


'-------< @Loop: Sortierte Ausgabe-Files einfuegen >--------
Dim objInlineShape As InlineShape
recOrder.MoveFirst()
Do Until recOrder.EOF
Dim sDateiname As String
sDateiname = recOrder("FileName")
DoEvents()

'----< File als Bitmap einfuegen >----
objInlineShape = ActiveDocument.InlineShapes.AddPicture(FileName:=sDateiname, LinkToFile:=False, SaveWithDocument:=True)
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 >

'Selection.Text = " "
'----</ File als Bitmap einfuegen >----

'< next >
recOrder.MoveNext()
'</ next >
Loop
'-------</ @Loop: Sortierte Ausgabe-Files einfuegen >--------

'-------< @Loop: JPG Thumbnails bilden >--------
For Each objInlineShape In ActiveDocument.InlineShapes
objInlineShape.Line.Style = msoLineSingle
objInlineShape.Line.Weight = 1
Next
'-------</ @Loop: JPG Thumbnails bilden >--------
'-----------------</ Fotos_aus_Ordner_einfuegen() >-----------------
End Sub


Sub Bilder_vergroessern()
'
' Bilder_vergroessern Makro
'
Dim objImageShape As InlineShape
For Each objImageShape In ActiveDocument.InlineShapes
Dim s
objImageShape.ScaleWidth = objImageShape.ScaleWidth * 2
objImageShape.ScaleHeight = objImageShape.ScaleHeight * 2
Next
End Sub

Sub Bilder_anpassen_gross()
'-----------------< Bilder_anpassen_gross() >-----------------
Dim objImageShape As InlineShape
For Each objImageShape In ActiveDocument.InlineShapes
objImageShape.ScaleWidth = 100
objImageShape.ScaleHeight = 100
Next
'-----------------</ Bilder_anpassen_gross() >-----------------
End Sub

Sub Bilder_anpassen_50_prozent()
'-----------------< Bilder_anpassen_gross() >-----------------
Dim objImageShape As InlineShape
For Each objImageShape In ActiveDocument.InlineShapes
objImageShape.ScaleWidth = 50
objImageShape.ScaleHeight = 50
Next
'-----------------</ Bilder_anpassen_gross() >-----------------
End Sub

Sub Bilder_vergroessern_20_Prozent()
'-----------------< Bilder_vergroessern_20_Prozent() >-----------------
Dim objImageShape As InlineShape
For Each objImageShape In ActiveDocument.InlineShapes
objImageShape.ScaleWidth = objImageShape.ScaleWidth * 1.2
objImageShape.ScaleHeight = objImageShape.ScaleHeight * 1.2
Next
'-----------------</ Bilder_vergroessern_20_Prozent() >-----------------
End Sub

Sub Bilder_vergroessern_30_Prozent()
'-----------------< Bilder_vergroessern_20_Prozent() >-----------------
Dim objImageShape As InlineShape
For Each objImageShape In ActiveDocument.InlineShapes
objImageShape.ScaleWidth = objImageShape.ScaleWidth * 1.3
objImageShape.ScaleHeight = objImageShape.ScaleHeight * 1.3
Next
'-----------------</ Bilder_vergroessern_20_Prozent() >-----------------
End Sub

Sub Bilder_verkleinern()
'-----------------< Bilder_verkleinern() >-----------------
Dim objImageShape As InlineShape
For Each objImageShape In ActiveDocument.InlineShapes
objImageShape.ScaleWidth = objImageShape.ScaleWidth / 2
objImageShape.ScaleHeight = objImageShape.ScaleHeight / 2
Next
'-----------------</ Bilder_verkleinern() >-----------------
End Sub

Sub Zuschnitt_Fotogallerie_Breit()
'-----------------< makro_Bild_zuschneiden() >-----------------
Dim objImageShape As InlineShape
For Each objImageShape In ActiveDocument.InlineShapes
'oberen Rand setzen
objImageShape.PictureFormat.CropTop = objImageShape.ScaleHeight * 4.2

'linken Rand setzen
objImageShape.PictureFormat.CropLeft = objImageShape.ScaleWidth * 6

'untern Rand setzen
objImageShape.PictureFormat.CropBottom = objImageShape.ScaleHeight * 2

'rechten Rand setzen
objImageShape.PictureFormat.CropRight = objImageShape.ScaleWidth * 12
Next
'-----------------</ makro_Bild_zuschneiden() >-----------------
End Sub


Sub Zuschnitt_Moviemaker_Breit_links()
'-----------------< makro_Bild_zuschneiden() >-----------------
Dim objImageShape As InlineShape
For Each objImageShape In ActiveDocument.InlineShapes
'oberen Rand setzen
objImageShape.PictureFormat.CropTop = objImageShape.ScaleHeight * 3.5

'linken Rand setzen
objImageShape.PictureFormat.CropLeft = objImageShape.ScaleWidth * 10

'untern Rand setzen
objImageShape.PictureFormat.CropBottom = objImageShape.ScaleHeight * 12

'rechten Rand setzen
objImageShape.PictureFormat.CropRight = objImageShape.ScaleWidth * 20
Next
'-----------------</ makro_Bild_zuschneiden() >-----------------
End Sub


Sub Zuschnitt_Video_Mitte()
'-----------------< Zuschnitt_Video_Mitte() >-----------------
Dim objImageShape As InlineShape
For Each objImageShape In ActiveDocument.InlineShapes
'oberen Rand setzen
objImageShape.PictureFormat.CropTop = objImageShape.ScaleHeight * 4.2

'linken Rand setzen
objImageShape.PictureFormat.CropLeft = objImageShape.ScaleWidth * 6

'untern Rand setzen
objImageShape.PictureFormat.CropBottom = objImageShape.ScaleHeight * 2

'rechten Rand setzen
objImageShape.PictureFormat.CropRight = objImageShape.ScaleWidth * 12
Next
'-----------------</ Zuschnitt_Video_Mitte() >-----------------
End Sub

Sub Zuschnitt_Video_Mitte_Schmal()
'-----------------< Zuschnitt_Video_Mitte_Schmal() >-----------------
Dim objImageShape As InlineShape
For Each objImageShape In ActiveDocument.InlineShapes
'oberen Rand setzen
objImageShape.PictureFormat.CropTop = objImageShape.ScaleHeight * 3.5

'linken Rand setzen
objImageShape.PictureFormat.CropLeft = objImageShape.ScaleWidth * 10

'untern Rand setzen
objImageShape.PictureFormat.CropBottom = objImageShape.ScaleHeight * 12

'rechten Rand setzen
objImageShape.PictureFormat.CropRight = objImageShape.ScaleWidth * 20
Next
'-----------------</ Zuschnitt_Video_Mitte_Schmal() >-----------------
End Sub


Sub Zuschnitt_Youtube()
'-----------------< Zuschnitt_Youtube() >-----------------
Dim objImageShape As InlineShape
For Each objImageShape In ActiveDocument.InlineShapes
'oberen Rand setzen
objImageShape.PictureFormat.CropTop = objImageShape.ScaleHeight * 3.5

'linken Rand setzen
objImageShape.PictureFormat.CropLeft = objImageShape.ScaleWidth * 10

'untern Rand setzen
objImageShape.PictureFormat.CropBottom = objImageShape.ScaleHeight * 12

'rechten Rand setzen
objImageShape.PictureFormat.CropRight = objImageShape.ScaleWidth * 20
Next
'-----------------</ Zuschnitt_Youtube() >-----------------
End Sub

Sub Zuschnitt_Internet_800()
'-----------------< makro_Bild_zuschneiden() >-----------------
Dim objImageShape As InlineShape
For Each objImageShape In ActiveDocument.InlineShapes
'oberen Rand setzen
objImageShape.PictureFormat.CropTop = objImageShape.ScaleHeight * 2

'linken Rand setzen
objImageShape.PictureFormat.CropLeft = objImageShape.ScaleWidth * 10

'untern Rand setzen
objImageShape.PictureFormat.CropBottom = objImageShape.ScaleHeight * 2

'rechten Rand setzen
objImageShape.PictureFormat.CropRight = objImageShape.ScaleWidth * 10
Next
'-----------------</ makro_Bild_zuschneiden() >-----------------
End Sub
Sub Zuschnitt_Internet_Links0_800()
'-----------------< makro_Bild_zuschneiden() >-----------------
Dim objImageShape As InlineShape
For Each objImageShape In ActiveDocument.InlineShapes
'oberen Rand setzen
objImageShape.PictureFormat.CropTop = objImageShape.ScaleHeight * 2

'linken Rand setzen
objImageShape.PictureFormat.CropLeft = objImageShape.ScaleWidth * 0.2

'untern Rand setzen
objImageShape.PictureFormat.CropBottom = objImageShape.ScaleHeight * 2

'rechten Rand setzen
objImageShape.PictureFormat.CropRight = objImageShape.ScaleWidth * 20
Next
'-----------------</ makro_Bild_zuschneiden() >-----------------
End Sub

Sub Zuschnitt_Internet_1024()
'-----------------< makro_Bild_zuschneiden() >-----------------
Dim objImageShape As InlineShape
For Each objImageShape In ActiveDocument.InlineShapes
' 'width=471
' 'oberen Rand setzen
' objImageShape.PictureFormat.CropTop = objImageShape.ScaleHeight * 2
'
' 'linken Rand setzen
' objImageShape.PictureFormat.CropLeft = objImageShape.ScaleWidth * 9
'
' 'untern Rand setzen
' objImageShape.PictureFormat.CropBottom = objImageShape.ScaleHeight * 4
'
' 'rechten Rand setzen
' objImageShape.PictureFormat.CropRight = objImageShape.ScaleWidth * 12


'width=691
'oberen Rand setzen
objImageShape.PictureFormat.CropTop = objImageShape.ScaleHeight * 1.5

'linken Rand setzen
objImageShape.PictureFormat.CropLeft = objImageShape.ScaleWidth * 6

'untern Rand setzen
objImageShape.PictureFormat.CropBottom = objImageShape.ScaleHeight * 1.5

'rechten Rand setzen
objImageShape.PictureFormat.CropRight = objImageShape.ScaleWidth * 6


' 'objimageshape.width=??
' 'oberen Rand setzen
' objImageShape.PictureFormat.CropTop = objImageShape.ScaleHeight * 3.5
'
' 'linken Rand setzen
' objImageShape.PictureFormat.CropLeft = objImageShape.ScaleWidth * 10
'
' 'untern Rand setzen
' objImageShape.PictureFormat.CropBottom = objImageShape.ScaleHeight * 12
'
' 'rechten Rand setzen
' objImageShape.PictureFormat.CropRight = objImageShape.ScaleWidth * 20
Next
'-----------------</ makro_Bild_zuschneiden() >-----------------
End Sub
Sub Bilder_Helligkeit_Plus_10()
'-----------------< Bilder_aufhellen() >-----------------
Dim objImageShape As InlineShape
For Each objImageShape In ActiveDocument.InlineShapes
objImageShape.PictureFormat.Brightness = objImageShape.PictureFormat.Brightness * 1.1
Next
'-----------------</ Bilder_aufhellen() >-----------------
End Sub
Sub Bilder_Kontrast_Plus_10()
'-----------------< Bilder_aufhellen() >-----------------
Dim objImageShape As InlineShape
For Each objImageShape In ActiveDocument.InlineShapes
objImageShape.PictureFormat.Contrast = objImageShape.PictureFormat.Contrast * 1.1
Next
'-----------------</ Bilder_aufhellen() >-----------------
End Sub

Sub Makro1()
'
' Makro1 Makro
'
'
Selection.TypeText Text:="sefsdfsdf"
End Sub
Mobile

.