Discussion :

[raph974]

Bonjour,

J'ai récupéré une macro qui permet de remplir un combobox à partir d'un fichier Excel fermé.
Sous Excel ça fontionne très bien.
Sous Outlook, j'ai erreur d'exécution 438 : Propriété ou méthode non gérée par cet objet.

Voici le code :

Code vba :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Explicit
 
Const NDF = "C:\test.xlsx"
 
Private RcdSt() As Variant
Private Req As String
 
Private Sub UserForm_Initialize()
 
ComboBox1.List = Get_Combo("Nom", "Clients")
 
End Sub
' *************************************************************************************************
Function Query(Req As String) As Long
Dim Cnx As Object, Rst As Object
Dim i As Long, j As Long
 
    On Error GoTo errhdlr
 
    Set Cnx = CreateObject("ADODB.Connection")
    Cnx.Provider = "MSDASQL"
 
    Cnx.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & _
             "DBQ=" & NDF & "; ReadOnly=False;"
 
    If Left(Req, 6) = "SELECT" Then
        Set Rst = CreateObject("ADODB.Recordset")
        Rst.Open Req, Cnx, 3
 
        Query = Rst.RecordCount
        If Not Query = 0 Then
            ReDim RcdSt(Rst.Fields.Count - 1, Query - 1)
            Rst.MoveFirst
            RcdSt = Rst.GetRows
            For i = 0 To UBound(RcdSt, 1) - 1
                For j = 0 To UBound(RcdSt, 2) - 1
                    If IsNull(RcdSt(i, j)) Then RcdSt(i, j) = ""
                Next j
            Next i
        End If
    Else
        Cnx.Execute Req
        Query = 0
    End If
 
    Cnx.Close
    Set Rst = Nothing
    Set Cnx = Nothing
    Exit Function
 
errhdlr:
    If Not Rst Is Nothing Then If Rst.State = 1 Then Rst.Close
    If Not Cnx Is Nothing Then If Cnx.State = 1 Then Cnx.Close
    Set Rst = Nothing
    Set Cnx = Nothing
    Query = -1
    MsgBox (Err.Description)
End Function
 
 
' *************************************************************************************************
Function Get_Combo(Chps As String, Ong As String) As Variant()
    Req = "SELECT DISTINCT " & Chps & " FROM [" & Ong & "$] ORDER BY " & Chps
    Erase Get_Combo
    If Query(Req) > 0 Then Get_Combo = Application.Transpose(RcdSt)
 
End Function

J'ai l'impression que c'est la ligne suivante qui pose problème d'après exécution pas à pas (F8) :
ComboBox1.List = Get_Combo("Nom", "Clients")

Je vous remercie de votre aide.

[Invité]

Bonjour

Je ne suis pas un pro du VBA Outlook, mais je pense que cette ligne pose un problème.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Application.Transpose

Je ne pense pas que ce soit dans le modèle objet Outlook.

Philippe

[raph974]

Bien vu !
Effectivement Application.Transpose n'existe pas sous Outlook.

C'est dommage, ce code était exactement ce que je voulais...

[Oliv-]

Bonjour,

Exact il s'agit d'une fonction de Excel

voici une autre façon de faire

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Explicit
 
Const NDF = "C:\temp\test.xlsx"
 
Private Req As String
 
 
Private Sub UserForm_Initialize()
 
    Call Get_Combo("Nom", "Clients")
 
End Sub
' *************************************************************************************************
Function Query(Req As String) As Long
 
    Dim i As Long
 
    On Error GoTo errhdlr
Dim Rst As Object
Dim Cnx As Object
    Set Cnx = CreateObject("ADODB.Connection")
    Cnx.Provider = "MSDASQL"
 
    Cnx.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & _
             "DBQ=" & NDF & "; ReadOnly=False;"
 
    If Left(Req, 6) = "SELECT" Then
        Set Rst = CreateObject("ADODB.Recordset")
        Rst.Open Req, Cnx, 3
 
        Query = Rst.RecordCount
        If Not Query = 0 Then
            Rst.MoveFirst
            With ComboBox1
                While Not Rst.EOF
                    .AddItem (Rst.Fields("Nom"))
                    '.List(i, 1) = Rst.Fields("idOperateur")
                    Rst.MoveNext
                    'i = i + 1
                Wend
            End With
        End If
    Else
        Cnx.Execute Req
        Query = 0
    End If
 
 
     Cnx.Close
    Set Rst = Nothing
    Set Cnx = Nothing
    Exit Function
 
errhdlr:
    If Not Rst Is Nothing Then If Rst.State = 1 Then Rst.Close
    If Not Cnx Is Nothing Then If Cnx.State = 1 Then Cnx.Close
    Set Rst = Nothing
    Set Cnx = Nothing
    Query = -1
    MsgBox (Err.Description)
End Function
 
 
' *************************************************************************************************
Function Get_Combo(Chps As String, Ong As String) As Boolean
    Req = "SELECT DISTINCT " & Chps & " FROM [" & Ong & "$] ORDER BY " & Chps
    Get_Combo = False
    If Query(Req) > 0 Then
        Get_Combo = True
    End If
End Function