Modificar Macro para tomar la imagen de diferente ruta según información de celda en excel
Como lo tengo hoy, es así:
Adentro de la carpeta Dropbox, hay 5 carpetas:
Infracciones
Cartas Generadas
Servidor 1
Servidor 2
Servidor 3
El archivo maestro de Bitácora y cartas están en la carpeta de infracciones.
La idea es que las cartas que se generan se guarden en la Carpeta de Cartas Generadas.
Las imágenes se encuentran en las carpetas de Servidor "1,2, o 3" según sea el caso.
La intención es que en lugar de que tome la imagen de la misma carpeta, y deposite la carta en la misma carpeta, tome la imagen de la carpeta que le corresponde, y deposite la carta en la carpeta de cartas generadas.
La carpeta que le corresponde es de acuerdo a la columna "B" del archivo de Bitácora, la columna tiene como titulo "S" y se refiere al numero de servidor, donde el valor solo puede ser "1,2 ó 3".
¿Me ayudas?
Asi es como se ve.
La ruta es: D:\Documents and Settings\Gerente\Mis documentos\Dropbox
Gracias
Prueba lo siguiente para poner el archivo en los servidores 1,2,3
Sub CorrespondenciaConWord()
'Por.Dante Amor
'
patharch = ThisWorkbook.Path & "\cartas.dotx"
i = ActiveCell.Row
'
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.documents.Add Template:=patharch, NewTemplate:=False, DocumentType:=0
'
For j = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
textobuscar = Cells(1, j)
objWord.Selection.Move 6, -1
objWord.Selection.Find.Execute FindText:=textobuscar
'
While objWord.Selection.Find.found = True
objWord.Selection.Text = Cells(i, j) 'texto a reemplazar
objWord.Selection.Move 6, -1
objWord.Selection.Find.Execute FindText:=textobuscar
Wend
'
Next
'
ruta = "D:\Documents and Settings\Gerente\Mis documentos\Dropbox\"
Select Case Cells(i, "B")
Case 1: serv = "Servidor 1\"
Case 2: serv = "Servidor 2\"
Case 3: serv = "Servidor 3\"
End Select
'ruta = ThisWorkbook.Path & "\"
archivo = ruta & serv & Format(Cells(i, "A"), "yyyymmdd") & Format(Cells(i, "D"), "HHMM") & Cells(i, "E")
If Dir(archivo & ".bmp") <> "" Then
objWord.Selection.Find.Execute FindText:="Insertar imagen"
Set objShape = objWord.Selection.InlineShapes.AddPicture(archivo & ".bmp")
End If
'
ObjWord. Activate
ObjWord. ActiveDocument. SaveAs archivo
objWord. ActiveDocument. Close
objWord. Quit
End Sub
