1
2
3
Sub billet_remove()
Worksheets("mafeuille").ListObjects("T_monbotablo").Range.RemoveDuplicates Columns:=Array(1,4), Header:=xlYes
End Sub

Worksheets("mafeuille").ListObjects("T_monbotablo").Range.RemoveDuplicates Columns:=tabarray, Header:=xlYes

Evaluate(tabarray)

(tabarray)

1
2
3
4
5
Sub épure_doublons()

Call billet_remove("parent", "ville")

End Sub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub billet_remove(ParamArray listechamps() As Variant)

ReDim tabarray(0 To UBound(listechamps)) As Variant

Dim i As Long

With Worksheets("mafeuille").ListObjects("T_monbotablo")
      
        For i = 0 To UBound(tabarray)
               tabarray(i) = .ListColumns(listechamps(i)).Index
        Next i
         
        .Range.RemoveDuplicates Columns:=Evaluate(tabarray), Header:=xlYes

End With

End Sub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Option Explicit

Sub FiltreTableau()

   Dim cellRésult As Range
    
    With ThisWorkbook.Worksheets("Feuil1")
    
    If .FilterMode = True Then
            .ListObjects("monbotablo").Range.AutoFilter
    End If
    
    .ListObjects("monbotablo").Range.AutoFilter _
        Field:=1, Criteria1:="=be*"
 
    'Renvoie la plage de cellules visibles après l'application du filtre.
    Set cellRésult = .ListObjects("monbotablo").Range.Cells.SpecialCells(xlCellTypeVisible).Cells
    
    End With

End Sub

Field:= 1

1
2
3
4
5
Option Explicit

Public Sub filter_tablostruc()
        Call FiltreTableau(lechamp:="pays", lecritère:="It*")
End Sub

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
Public Sub FiltreTableau(lechamp As String, lecritère As String)
   
Dim numchamp As Integer
Dim cellRésult As Range

'Filtre la colonne du tableau correspondant au paramètre "lechamp",
'avec pour crtitère le paramètre "lecritère"
'sensible à la casse.

With Worksheets("Feuil1")

        'Efface le filtre éventuel
        If .FilterMode = True Then _
                .ListObjects("monbotablo").Range.AutoFilter
        'Recherche la colonne où se trouve le champ souhaité
        numchamp = .ListObjects("monbotablo").ListColumns(lechamp).Index
        'Filtre
        .ListObjects("monbotablo").Range.AutoFilter _
                Field:=numchamp, Criteria1:=lecritère
        
        'Renvoie la plage de cellules visibles après l'application du filtre
        
        '1 -avec la ligne de titre
        Set cellRésult = .ListObjects("monbotablo").Range.Cells.SpecialCells(xlCellTypeVisible).Cells
        Debug.Print "1ère cellule des titres: " & cellRésult.Cells(1, 1).Value
        
        '2 -sans la ligne de titre
        Set cellRésult = .ListObjects("monbotablo").DataBodyRange.Cells.SpecialCells(xlCellTypeVisible).Cells
        Debug.Print "1ère cellule des enregistrements: " & cellRésult.Cells(1, 1).Value

End With

End Sub

numchamp = Application.WorksheetFunction.Match(lechamp, .ListObjects("monbotablo").HeaderRowRange, 0)

macel = laplage.fonctionx(« Toto », , , , False)

1
2
3
4
5
6
7
8
Dim lemessage As Variant         
lemessage = MsgBox( _
                    Prompt:="Une extraction est possible" & Chr(13) & _
                                   "Souhaitez-vous la créer?", _
                    Buttons:=vbYesNo, _
                    Title:="Tableau récapitualatif.")
        
If lemessage = vbYes Then……

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Option Explicit

Public Sub protéger(lafeuil As String, motpasse As String, celdep As String, laprotection As Boolean, Optional nblignes As Long, Optional nbcolonnes As Integer)

With Worksheets(lafeuil)
        
        .Unprotect Password:= motpasse
        .Cells.Locked = False
        
        'Pour contrôle
         Debug.Print .Range(celdep).Resize(IIf(nblignes = 0, 1, nblignes), IIf(nbcolonnes = 0, 1, nbcolonnes)).Address
        
        .Range(celdep).Resize(IIf(nblignes = 0, 1, nblignes), IIf(nbcolonnes = 0, 1, nbcolonnes)).Locked = laprotection
        .Protect Password:= motpasse

End With

End Sub

1
2
3
4
5
Sub essai()

protéger "VENETA", "PUGLIA", "A1", True, , 10

End Sub

, ,

1
2
3
4
5
Sub essai()

Call protéger(lafeuil:="VENETA", motpasse:="PUGLIA",  celdep:="A1", laprotection:=True, nbcolonnes:=10)

End Sub

1
2
3
4
5
6
7
8
9
10
11
12
Option Explicit

Public WithEvents lebouton As CommandButton

Private Sub lebouton_Click()

MsgBox _
        Prompt:="Bonjour le Forum", _
        Buttons:=vbInformation, _
        Title:="Message d'accueil"

End Sub

1
2
3
4
5
6
7
8
9
10
11
Option Explicit

Dim clsbtn() As New Class_boutons

Private Sub Workbook_Open()
Dim b As Byte
For b = 1 To 3
        ReDim Preserve clsbtn(1 To b)
        Set clsbtn(b).lebouton = Worksheets("Wks_" & b).OLEObjects("Btn_Bonjour").Object
Next b
End Sub

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
Option Explicit

Dim fullname_img As String

Public Type destinataire
        obj As String
        lapj As String
        lalistedest As Range
        lecorps As Range
End Type

Public Function données_dest(ledest As String) As destinataire

Dim lawks As Worksheet
Set lawks = ThisWorkbook.Worksheets("liste_mails")

Dim t As Range

Set t = lawks.Range("liste_dest").Find(what:=ledest, lookat:=xlWhole, LookIn:=xlValues)

With données_dest
        Set .lalistedest = lawks.Range("Détail_" & CStr(t.Value))
        .obj = t.Offset(0, 1).Value
        .lapj = t.Offset(0, 2).Value
        Set .lecorps = lawks.Range("corps_" & t.Value)
End With

Set t = Nothing

Set lawks = Nothing

End Function

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
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
Public Sub envoi_mails_groupés()

Dim c As Range

For Each c In Worksheets("liste_mails").Range("liste_dest")

        Call Envoi_Mail(c.Value)

Next c

Application.DisplayAlerts = True

End Sub

Sub Envoi_Mail(letoto As String)

 Dim lobjet As String
 Dim str_pj As String
 Dim rng_dest As Range
 Dim rng_body As Range
 
With données_dest(letoto)
        lobjet = .obj
        str_pj = .lapj
        Set rng_dest = .lalistedest
        Set rng_body = .lecorps
End With

Dim lapj As String
lapj = ThisWorkbook.Path & Application.PathSeparator & str_pj & ".pdf"

Dim MonItem As Outlook.MailItem

'Requiert une référence à la bibliothèque d'objets Outlook
Dim Applic_Outlook As Outlook.Application
Dim édit_ol As Outlook.Inspector
'Requiert une référence à la bibliothèque d'objets Word
Dim wdDoc As Word.Document

Dim liste_adresses As String

liste_adresses = ""
'For Each c In données_dest(letoto).lalistedest
'        liste_adresses = liste_adresses & c.Value & ";"
'Next c
Dim tb() As Variant
ReDim tb(1 To rng_dest.Count)
tb = Application.Transpose(rng_dest)

liste_adresses = Join(tb, ";")

Application.ScreenUpdating = False

'Crée l'objet Outlook
Set Applic_Outlook = CreateObject("Outlook.Application")

'Créer l'élément de mail et le transmettre
Set MonItem = Applic_Outlook.CreateItem(olMailItem)

With MonItem
        
        '.BodyFormat = olFormatHTML
        .To = liste_adresses
        .Subject = lobjet
        .Display
        .Attachments.Add Source:=lapj

        On Error Resume Next
        AppActivate lobjet & " - Message (HTML)" ' Active Outlook
        AppActivate lobjet & " - Message" ' Active Outlook
        On Error GoTo 0
        
        Set édit_ol = .GetInspector
        
        'Portée module
        Set wdDoc = édit_ol.WordEditor
        
        'importation du corps de texte dans le corps de message
        Call save_img(données_dest(letoto).lecorps)

        With wdDoc
                'New 10 Décembre 2019
                .InlineShapes.AddPicture Filename:=fullname_img
                'Image redimensionnée
                .InlineShapes(1).Width = 600
        End With

        Set wdDoc = Nothing
        Set édit_ol = Nothing

        .Send
        
        Application.CutCopyMode = False
        
End With

Set MonItem = Nothing
Set Applic_Outlook = Nothing

Set rng_dest = Nothing
Set rng_body = Nothing

ActiveWindow.DisplayGridlines = True

End Sub

Public Sub save_img(corpstexte As Range)

'Création d'un fichier image sur le répertoire de ce classeur

'---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

Dim s As Shape
With Worksheets("liste_mails")
        
        .Activate
        
        ActiveWindow.DisplayGridlines = False
        
        'Précaution
        If .Shapes.Count > 0 Then
                For Each s In .Shapes
                        With s
                                If (InStr(.Name, "Venise") + InStr(.Name, "Rome")) = 0 Then .Delete
                        End With
                Next s
        End If
        
End With

'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

Dim texte_date As String, name_img As String

texte_date = Format(Date, "yyyymmdd")
name_img = "Image_" & texte_date & ".jpg"
fullname_img = ThisWorkbook.Path & "\" & name_img

'----------------------
Dim Fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim FileItem As Scripting.file
 
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(ThisWorkbook.Path)
 
For Each FileItem In SourceFolder.Files
 
        With FileItem
               'Debug.Print .Name
               If InStr(.Name, "jpg") > 0 Then
                     If InStr(.Name, name_img) = 0 Then Kill .Path
               End If
        End With
 
Next FileItem

Set SourceFolder = Nothing
Set Fso = Nothing
 
'----------------------

Application.ScreenUpdating = False

'Dim lechart As Object, hPicAvail As Long
Dim lechart As Object

With Worksheets("liste_mails")

    
    Set lechart = .ChartObjects.Add(0, 0, 1, 1).Chart
    
         CreateObject("htmlfile").parentwindow.clipboardData.clearData ("Text")  'on vide le clipboard entre chaque copie pour tester vraiment le available
        
        With lechart.Parent
                 
                 .Width = corpstexte.Width
                 .Height = corpstexte.Height
                 .Left = corpstexte.Left + corpstexte.Width + 20:
                 
                 corpstexte.CopyPicture Appearance:=xlScreen, Format:=xlPicture
                 
                 .Select
                 
                 Do
                       DoEvents
                 Loop Until .Chart.Pictures.Count = 0
                 
                 .Chart.Paste
                 
                 'Do
                 '      DoEvents
                 'Loop While .Chart.Pictures.Count = 0
                 
                 With .Chart
                       .Export Filename:=fullname_img, FilterName:="jpg"
                 End With
                 
                 .Delete
                 
           End With
           
      Set lechart = Nothing
      
End With

End Sub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub TestDeleteSig()
    Dim objMsg As Outlook.MailItem
    Set objMsg = Application.CreateItem(olMailItem)
    objMsg.Display
    Call DeleteSig(objMsg)
    Set objMsg = Nothing
End Sub

Sub DeleteSig(msg As Outlook.MailItem)
    Dim objDoc As Word.Document
    Dim objBkm As Word.Bookmark
    On Error Resume Next
    Set objDoc = msg.GetInspector.WordEditor
    Set objBkm = objDoc.Bookmarks("_MailAutoSig")
    If Not objBkm Is Nothing Then
        objBkm.Select
        objDoc.Windows(1).Selection.Delete
    End If
    Set objDoc = Nothing
    Set objBkm = Nothing
End Sub

1
2
3
4
5
6
Dim objBkm As Word.Bookmark
 
           With wdDoc
                    If .bookmarks.Exists(Name:="_MailAutoSig") Then _
                                .bookmarks(Index:="_MailAutoSig").Range.Delete
            End With

1
2
3
    Set objBkm = wdDoc.bookmarks("_MailAutoSig")
    If Not objBkm Is Nothing Then objBkm.Range.Delete
    Set objBkm = Nothing

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
Option Explicit
 
 Public Declare Function SetWindowPos _
        Lib "user32" ( _
            ByVal Hwnd As Long, _
            ByVal hWndInsertAfter As Long, _
            ByVal x As Long, ByVal y As Long, _
            ByVal cx As Long, ByVal cy As Long, _
            ByVal wFlags As Long) _
    As Long

Public Const SWP_NOSIZE = &H1
Public Const SWP_NOMOVE = &H2
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2

Sub Test_Open_Outlook()

Dim Chemin As String
Chemin = "C:\Program Files (x86)\Microsoft Office\root\Office16\OUTLOOK.exe"
 
Dim Appli As Object
Dim session_Outlook As New Outlook.Application
Dim Ole_appli As Object
 
Dim typouv As Byte
typouv = 1

On Error Resume Next
Set Appli = GetObject(, "Outlook.Application")
 
Call ShowXLOnTop(True)

If Appli Is Nothing Then

      'Ouvre Outlook
        session_Outlook = Shell(Chemin, typouv)

Else
        
        'Fermeture de l'application Outlook si ouverte et réouverture d'une nouvelle
        Call KillProcess("Outlook.exe")
        
        session_Outlook = Shell(Chemin, typouv)

End If
 
Set Ole_appli = Nothing
Set Appli = Nothing

Call ShowXLOnTop(False)

End Sub

Sub ShowXLOnTop(ByVal OnTop As Boolean)
    Dim xStype As Long

Dim xHwnd As Long

If OnTop Then
        xStype = HWND_TOPMOST
    Else
        xStype = HWND_NOTOPMOST
    End If
    Call SetWindowPos(Application.Hwnd, xStype, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE)
End Sub

 Public Function KillProcess(ByVal ProcessName As String) As Boolean
    Dim svc As Object
    Dim sQuery As String
    Dim oproc
    Set svc = GetObject("winmgmts:root\cimv2")
    sQuery = "select * from win32_process where name='" & ProcessName & "'"
    For Each oproc In svc.execquery(sQuery)
        oproc.Terminate
    Next
    Set svc = Nothing
End Function