Sub ExportarImagenEnWord()
Dim applWord As Word.Application
Dim docWord As Word.Document
Dim paraWord As Word.Paragraph
Dim image As Word.InlineShape
Dim oldRange As Range
Dim ratio, i As Integer
'Creo una nueva instancia del Word:
Set applWord = New Word.Application
'Hago al Word visible:
applWord.Visible = True
'Maximizo la ventana del Word:
applWord.WindowState = wdWindowStateMaximize
'Añado un nuevo documento de Word:
Set docWord = applWord.Documents.Add
'Le damos el formato al documento - Orientacion, Tamaño de pagina y Margenes:
With docWord.PageSetup
.LineNumbering.Active = True
.Orientation = wdOrientPortrait
.TopMargin = applWord.InchesToPoints(1)
.BottomMargin = applWord.InchesToPoints(1)
.LeftMargin = applWord.InchesToPoints(1.3)
.RightMargin = applWord.InchesToPoints(1.3)
.PageWidth = applWord.InchesToPoints(8)
.PageHeight = applWord.InchesToPoints(11)
.Gutter = applWord.InchesToPoints(0.25)
.GutterPos = wdGutterPosLeft
End With
'The Selection Property returns the the selected area in the document or if nothing is selected it represents the insertion point.
With applWord.Selection
.Font.Name = "Arial"
.Font.Size = 12
.Font.Bold = True
.Font.Color = wdColorRed
.ParagraphFormat.Alignment = wdAlignParagraphCenter
'set spacing after this paragraph, in points:
.ParagraphFormat.SpaceAfter = 10
End With
Application.ScreenUpdating = False
'Elijo el ratio de aspecto deseado para las imagenes que meteremos al documento de Word
ratio = 100
For i = 1 To ThisWorkbook.Sheets.Count
'Selecciono la hoja indicada por el indice
ThisWorkbook.Sheets(i).Select
If i > 1 Then
'Inserto el nombre de la hoja en el documento. el & vbCrLf es para añadir un salto de linea:
applWord.Selection.TypeText Text:=vbCrLf & vbCrLf
End If
'Inserto el nombre de la hoja en el documento. el & vbCrLf es para añadir un salto de linea:
applWord.Selection.TypeText Text:=ThisWorkbook.ActiveSheet.Name & vbCrLf
Set oldRange = ActiveCell.CurrentRegion
'Selecciono el rango que quiero convertir en imagen
Range("A1:F14").Select
'Guardo la seleccion en el portapapeles como una imagen con el formato indicado
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
oldRange.Select
'Pego la tabla que copie como imagen en el portapapeles
applWord.Selection.Paste
'Si es una imagen la redimensiono al tamaño deseado
'Realmente no necesitamos el condicional ya que sabemos que será una imagen
With docWord.InlineShapes.Item(i)
If .Type = wdInlineShapePicture Then
.LockAspectRatio = msoCTrue
.ScaleHeight = ratio
End If
End With
Next i
'Con este bucle recorro todos los InlineShapes y si son imagenes las redimensiono al tamaño deseado
'O lo hacemos como está dentro del bucle de arriba, o lo hacemos asi, el resultado es el mismo
'For Each image In docWord.InlineShapes
' If image.Type = wdInlineShapePicture Then
' image.LockAspectRatio = msoCTrue
' image.ScaleHeight = ratio
' End If
'Next
'Otro modo de hacerlo
'For i = 1 To docWord.InlineShapes.Count
' With docWord.InlineShapes.Item(i)
' If .Type = wdInlineShapePicture Then
' .LockAspectRatio = msoCTrue
' .ScaleHeight = ratio
' End If
' End With
'Next i
'Limpio la variable usada para recorrer las imagenes y redimensionarlas
Set image = Nothing
Application.ScreenUpdating = True
'Limpio la variable de rango utilizada de modo auxiliar
Set oldRange = Nothing
'Añado un nuevo parrafo al final del documento:
docWord.Paragraphs.Add
'Le indico que lo añada al final del documento y le indico el texto del parrafo.
Set paraWord = docWord.Paragraphs(docWord.Paragraphs.Count)
paraWord.Range.Text = "Escribes lo que quieras y si no lo quieres pues nada, eliminas desde aqui hasta la instruccion donde se guarda el documento."
'damos formato al nuevo parrafo de texto:
With paraWord.Range
.ParagraphFormat.Alignment = wdAlignParagraphJustify
.ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
.ParagraphFormat.LeftIndent = applWord.InchesToPoints(0.25)
.ParagraphFormat.FirstLineIndent = applWord.InchesToPoints(0.5)
.ParagraphFormat.SpaceAfter = 10
With .Font
.Name = "TimesNewRoman"
.Size = 10
.Bold = False
.Color = wdColorBlue
End With
End With
docWord.Paragraphs.Add
Set paraWord = docWord.Paragraphs(docWord.Paragraphs.Count)
paraWord.Range.Text = "Otro parrafo mas de texto."
With paraWord.Range
.ParagraphFormat.Alignment = wdAlignParagraphJustify
.ParagraphFormat.LineSpacingRule = wdLineSpaceDouble
.ParagraphFormat.LeftIndent = applWord.InchesToPoints(0.75)
.ParagraphFormat.FirstLineIndent = applWord.InchesToPoints(1)
.ParagraphFormat.SpaceAfter = 10
With .Font
.Name = "Verdana"
.Size = 10
.Bold = False
.Color = wdColorGreen
End With
End With
'Para guardar el documento en el lugar por defecto:
docWord.SaveAs Filename:="newDoc1.docx"
'Para especificar el documento en una direccion deseada:
'DocWord.SaveAs fileName:="C:\Documents and Settings\Usuario\Mis documentos\newDoc1.docx"
'Guardo y cierro el documento de Word.
docWord.Close SaveChanges:=wdSaveChanges
'Cierro el Word:
applWord.Quit
'Limpio las variables:
Set docWord = Nothing
Set applWord = Nothing
Set paraWord = Nothing
End Sub