ImagenesFinal

Option Explicit

Public Sub AbrirLibrosv3()

    Dim img As Shape

    Dim fso As Object, fCarpeta As Object, tmpCarpeta As Object

    Dim Fichero As Object, tmpFichero As Object

    Dim strRutaInicial As String



    strRutaInicial = "D:\Check_List_Hold_Point"


    Set fso = CreateObject("Scripting.FileSystemObject")

    Set fCarpeta = fso.GetFolder(strRutaInicial)


    For Each tmpFichero In fCarpeta.Files

    If LCase(Mid(tmpFichero.Name, InStr(tmpFichero.Name, ".") + 1)) = "xlsx" Then
        Workbooks.Open tmpFichero.Path

        Application.ScreenUpdating = False



        Application.ScreenUpdating = True

        ActiveWorkbook.Close savechanges:=False
    End If

    Next tmpFichero


    Recursivo strRutaInicial

End Sub


Private Sub Recursivo(ByVal RutaInicial As String)

    Dim fso As Object, fCarpeta As Object, tmpCarpeta As Object

    Dim Fichero As Object, tmpFichero As Object

    Dim ruta As String
    Dim hojaActual As Worksheet
    Dim graficoActual As ChartObject
    Dim img As Shape
    Dim strTempName As String
    ' Dim objHolder As ChartObject
    Dim PicWidth As Long, PicHeight As Long
    Dim MyChart As String, MyPicture As String
    Dim intIndex As Integer

    Dim intListCount As Integer
    Dim objTemp As Object
    Dim objHolder As ChartObject
    Dim sngWidth As Single
    Dim sngHeight As Single
    Dim shapeType As Integer


    Set fso = CreateObject("Scripting.FileSystemObject")

    Set fCarpeta = fso.GetFolder(RutaInicial)

    ruta = "D:\Graficos\"

    For Each tmpCarpeta In fCarpeta.SubFolders

        For Each tmpFichero In tmpCarpeta.Files

            If LCase(Mid(tmpFichero.Name, InStr(tmpFichero.Name, ".") + 1)) = "xlsx" Then
                Workbooks.Open tmpFichero.Path

                Application.ScreenUpdating = False

                For Each hojaActual In Sheets

                    For intIndex = 1 To hojaActual.Shapes.Count
                         On Error Resume Next

                         Set objTemp = ActiveSheet.Shapes(intIndex)
                         strTempName = ActiveSheet.Shapes(intIndex).Name
                         shapeType = CStr(ActiveSheet.Shapes(intIndex).Type)

                         Set objHolder = ActiveSheet.ChartObjects.Add(100, 200, 400, 200)
                         objHolder.Activate

                         sngWidth = objTemp.Width
                         sngHeight = objTemp.Height

                         With objHolder
                            .Width = sngWidth + 20
                            .Height = sngHeight + 20
                            If shapeType = 6 Then 'Objetos Agrupados
                                objTemp.CopyPicture xlScreen, xlBitmap
                            Else
                                objTemp.Copy
                            End If
                         End With

                         With objHolder
                            .Chart.Paste
                            With .Chart.Shapes(1)
                                .Placement = xlMove
                                .Left = -4
                                .Top = -4
                            End With
                            .Width = sngWidth + 1
                            .Height = sngHeight + 1
                            .Chart.Export ruta & tmpFichero.Name & hojaActual.Name & "-" & strTempName & ".jpg", "jpg"
                            .Chart.Shapes(1).Delete


                        End With

                    Next


                Next

                Application.ScreenUpdating = True


                ActiveWorkbook.Close savechanges:=False
            End If

        Next

        Recursivo tmpCarpeta.Path

    Next tmpCarpeta

End Sub