Colegul meu Lucian a propus o solutie cu coduri macro.
Solutia lui este:
Cod: Selectaţi tot
Sub LSPrint(Item As Outlook.MailItem)
'---------------------------------------------------------------------------
' Descriere : Aceast script tipareste fisierele atasate mesajului Outlook
' trimis ca parametru
'
' Parametrii : Item = Mesajul din Inbox ce trebuie prelucrat
'
' Utilizare : Scriptul se poate folosi la prelucrarea mesajelor sosite in Inbox
' apelabil in cadrul unei reguli
'
' NOTA : Necesita referinta catre Microsoft Scripting Runtime
' Se adauga din Tools\References
'---------------------------------------------------------------------------
' Avertizare : Acest cod trebuie luat asa cum este.
' Orice test se va efectua pe o copie a datelor originale
'---------------------------------------------------------------------------
' Author : Lucian Constantin
' Date : 25.11.2009
' Versiunea : 0.1
' Site web : http://www.officespecialist.ro
'---------------------------------------------------------------------------
On Error GoTo OError
'Detecteaza folder-ul temporar
Dim oFS As FileSystemObject
Dim sTempFolder As String
Set oFS = New FileSystemObject
'Temporary Folder Path
sTempFolder = oFS.GetSpecialFolder(TemporaryFolder)
'Creaza un folder temporar "special" pentru acest script
cTmpFld = sTempFolder & "\OETMP" & Format(Now, "yyyymmddhhmmss")
MkDir (cTmpFld)
'Prelucrare atasamente (save & print)
Dim oAtt As Attachment
For Each oAtt In Item.Attachments
FileName = oAtt.FileName
FullFile = cTmpFld & "\" & FileName
'Salveaza atasamentul
oAtt.SaveAsFile (FullFile)
'Tipareste atasamentul
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(0)
Set objFolderItem = objFolder.ParseName(FullFile)
objFolderItem.InvokeVerbEx ("print")
Next oAtt
'Cleanup
If Not oFS Is Nothing Then Set oFS = Nothing
If Not objFolder Is Nothing Then Set objFolder = Nothing
If Not objFolderItem Is Nothing Then Set objFolderItem = Nothing
If Not objShell Is Nothing Then Set objShell = Nothing
OError:
If Err <> 0 Then
MsgBox Err.Number & " - " & Err.Description
Err.Clear
End If
Exit Sub
End Sub
In plus, in afara de faptul ca atunci cand printeaza documente Word, codul macro de mai sus insereaza un modul in sablonul Normal.dotm pe care nu il mai sterge.
Iata noul cod rezultat:
Acest cod merge in modulul: ThisOutlookSession
Cod: Selectaţi tot
'---------------------------------------------------------------------------
' Descriere : Aceast script tipareste fisierele atasate mesajului Outlook
' trimis ca parametru
'
' Parametrii : Item = Mesajul din Inbox ce trebuie prelucrat
'
' Utilizare : Scriptul se poate folosi la prelucrarea mesajelor sosite in Inbox
' apelabil in cadrul unei reguli
'
' NOTA : Necesita referinta catre Microsoft Scripting Runtime
' Se adauga din Tools\References
' : Sursa secundara de informatii:
' http://www.eggheadcafe.com/forumarchives/outlookprogram_visualbasica/dec2005/post24716352.asp
'---------------------------------------------------------------------------
' Avertizare : Acest cod trebuie luat asa cum este.
' Orice test se va efectua pe o copie a datelor originale
'---------------------------------------------------------------------------
' Author : Lucian Constantin si Alexandru Dionisie
' Date : 25.11.2009
' Versiunea : 0.2
' Site web : http://www.officespecialist.ro
'---------------------------------------------------------------------------
Private Const RUN_ONCE As Boolean = True
'intervalul pentru timer, exprimat in milisecunde
' 10000 milisecunde = 10 secunde
Private Const TIMER_INTERVAL As Long = 20000
Public Sub Timer()
If RUN_ONCE Then
modTimer.DisableTimer
End If
Call DeleteTemp
End Sub
Sub PrintAttachement(Item As Outlook.MailItem)
On Error GoTo Error
' creem o copie a sablonului Word
FileCopy "C:\Documents and Settings\" & Environ("USERNAME") & "\Application Data\Microsoft\Templates\Normal.dotm", _
"C:\Documents and Settings\" & Environ("USERNAME") & "\Application Data\Microsoft\Templates\Normal.bak"
'Detecteaza folder-ul temporar
Dim oFS As FileSystemObject
Dim sTempFolder As String
Set oFS = New FileSystemObject
'Temporary Folder Path
sTempFolder = oFS.GetSpecialFolder(TemporaryFolder)
'Creaza un folder temporar "special" pentru acest script
cTmpFld = sTempFolder & "\OETMP" & Format(Now, "yyyymmddhhmmss")
MkDir (cTmpFld)
'Prelucrare atasamente (save & print)
Dim oAtt As Attachment
For Each oAtt In Item.Attachments
FileName = oAtt.FileName
FullFile = cTmpFld & "\" & FileName
'Salveaza atasamentul
oAtt.SaveAsFile (FullFile)
'Tipareste atasamentul
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(0)
Set objFolderItem = objFolder.ParseName(FullFile)
objFolderItem.InvokeVerbEx ("print")
Next oAtt
'Cleanup
If Not oFS Is Nothing Then Set oFS = Nothing
If Not objFolder Is Nothing Then Set objFolder = Nothing
If Not objFolderItem Is Nothing Then Set objFolderItem = Nothing
If Not objShell Is Nothing Then Set objShell = Nothing
' restauram copia sablonului
FileCopy "C:\Documents and Settings\" & Environ("USERNAME") & "\Application Data\Microsoft\Templates\Normal.bak", _
"C:\Documents and Settings\" & Environ("USERNAME") & "\Application Data\Microsoft\Templates\Normal.dotm"
'activam timer-ul
modTimer.EnableTimer TIMER_INTERVAL, Me
Error:
If Err <> 0 Then
MsgBox Err.Number & " - " & Err.Description
Err.Clear
End If
Exit Sub
End Sub
Sub DeleteTemp()
'stergem toate fisierele temporare
Set objApp = CreateObject("WScript.Shell")
objApp.Run "cmd.exe /c " & Chr(34) & "rmdir /S /Q %temp%" & Chr(34)
End Sub
Cod: Selectaţi tot
Option Explicit
Private Declare Function SetTimer Lib "user32.dll" (ByVal hwnd As Long, _
ByVal nIDEvent As Long, ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" (ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
Const WM_TIMER = &H113
Private hEvent As Long
Private m_oCallback As Object
Public Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long)
If uMsg = WM_TIMER Then
m_oCallback.Timer
End If
End Sub
Public Function EnableTimer(ByVal msInterval As Long, oCallback As Object) As Boolean
If hEvent <> 0 Then
Exit Function
End If
hEvent = SetTimer(0&, 0&, msInterval, AddressOf TimerProc)
Set m_oCallback = oCallback
EnableTimer = CBool(hEvent)
End Function
Public Function DisableTimer()
If hEvent = 0 Then
Exit Function
End If
KillTimer 0&, hEvent
hEvent = 0
End Function
Cod: Selectaţi tot
FileCopy "C:\Documents and Settings\" & Environ("USERNAME") & "\Application Data\Microsoft\Templates\Normal.dotm", _
"C:\Documents and Settings\" & Environ("USERNAME") & "\Application Data\Microsoft\Templates\Normal.bak"
Daca ati personalizat aplicatia MS Word sa salveze sablonul intr-o alta locatie, schimbati aceste linii.