Visual Basic - Ayuda Capturar Pantalla Formulario y enviar a Word

Option Compare Database

Declare Sub keybd_event _

    Lib "user32" _

   (ByVal bVk As Byte, _

    ByVal bScan As Byte, _

    ByVal dwFlags As Long, _

    ByVal dwExtraInfo As Long)

Public Sub CapturarVentana()

'On Error GoTo manejar_err

    'Declaramos variables

    Dim i As Integer, x As String, Ruta As String

    Dim Wordobj As word.Application, objdoc As word.Document, objselection As word.Selection

    'Buscamos el último separador (\) del nombre completo de la BdD.

    i = InStrRev(CurrentDb.Name, "\")

    'Obtenemos la ruta de la carpeta en la que se va a guardar el documento

    Ruta = Left(CurrentDb.Name, i) & "Dashboard\"

   'keybd_event vbKeySnapshot, 1&, 0&, 0&

    keybd_event vbKeySnapshot, 0, 0, 0

    Set Wordobj = CreateObject("Word.Application")

    With Wordobj

    .Visible = True

    .Activate

    .WindowState = wdWindowStateMaximize

    End With

    Set objdoc = Wordobj.Documents.Open(Ruta & "DashBoard.docx")

    Set objselection = Wordobj.Selection

    'Paste into Word

objselection.Paste

   'Selecciona el objeto

 Wordobj.ActiveDocument.Shapes.SelectAll

   'Redimensiona el objeto. Requiere el módulo ResizePics()

   '-----------------------------------------------------------------------------

 Call ResizePics

   'Ruta = Ruta & Date & "\" 'Añadimos a la ruta la subcarpeta

   ' xMkDir Ruta 'Creamos la carpeta si no existía (Requiere el módulo mdlProcedimientos)

    hoy = Format(Time, "hhmmss")

    objdoc.SaveAs2 Ruta & "DashBoard_" & hoy & ".docx" 'Guardamos el documento

    Wordobj.Quit

    'objdoc.Close

    Set Wordobj = Nothing

    Set objdoc = Nothing

    Set objselection = Nothing

    MsgBox "Pantalla copiada a fichero word"

   ' Exit Sub

manejar_err:

MsgBox err.Description & err.Number, vbCritical

On Error Resume Next

Set Wordobj = Nothing

Set objdoc = Nothing

Set objselection = Nothing

End Sub

Sub ResizePics()

Dim shp As word.Shape

Dim ishp As word.InlineShape

If word.Selection.Type <> wdSelectionInlineShape And _

word.Selection.Type <> wdSelectionShape Then

Exit Sub

End If

If word.Selection.Type = wdSelectionInlineShape Then

Set ishp = word.Selection.Range.InlineShapes(1)

ishp.LockAspectRatio = False

ishp.Height = InchesToPoints(7.8)

ishp.Width = InchesToPoints(10.8)

Else

If word.Selection.Type = wdSelectionShape Then

Set shp = word.Selection.ShapeRange(1)

shp.LockAspectRatio = False

shp.Height = InchesToPoints(7.8)

shp.Width = InchesToPoints(10.8)

End If

End If

Set ishp = Nothing

Set shp = Nothing

End Sub