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
| Option Explicit
Dim M As Integer
Dim F As Byte
Dim ChckB(68) As New ClasseChckB
Dim Wsl, Wsz As Worksheet
Dim Ctrl As Control
Dim t As Byte
Dim NomDuFichier As String
Dim WordApp As Object
Dim WordDoc As Object
Private Sub CmdB_Exporter_Click() ' Bouton Exporter
Set Wsz = Sheets("Feuille Temporaire")
Application.ScreenUpdating = False
For t = 1 To 68
If Me.Controls("Checkbox" & t).Value = True Then
GoTo LaSuite
Else
MsgBox "Vous n'avez rien coché !?", 48, "Attention"
Exit Sub
End If
Next t
LaSuite:
Wsz.Cells.ClearContents
For M = 1 To 68
If Me.Controls("CheckBox" & M).Value = True Then
Wsz.Cells(1, M).Value = Me.Controls("CheckBox" & M).Caption
Wsz.Cells(1, M).Interior.ColorIndex = 35 ' Vert
Wsz.Cells(1, M).Font.ColorIndex = 41 ' Bleu
Wsz.Cells(1, M).Font.Name = "Courrier New"""
Wsz.Cells(1, M).Font.FontStyle = "Gras"
Wsz.Cells(1, M).Font.Size = 12
Wsz.Cells(2, M).Value = Me.Controls("TextBox" & M).Value
Wsz.Cells(2, M).Font.Name = "Courrier New"
Wsz.Cells(2, M).Font.Size = 12
End If
Next M
Sheets("Feuille Temporaire").Select
With Sheets("Feuille Temporaire")
Range("A1:BP2").Select: Selection.Copy: Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Rows("1:2").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Columns("B:B").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.ColumnWidth = 45
.Range("A1").Select
DétruireLigne
.Range("B1").Interior.Color = xlNone
.Range("B1").Interior.Pattern = xlNone
.Range("B1").Font.ColorIndex = xlAutomatic
.Range("B1").Font.Bold = False
End With
Application.DisplayAlerts = True
' ---------------------------------------------------------------------------------------------
' Transferer les données exporter vers Word |
' ---------------------------------------------------------------------------------------------
NomDuFichier = ("D:\" & NomUtilisateur & "\Documents\Fichiers Clients\" & TextBox3.Value _
& " " & TextBox4.Value & " " & TextBox5.Value)
On Error Resume Next
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
Set WordDoc = WordApp.Documents.Add
WordApp.Selection.TypeText Text:="Détail du contact" ' Insère du texte au point d'insertion
WordApp.Selection.TypeParagraph ' Sauter une ligne
Wsz.Range("A1:B" & Wsz.Range("A" & Rows.Count).End(xlUp).Row).Select
Selection.Font.Name = "Courier New"
Selection.Font.Size = 10
Selection.Copy
WordDoc.Range.PasteSpecial ' Colle les données dans Word
' ---------------> Ma mise en forme dans Word
'Selection.Shading.Texture = WordDoc.TextureNone
'Selection.Shading.ForegroundPatternColor = WordDoc.ColorAutomatic
'Selection.Shading.BackgroundPatternColor = WordDoc.ColorAutomatic
'ActiveWindow.ActivePane.View.ShowAll = Not ActiveWindow.ActivePane.View.ShowAll
'Selection.Tables(1).Style = "Grille du tableau"
'ActiveWindow.ActivePane.View.ShowAll = Not ActiveWindow.ActivePane.View.ShowAl
Application.CutCopyMode = False
WordDoc.SaveAs NomDuFichier ' Enregistre les modifications
WordApp.Quit ' Quitte Word
Set WordDoc = Nothing ' Vide l'objet en mémoire
Set WordApp = Nothing ' Vide l'objet en mémoire
MsgBox ("Document créé et rangé")
Unload Me
End Sub |
