DescargarImagenesFinal

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 strTempName As String

    Dim PicWidth As Long, PicHeight As Long
    Dim intIndex As Integer

    Dim objTemp As Object
    Dim objHolder As ChartObject
    Dim sngWidth As Single
    Dim sngHeight As Single
    Dim shapeType As Integer
    Dim path As String
    Dim directory As String



    Set fso = CreateObject("Scripting.FileSystemObject")

    Set fCarpeta = fso.GetFolder(RutaInicial)

    directory = "D:\Graficos\"
    path = directory & Right(fCarpeta, Len(fCarpeta) - 3)
    If Len(Dir(path, vbDirectory)) = 0 Then
        MkDir path
    End If


    For Each tmpCarpeta In fCarpeta.SubFolders
        Debug.Print tmpCarpeta
        path = directory & Right(tmpCarpeta, Len(tmpCarpeta) - 3)
        If Len(Dir(path, vbDirectory)) = 0 Then
            MkDir path
        End If
        For Each tmpFichero In tmpCarpeta.Files
            If (Left(tmpFichero.Name, 1) = "~") Then  'Valida documentos ocultos
                GoTo Break1
            End If

            Debug.Print tmpFichero
            path = directory & Right(tmpFichero, Len(tmpFichero) - 3)
            If Len(Dir(path, vbDirectory)) = 0 Then
                MkDir path
                Debug.Print path
            End If

            If LCase(Mid(tmpFichero.Name, InStr(tmpFichero.Name, ".") + 1)) = "xlsx" Or LCase(Mid(tmpFichero.Name, InStr(tmpFichero.Name, ".") + 1)) = ".xlsx" Then
                Application.DisplayAlerts = False
                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 = hojaActual.Shapes(intIndex)
                         strTempName = hojaActual.Shapes(intIndex).Name
                         shapeType = CStr(hojaActual.Shapes(intIndex).Type)

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

                         sngWidth = objTemp.Width
                         sngHeight = objTemp.Height

                         If intIndex = 20 Then
                             strTempName = hojaActual.Shapes(intIndex).Name
                         End If

                         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
                             If ((.Height > 40) And ((shapeType = 6) Or (shapeType = 13))) Then
                                path = path & "\"
                                .Chart.Export path & strTempName & ".jpg", "jpg"
                             End If
                            .Chart.Shapes(1).Delete
                         End With
                    Next

                Next

                Application.ScreenUpdating = True

                ActiveWorkbook.Close savechanges:=False

                Application.DisplayAlerts = True
            End If
Break1:

        Next

        Recursivo tmpCarpeta.path

    Next

End Sub