Moderatori: Anthony47, Flash30005
Sub WorkAll()
'Vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=109180&p=641302#p641302
Dim daProc As MAPIFolder, Procd As MAPIFolder
Dim myNameSpace As NameSpace, myMex As MailItem, mMitt As String
Dim ZZsjAdd As String, ZZMailTxt As String, I As Long, BasePath As String, PS As String
Dim DayPath As String, J As Long, AttCnt As Long, mWAtt As Long, fCnt As Long, mTot As Long
Dim AName As String, mySplit, myTim As Single, eDel As Single, flXls As Boolean, mRes As Long
Dim mSender, noBB As String
'
Set myNameSpace = Application.GetNamespace("MAPI")
Set daProc = myNameSpace.Folders("Cartelle personali").Folders("Posta in arrivo").Folders("DaProcessare") '<<<Folder di origine
Set Procd = myNameSpace.Folders("Cartelle personali").Folders("Posta in arrivo").Folders("Processate") '<<< Folder si destinazione
BasePath = "C:\PROVA" '<<< La directory "base" in cui saranno salvati gli allegati
'
noBB = "<>:/\|?*" & Chr(34)
PS = "\"
DayPath = Format(Now, "yy-mm-dd")
If Right(BasePath, 1) <> PS Then BasePath = BasePath & PS
DayPath = BasePath & DayPath
If Dir(DayPath, vbDirectory) = "" Then MkDir (DayPath)
mTot = daProc.Items.Count
For J = daProc.Items.Count To 1 Step -1
'For Each myMex In daProc.Items
Set myMex = daProc.Items(J)
flXls = False
If TypeOf myMex Is MailItem Then
mSender = myMex.SenderName
'Stop
' If myMex.SenderEmailType = "EX" Then
' mSender = (myMex.Sender.GetExchangeUser.PrimarySmtpAddress)
' Else
' mSender = (myMex.SenderEmailAddress)
' End If
'bonifica Adr:
For I = 1 To Len(noBB)
mSender = Replace(mSender, Mid(noBB, I, 1), "#", , , vbTextCompare)
Next I
myTim = Timer
AttCnt = myMex.Attachments.Count
If AttCnt > 0 Then
For I = 1 To AttCnt
'"Sistema" il nome file:
AName = myMex.Attachments(I).DisplayName
mySplit = Split(" " & AName, ".", , vbTextCompare)
If UBound(mySplit, 1) > 0 Then
AName = mSender & "_" & Replace(AName, "." & mySplit(UBound(mySplit, 1)), "_" & Format(Now, "hh-mm-ss") & "." & mySplit(UBound(mySplit, 1)))
Else
AName = mSender & "_" & AName & "_" & Format(Now, "hh-mm-ss")
End If
'se file xls, salva allegato:
If InStr(1, mySplit(UBound(mySplit)), "xls", vbTextCompare) > 0 Then
fCnt = fCnt + 1
myMex.Attachments(I).SaveAsFile DayPath & PS & AName
flXls = True
End If
Next I
Else
'Niente?
End If
If flXls Then mWAtt = mWAtt + 1
'Sposta messaggio:
myMex.Move Procd
'eventuale attesa per >1 sec:
If (Timer - myTim) < 1 Then
eDel = (myTim + 1.5 - Timer)
myWait (eDel)
End If
End If
'Next myMex
Next J
mRes = daProc.Items.Count 'Itm residui (non mailItems)
MsgBox ("Completato... " & vbCrLf & "Messaggi esaminati: " & mTot _
& vbCrLf & "Mail (spostate) con allegati: " & mWAtt _
& vbCrLf & "Totale file allegati: " & fCnt _
& vbCrLf & "Messaggi rimanenti (non spostati): " & mRes)
End Sub
Sub myWait(ByVal myStab As Single)
Dim myStTiM As Single
'
myStTiM = Timer
Do 'wait myStab
DoEvents
If Timer > myStTiM + myStab Or Timer < myStTiM Then Exit Do
Loop
End Sub
Solo e tutti i file "XLS*"Solo i file "xls*" saranno scaricati
su Office 2016 non parte la macro.
[. . . .]
Hai qualche idea?
Set daProc = myNameSpace.Folders("Cartelle personali").Folders("Posta in arrivo").Folders("DaProcessare") '<<<Folder di origine
Set Procd = myNameSpace.Folders("Cartelle personali").Folders("Posta in arrivo").Folders("Processate") '<<< Folder si destinazione
Sub folderTree()
Dim olApp As New Outlook.Application
Dim myNameSpace As Outlook.Namespace
Dim I As Long, J As Long, K As Long
Set myNameSpace = olApp.GetNamespace("MAPI")
For I = 1 To myNameSpace.Folders.Count
Debug.Print I, myNameSpace.Folders(I).Name
For J = 1 To myNameSpace.Folders(I).Folders.Count
Debug.Print I, J, myNameSpace.Folders(I).Folders(J)
For K = 1 To myNameSpace.Folders(I).Folders(J).Folders.Count
Debug.Print I, J, K, myNameSpace.Folders(I).Folders(J).Folders(K).Name
Next K
Next J
Next I
End Sub
Format c:
Sub Processa_Moduli()
'Vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=109180&p=641302#p641302
Dim daProc As MAPIFolder, Procd As MAPIFolder
Dim myNameSpace As NameSpace, myMex As MailItem, mMitt As String
Dim ZZsjAdd As String, ZZMailTxt As String, I As Long, BasePath As String, PS As String
Dim DayPath As String, MonthPath As String, YearPath As String, J As Long, AttCnt As Long, mWAtt As Long, fCnt As Long, mTot As Long
Dim AName As String, mySplit, myTim As Single, eDel As Single, flXls As Boolean, mRes As Long
Dim mSender, noBB As String
'
Set myNameSpace = Application.GetNamespace("MAPI")
Set daProc = myNameSpace.Folders("xy@xy.com").Folders("Posta in arrivo").Folders("_Da Processare") '<<<Folder di origine
Set Procd = myNameSpace.Folders("xy@xy.com").Folders("Posta in arrivo").Folders("_Processate") '<<< Folder si destinazione
'BasePath = "C:\PROVA" '<<< La directory "base" in cui saranno salvati gli allegati
BasePath = "S:\Invio-Ricezione\Ricezione_Moduli_Excel\MODULI CLIENTI DA PROCESSARE"
MsgBox ("Ora cerco Moduli excel da archiviare.. premi ok e attendi mio messaggio..")
noBB = "<>:/\|?*" & Chr(34)
PS = "\"
YearPath = Format(Now, "yyyy") & "_Moduli_Da_processare" '<<< inizio mia modifica al codice
If Right(BasePath, 1) <> PS Then BasePath = BasePath & PS
YearPath = BasePath & YearPath
If Dir(YearPath, vbDirectory) = "" Then MkDir (YearPath)
MonthPath = MonthName(Month(Date)) & Format(Now, "_yyyy") & "_Moduli_Da_processare"
If Right(YearPath, 1) <> PS Then YearPath = YearPath & PS
MonthPath = YearPath & MonthPath
If Dir(MonthPath, vbDirectory) = "" Then MkDir (MonthPath)
DayPath = Format(Now, "dd-mm-yyyy") & "_Moduli_Da_processare"
If Right(MonthPath, 1) <> PS Then MonthPath = MonthPath & PS
DayPath = MonthPath & DayPath
If Dir(DayPath, vbDirectory) = "" Then MkDir (DayPath) '<<< fine mia modifica al codice
mTot = daProc.Items.Count
For J = daProc.Items.Count To 1 Step -1
'For Each myMex In daProc.Items
Set myMex = daProc.Items(J)
flXls = False
If TypeOf myMex Is MailItem Then
mSender = myMex.SenderName
'Stop
' If myMex.SenderEmailType = "EX" Then
' mSender = (myMex.Sender.GetExchangeUser.PrimarySmtpAddress)
' Else
' mSender = (myMex.SenderEmailAddress)
' End If
'bonifica Adr:
For I = 1 To Len(noBB)
mSender = Replace(mSender, Mid(noBB, I, 1), "#", , , vbTextCompare)
Next I
myTim = Timer
AttCnt = myMex.Attachments.Count
If AttCnt > 0 Then
For I = 1 To AttCnt
'"Sistema" il nome file:
AName = myMex.Attachments(I).DisplayName
mySplit = Split(" " & AName, ".", , vbTextCompare)
If UBound(mySplit, 1) > 0 Then
AName = mSender & "_" & Replace(AName, "." & mySplit(UBound(mySplit, 1)), "_" & Format(Now, "hh-mm-ss") & "." & mySplit(UBound(mySplit, 1)))
Else
AName = mSender & "_" & AName & "_" & Format(Now, "hh-mm-ss")
End If
'se file xls, salva allegato:
If InStr(1, mySplit(UBound(mySplit)), "xls", vbTextCompare) > 0 Then
fCnt = fCnt + 1
myMex.Attachments(I).SaveAsFile DayPath & PS & AName
flXls = True
End If
Next I
Else
'Niente?
End If
If flXls Then mWAtt = mWAtt + 1
'Sposta messaggio:
myMex.Move Procd
'eventuale attesa per >1 sec:
If (Timer - myTim) < 1 Then
eDel = (myTim + 1.5 - Timer)
myWait (eDel)
End If
End If
'Next myMex
Next J
mRes = daProc.Items.Count 'Itm residui (non mailItems)
MsgBox ("Completato... " & vbCrLf & "Messaggi esaminati: " & mTot _
& vbCrLf & "Mail (spostate) con allegati: " & mWAtt _
& vbCrLf & "Totale file allegati: " & fCnt _
& vbCrLf & "Messaggi rimanenti (non spostati): " & mRes)
End Sub
Sub myWait(ByVal myStab As Single)
Dim myStTiM As Single
'
myStTiM = Timer
Do 'wait myStab
DoEvents
If Timer > myStTiM + myStab Or Timer < myStTiM Then Exit Do
Loop
End Sub
myMex.Attachments(I).SaveAsFile DayPath & PS & AName
?DayPath & PS & AName
S:\Invio-Ricezione\Ricezione_Moduli_Excel\MODULI CLIENTI DA PROCESSARE\2018_Moduli_Da_processare\marzo_2018_Moduli_Da_processare\13-03-2018_Moduli_Da_processare
Torna a Applicazioni Office Windows
Salvare file excel in formato html escludendo le immagini Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 10 |
Acquistare un disco esterno portatile per salvare i da Autore: Giovannino60 |
Forum: Consigli per gli acquisti Risposte: 3 |