[VBA OUTLOOK] pièces jointes [Résolu]

[SpaceFrog]

Bonjour !
ça faisait un bail que je n'étais pas passé par ici ..


Bon voici ce qui m'amène :
Je suis en traine d'essayer d'ajouter une extension à outlook, un visionneur d'images jointes, en effet cela lui manque cruellement. Si vous recevez une dizaine d'images en pièces jointes, il faut les auvergarder dasn un repertoire pour les visulaiser. Les extensions gratuites dispo sur le net sont bridées à quelques images.

Bref j'ai trouvé un article sur MSDN qui parle du sujet mais j'ai un bug dasn le code...

en effet il n'arrive pas à récupérer les references de ou des images ...
ça se passe sur cette ligne là :

Code :

strImageFile = strTempFolderPath & "\" & objCurrentMessage.Attachments.Item(lstAtts.List(intListIndex, 0)).DisplayName

mon strImageFile reste vide ....
une idée ?

[bidou]

aloa ma grenouille

c'est sensé représenter quoi ?
lstAtts.List(intListIndex, 0)

[SpaceFrog]

c'est la liste des pièces jointes ...
à priori c'est la version de outlook qui ne permet pas ça ...

ça se passe par là bidou
http://msdn.microsoft.com/office/def...PictAttach.asp

[SpaceFrog]

j'ai trouvé un autre code mais là encore il ne fonctionne pas

Code :

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
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
'NOTE: references are needed for scripting runtime!!!!
 
'Windows API function declarations
Private Declare Function OpenProcess Lib "kernel32.dll" ( _
                 ByVal dwDesiredAccess As Long, _
                 ByVal bInheritHandle As Long, _
                 ByVal dwProcessId As Long) As Long
 
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
      hHandle As Long, ByVal dwMilliseconds As Long) As Long
 
Private Declare Function CloseHandle Lib "kernel32.dll" _
      (ByVal hObject As Long) As Long
 
Const SYNCHRONIZE = &H100000
Const INFINITE = &HFFFF
 
Public Sub picview1()
    'This is the entry point for the macro, which gets the mail item from the open inspector or from the explorer selected item
    On Error Resume Next
    Dim exp As Outlook.Explorer
    Dim insp As Outlook.Inspector
 
    Set insp = ActiveInspector
    If Not insp Is Nothing Then 'check if an inspector was active
        If insp.CurrentItem.Class = olMail Then picview (insp.CurrentItem)
    Else
        Set exp = Outlook.ActiveExplorer
        If Not exp Is Nothing And exp.Selection.Count = 1 And exp.Selection.item(1).Class = olMail Then Call picview(exp.Selection.item(1))
    End If
End Sub
 
Public Sub picview(ByRef msg As MailItem)
    Dim oAttach As Attachment
    Dim pictures As Collection
    Dim fso As FileSystemObject
    Dim oFolder As Folder
    Dim i As Integer
 
    On Error GoTo err_pic
 
    If msg.Attachments.Count = 0 Then Exit Sub
 
    Set fso = New FileSystemObject
    Set pictures = New Collection
 
    For Each oAttach In msg.Attachments 'check attachments extenstion and if a picture add to the pictures collection
        'actually this is a slow and memory wasting method, but very easy to use and read. a faster method is to save the indexes in an integer array
        If Right(oAttach.FileName, 3) = "jpg" Or Right(oAttach.FileName, 3) = "bmp" Or Right(oAttach.FileName, 3) = "gif" Then
            pictures.Add oAttach
        End If
    Next
    If pictures.Count > 0 Then
        i = 0
        While fso.FolderExists("c:\temp\picview" & strGen(i)) 'set up folder name
            i = i + 1
        Wend
        Set oFolder = fso.CreateFolder("c:\temp\picview" & strGen(i)) 'Make new folder
 
        For Each oAttach In pictures
            i = 0
            While fso.FileExists(oFolder.Path & "\" & strGen(i) & oAttach.FileName) 'set up file name
                i = i + 1
            Wend
            oAttach.SaveAsFile oFolder.Path & "\" & strGen(i) & oAttach.FileName
        Next
        Call ShellAndWait("rundll32.exe C:\WINDOWS\System32\shimgvw.dll,ImageView_Fullscreen " & oFolder.Path, vbMaximizedFocus) 'run the viewer
        oFolder.Delete True 'clean up folder
    End If
    Exit Sub
 
err_pic:
    If Err.Number = 91 Then
        Exit Sub
    Else
        Debug.Print Err.Number
        Resume Next
    End If
End Sub
 
Private Sub ShellAndWait(ByVal program_name As String, _
    ByVal window_style As VbAppWinStyle)
    'this function runs a program in the shell then connects to the process and wait for the process
    'to become signalled. the function then returns. note that the WaitForSingleobject API function
    'is very low on CPU consumption. another possible method would have been a doevents loop that checks
    'for process state. that would have been very easy to write (using WSH wshExec.status) but heavy on the cpu
Dim process_id As Long
Dim process_handle As Long
 
    ' Start the program.
    On Error GoTo ShellError
    process_id = Shell(program_name, window_style)
    On Error GoTo 0
 
    DoEvents
 
    ' Wait for the program to finish.
    ' Get the process handle.
    process_handle = OpenProcess(SYNCHRONIZE, 0, process_id)
    If process_handle <> 0 Then
        WaitForSingleObject process_handle, INFINITE 'Wait for program to become signaled
        CloseHandle process_handle
    Else
        Debug.Print "Dll error " & Err.LastDllError
    End If
 
    Exit Sub
 
ShellError:
    MsgBox "Error starting task " & _
        txtProgram.Text & vbCrLf & _
        Err.Description, vbOKOnly Or vbExclamation, _
        "Error"
End Sub
 
Private Function strGen(i As Integer) As String
    'This function is just to fix file names the way i like it. not really necessary
    If i = 0 Then
        strGen = ""
    Else
        strGen = "~" & i
    End If
End Function

Testé en mode pas à pas il ne lance pas picview ... ???

[SpaceFrog]

Bon alors à priori il y avait une syntaxe non reconnue par outlook 2000 que j'ai réussi à remplacer puis un autre soucie de base 0 ou 1 de tableau.
Tout tourne à merveille

j'ai même ajouté d'autre viewers dasn la liste ...

Si cet addon vous intéresse vous savez ou me trouver ...