Copiar archivo jpg

solilopi · el 10 de marzo

Hola de nuevo, tengo esta macro:

Sub Inserta_foto()



'Renombramos archivo



Name "C:\Seat\Fotos\foto.jpg" As "C:\Seat\Fotos\imagen.jpg"



ActiveCell.Select



ActiveSheet.Pictures.Insert("C:\Seat\Fotos\imagen.jpg").Select



With Selection



.ShapeRange.LockAspectRatio = msoFalse

.ShapeRange.Height = 60.75 'Alto de la imagen

.ShapeRange.Width = 84 'Ancho de la imagen

.ShapeRange.Left = .ShapeRange.Left + 1 'Añadimos 1 para que se vea la línea divisoria de la celda (izquierda)

.ShapeRange.Top = .ShapeRange.Top + 1 'Añadimos 1 para que se vea la línea divisoria de la celda (superior)



'Movemos archivo a la carpeta Historico



  Name "C:\Seat\Fotos\imagen.jpg" As "C:\Seat\Historico\imagen_" & Format(Now, "dd-mm-yyyy") & ".jpg"





End With



End Sub[/CODE]

Mientras la he ejecutado en mi PC, un usuario sólo, no ha habido problema, los problemas vienen al utilizar el archivo desde un servidor varios usuarios, os explico:

El archivo está en un servidor y lo ejecutan tres usuarios distintos por lo que a la hora de renombrar el archivo, la ruta depende del usuario en cuestión siendo +/- C:\Users\nombre_usuario\imagenes.

Además, las imágenes se guardan con el formato: WIN_YYYYMMDD_HH_MM_SS_Pro, por lo que es otra historia poner caracteres comodín para que se pueda hacer el proceso.

Resumiendo:

Necesito poder coger de la carpeta imágenes del usuario activo una foto con el formato anterior para insertarla en una hoja Excel y luego guardarla en otra carpeta. Me falla la primera parte del problema, ¿puede alguien decirme como lo puedo hacer? Gracias.

LeandroA · el 11 de marzo

Hola podes usar hay varias formas de recuperar el usuario, o una carpeta especial, para este caso la mas fácil es usar Environ("USERPROFILE") esto retorna la ruta

C:\Users\nombre_usuario\

por lo tanto solo vasta con concatenar la palabra Pictures, ya que Imagenes es solo de visualización en el explorer.

MsgBox Environ("USERPROFILE") & "\Pictures"[/CODE]

LeandroA · el 11 de marzo

otra forma es utilizando la api SHGetSpecialFolderLocation de esta forma te retorna la ruta completa ya que a veces la carpeta Imágenes podría estar en otra ubicación.

Option Explicit

#If VBA7 And Win64 Then

    Private Type SHITEMID

        cb As LongLong

        abID As Byte

    End Type

    Private Declare PtrSafe Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long

    Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As LongLong, ByVal pszPath As String) As Long

    Private Declare PtrSafe Function GetUserNameA Lib "advapi32.dll" (ByVal lpBuffer As String, nSize As Long) As Long

#Else


    Private Type SHITEMID

        cb As Long

        abID As Byte

    End Type

    Private Declare  Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long

    Private Declare  Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As long, ByVal pszPath As String) As Long

    Private Declare  Function GetUserNameA Lib "advapi32.dll" (ByVal lpBuffer As String, nSize As Long) As Long

#End If


Private Type ITEMIDLIST

    mkid As SHITEMID

End Type


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

Enum eCSIDL_SPECIAL_FOLDERS

    ADMINTOOLS = &H30

    ALTSTARTUP = &H1D

    APPDATA = &H1A

    BITBUCKET = &HA

    COMMON_ADMINTOOLS = &H2F

    COMMON_ALTSTARTUP = &H1E

    COMMON_APPDATA = &H23

    COMMON_DESKTOPDIRECTORY = &H19

    COMMON_DOCUMENTS = &H2E

    COMMON_FAVORITES = &H1F

    COMMON_PROGRAMS = &H17

    COMMON_STARTMENU = &H16

    COMMON_STARTUP = &H18

    COMMON_TEMPLATES = &H2D

    Connections = &H31

    Controls = &H3

    COOKIES = &H21

    DESKTOP = &H0

    DESKTOPDIRECTORY = &H10

    DRIVES = &H11

    FAVORITES = &H6

    FLAG_DONT_VERIFY = &H4000

    FLAG_MASK = &HFF00&

    FLAG_PFTI_TRACKTARGET = FLAG_DONT_VERIFY

    Fonts = &H14

    INTERNET = &H1

    HISTORY = &H22

    INTERNET_CACHE = &H20

    LOCAL_APPDATA = &H1C

    MYPICTURES = &H27

    NETHOOD = &H13

    NETWORK = &H12

    PERSONAL = &H5

    PRINTERS = &H4

    PRINTHOOD = &H1B

    PROFILE = &H28

    PROGRAM_FILES = &H26

    PROGRAM_FILES_COMMON = &H2B

    PROGRAM_FILES_COMMONX86 = &H2C

    PROGRAM_FILESX86 = &H2A

    PROGRAMS = &H2

    RECENT = &H8

    SENDTO = &H9

    STARTMENU = &HB

    STARTUP = &H7

    SYSTEM = &H25

    SYSTEMX86 = &H29

    TEMPLATES = &H15

    Windows = &H24

End Enum


Public Sub MostrarRutaImagenes()

    MsgBox GetSpecialFolder(MYPICTURES)

End Sub



Function GetUserName() As String

    Dim lpBuff As String * 25

    GetUserNameA lpBuff, 25

    GetUserName = Left(lpBuff, InStr(lpBuff, Chr(0)) - 1)

End Function


Function GetSpecialFolder(SpecialFolder As Long) As String


    Dim IDL          As ITEMIDLIST

    Dim sPath        As String * 512


    If SHGetSpecialFolderLocation(100, SpecialFolder, IDL) = 0 Then

        Call SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath$)

        GetSpecialFolder = Left$(sPath, InStr(sPath, Chr$(0)) - 1)

    End If

End Function[/CODE]

solilopi · el 11 de marzo

Hola podes usar hay varias formas de recuperar el usuario, o una carpeta especial, para este caso la mas fácil es usar Environ("USERPROFILE") esto retorna la ruta
C:\Users\nombre_usuario\

por lo tanto solo vasta con concatenar la palabra Pictures, ya que Imagenes es solo de visualización en el explorer.
MsgBox Environ("USERPROFILE") & "\Pictures"[/CODE]
Hola Leandro, no entiendo, MsgBox, ¡¿Mensaje en pantalla?!. ¿Cómo pongo eso en la macro?. Además, está el problema con el nombre del archivo de imagen que no sé cómo narices lo pongo también en la ruta.

LeandroA · el 11 de marzo

Vos querias conocer la carpeta Imagenes del usario activo, pues bien el msgbox era solo para mostrarlo, vos sabras que hacer con esa ruta

Environ("USERPROFILE") & "\Pictures"

haber como para que lo entiendas, porque no se bien como es el nombre de la imagen.jpg

ActiveSheet.Pictures.Insert(Environ("USERPROFILE") & "\Pictures\" & 

"imagen_" & Format(Now, "dd-mm-yyyy") & ".jpg"

).Select[/CODE]

algo asi es como tienes que usarlo, ajusta como va a ser el nombre de la imagen.jpg

solilopi · el 11 de marzo

El nombre de la imagen, o una de ellas es: WIN_20160310_14_41_25_Pro. Cada vez que se genera una el prefijo WIN_ no cambia, sólo cambia el resto, que como puedes ver es la fecha en formato yyyymmdd_ y la hora separada por_ acabado en _Pro que también es fijo.

Pero lo que quiero, a parte de poner un nombre comodín para poder capturar la imagen, es que independientemente del usuario que abra el Excel, al ejecutar la macro cargue la foto que hay en su carpeta imágenes. No sé si me he explicado bien.

LeandroA · el 11 de marzo

te subi una macro, eso deveria insertar una imagen desde la carpeta imagenes de cualquier usuario con el nombre WIN_*_Pro*

Libro2.zip

solilopi · el 11 de marzo

Gracias, según veo inserta la imagen en la hoja activa. Me parece un buen comienzo para lo que pretendo. Voy a intentar aprovechar tu código para hacer lo que quiero. Repito, muchas gracias por tu tiempo y tu ayuda.

solilopi · el 11 de marzo

Hola de nuevo, al intentar guardar la imagen procesada en otra carpeta cojo la ruta y la intento copiar pero me da error.

el código de copiado es:

Name (sRuta & sNombre) As "C:\Seat\Historico\WIN_*_Pro.jpg"[CODE]

¿Qué tengo mal?[/CODE]

LeandroA · el 11 de marzo

Hola no podes usar * para el nombre de destino, porque no usas el mismo nombre que el origen

Name (sRuta &amp; sNombre) As "C:\Seat\Historico\" &amp; sNombre

solilopi · el 11 de marzo

Ya lo he solucionado. El código final queda así:

Sub Inserta_foto()


Dim sRuta As String, sNombre As String, sPath As String, sArchivo As String

Dim valor As Integer



sRuta = Environ("USERPROFILE") & "\pICTURES\"

sNombre = Dir(sRuta & "WIN_*_Pro*")

valor = Len(sNombre)


ActiveCell.Select


If Len(sNombre) Then


ActiveSheet.Pictures.Insert(sRuta & sNombre).Select


End If


With Selection


.ShapeRange.LockAspectRatio = msoFalse

.ShapeRange.Height = 60.75 'Alto de la imagen

.ShapeRange.Width = 84 'Ancho de la imagen

.ShapeRange.Left = .ShapeRange.Left + 1 'Añadimos 1 para que se vea la línea divisoria de la celda (izquierda)

.ShapeRange.Top = .ShapeRange.Top + 1 'Añadimos 1 para que se vea la línea divisoria de la celda (superior)

End With


sArchivo = Right(sNombre, 29)

Name sRuta & sNombre As "C:\Seat\Historico\" & sArchivo

End Sub[/CODE]