Guardar correos individuales en disco duro
Publicado por Alfonso (1 intervención) el 05/02/2021 02:53:45
Que tal.
Me han proporcionado una macro que toma los mensajes seleccionados en Outlook y los guarda como archivos .msg individuales en el directorio definido. El nombre del archivo incluye la fecha y hora de recepción. Los espacios y los caracteres no válidos se reemplazan por guiones bajos. Como dije, el directorio destino está definido en el código de la macro y quiero darle la posibilidad al usuario de elegir donde guardar dichos archivos, para ello me han proporcionado otro código que me da una ventana de exploración para elegir dicho directorio, sin embargo y a pesar de haber seguido las indicaciones, no logro que funcione, siempre me marca error. Por separado funcionan bien, el detalle es a la hora de juntarlos.
El código del macro simple es este:
El código de la función que me genera el cuadro de dialogo es este:
Y el código donde ambos se juntan es este:
Quiero suponer que donde indica:
Debo incrustar el código de la función, pero por mas que lo intento, lo cambio de posicion, etc., no logro que funcione.
Alguien podrá echarme una mano?
Saludos!
Me han proporcionado una macro que toma los mensajes seleccionados en Outlook y los guarda como archivos .msg individuales en el directorio definido. El nombre del archivo incluye la fecha y hora de recepción. Los espacios y los caracteres no válidos se reemplazan por guiones bajos. Como dije, el directorio destino está definido en el código de la macro y quiero darle la posibilidad al usuario de elegir donde guardar dichos archivos, para ello me han proporcionado otro código que me da una ventana de exploración para elegir dicho directorio, sin embargo y a pesar de haber seguido las indicaciones, no logro que funcione, siempre me marca error. Por separado funcionan bien, el detalle es a la hora de juntarlos.
El código del macro simple es este:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
Option Explicit
Public Sub SaveMessageAsMsg()
Dim oMail As Outlook.MailItemDim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
For Each objItem In ActiveExplorer.SelectionIf objItem.MessageClass = "IPM.Note" Then
Set oMail = objItemsName = oMail.Subject
ReplaceCharsForFileName sName, "-"
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
sPath = enviro & "\Documents\"
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG
End If
Next
End Sub
Private Sub ReplaceCharsForFileName(sName As String, _
sChr As String _
)sName = Replace(sName, "'", sChr)
sName = Replace(sName, "*", sChr)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End Sub
El código de la función que me genera el cuadro de dialogo es este:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = NothingSelect Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid: BrowseForFolder = FalseEnd Function
Y el código donde ambos se juntan es este:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
Option Explicit
Public Sub SaveMessageAsMsg()
Dim oMail As Outlook.MailItemDim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String
Dim strFolderpath As String
enviro = CStr(Environ("USERPROFILE"))
'Defaults to Documents folder' get the function athttp://slipstick.me/u1a2dstrFolderpath = BrowseForFolder(enviro & "\documents\")
For Each objItem In ActiveExplorer.SelectionIf objItem.MessageClass = "IPM.Note" Then
Set oMail = objItemsName = oMail.Subject
ReplaceCharsForFileName sName, "-"
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
sPath = strFolderpath & "\"
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG
End If
Next
End Sub
Quiero suponer que donde indica:
1
2
3
4
enviro = CStr(Environ("USERPROFILE"))
'Defaults to Documents folder' get the function athttp://slipstick.me/u1a2dstrFolderpath = BrowseForFolder(enviro & "\documents\")
Debo incrustar el código de la función, pero por mas que lo intento, lo cambio de posicion, etc., no logro que funcione.
Alguien podrá echarme una mano?
Saludos!
Valora esta pregunta
0