Cambio de ruta auotmatico al cambiar el mes?
Esta es la marco que uso actualmente.
Private Sub commandbutton1_click()
nombre = Cells(7, 4).Value
folio = Cells(5, 13).Value
fecha = Cells(7, 13).Value
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"\\192.168.1.XXX\Ordenes de Compra\EMPRESA\Julio2017\" & nombre & " " & folio & " .pdf", Quality:= _
xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
Application.DisplayAlerts = False
ActiveSheet.Unprotect "Fulcrum07"
Range("M5").Value = Range("M5").Value + 1
ActiveSheet.Protect "Fulcrum07"
Range("C11:J11,C12:J12,C13:J13,C14:J14,C15:J15,C16:J16,C17:J17,C18:J18,C19:J19,C20:J20,D24:N24,C25:N25,C26:N26,C27:N27,M11:M20"). ClearContents
ActiveWorkbook.Save
strReportName = "\\192.168.1.XXX\Ordenes de Compra\EMPRESA\OrdendeCompra_Jorge Suarez.xlsm"
Dim objOutlook As Object
Dim objMail As Object
Dim objOutlookAttach As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(olMailItem)
Set objOutlookAttach = objOutlook.CreateItem(olAttachMents)
With objMail
'A quien va dirigido el correo
.To = ""
.CC = ""
.CC = ""
.BCC = ""
'Se especifica el asunto
.Subject = " O.C. De " & fecha & nombre & folio
'Se escriben el o los archivos a adjuntar en el mail
.Attachments.Add "\\192.168.1.XXX\Ordenes de Compra\EMPRESA\Julio2017\" & nombre & " " & folio & " .pdf"
.Body = "Se anexa orden de compra favor de confirmar recepción"
'Se manda el mensaje
.Send
End With
'Se cierran todos los objetos utilizados
Set objMail = Nothing
Set objOutlook = Nothing
ActiveWorkbook.Close
End Sub
Por el momento lo guarda en la carpeta Julio2017 pero al llegar al 01 de Agosto, quiero que en automático lo guarde en Agosto2017.
Las carpetas ya las tengo creadas en el servidor.
1 Respuesta
Te anexo la macro actualizada, también cuando llegues a enero de 2018, la macro pondrá "enero2018"
Private Sub commandbutton1_click()
nombre = Cells(7, 4).Value
folio = Cells(5, 13).Value
fecha = Cells(7, 13).Value
mes = Format(Date, "mmmm")
año = Year(Date)
ruta = "\\192.168.1.XXX\Ordenes de Compra\EMPRESA\" & mes & año & "\"
'
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=ruta & nombre & " " & folio & " .pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=False, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
Application.DisplayAlerts = False
ActiveSheet.Unprotect "Fulcrum07"
Range("M5").Value = Range("M5").Value + 1
ActiveSheet.Protect "Fulcrum07"
Range("C11:J11,C12:J12,C13:J13,C14:J14,C15:J15,C16:J16,C17:J17,C18:J18,C19:J19,C20:J20,D24:N24,C25:N25,C26:N26,C27:N27,M11:M20"). ClearContents
ActiveWorkbook.Save
strReportName = "\\192.168.1.XXX\Ordenes de Compra\EMPRESA\OrdendeCompra_Jorge Suarez.xlsm"
Dim objOutlook As Object
Dim objMail As Object
Dim objOutlookAttach As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(olMailItem)
Set objOutlookAttach = objOutlook.CreateItem(olAttachMents)
With objMail
'A quien va dirigido el correo
.To = ""
.CC = ""
.CC = ""
.BCC = ""
'Se especifica el asunto
.Subject = " O.C. De " & fecha & nombre & folio
'Se escriben el o los archivos a adjuntar en el mail
.Attachments.Add ruta & nombre & " " & folio & " .pdf"
.Body = "Se anexa orden de compra favor de confirmar recepción"
'Se manda el mensaje
.Send
End With
'Se cierran todos los objetos utilizados
Set objMail = Nothing
Set objOutlook = Nothing
ActiveWorkbook.Close
End Sub
.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.
