CODE: Cod macro pt. a printa atasamentul unui E-mail sosit

trucuri, sfaturi si alte idei pentru imbunatatirea lucrului cu Outlook
Închis
Dr. Cloud
Mesaje: 3327
Membru din: Mar Oct 02, 2012 11:19 am

CODE: Cod macro pt. a printa atasamentul unui E-mail sosit

Mesaj de Dr. Cloud » Mie Noi 25, 2009 3:21 pm

In cadrul acestui topic se ceruse o regula pentru a printa atasamentele unui E-mail sosit de la un anumit destinatar.
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
Dat fiind faptul ca acest cod populeaza fisierul Temp din Windows, impreuna cu Lucian am lucrat la o noua versiune a acestui cod si am reusit sa facem in asa fel incat dupa printare sa se goleasca fisierul Temp de elemente nedorite.
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
Intr-un modul obisnuit se va insera urmatorul cod pentru timer:

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
Urmatoarele linii:

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"
Ne indica unde este localizat sablonul Normal.dotm.
Daca ati personalizat aplicatia MS Word sa salveze sablonul intr-o alta locatie, schimbati aceste linii.

Dr. Cloud
Mesaje: 3327
Membru din: Mar Oct 02, 2012 11:19 am

Re: CODE: Cod macro pt. a printa atasamentul unui E-mail sosit

Mesaj de Dr. Cloud » Lun Mai 24, 2010 7:18 pm

Subiect inchis.
Daca cineva doreste sa continue discutie, sa anunte un moderator pe privat pentru a redeschide subiectul.

Închis

Înapoi la “Tips and tricks in Outlook (indiferent de versiune)”