Discussion :

[Lustrui]

Bonjour,

j'ai besoin d'un coup de main pour un projet PPT. L'objectif est de venir cocher des checkbox et ensuite de lancer une macro pour qu'elle génère un fichier excel avec une ligne par checkbox coché sous ce format:
VARIBLE=Nom_de_la_checkbox ETAT=I

Est-ce que quelqu'un à des idées?

Merci d'avance

[E KERGRESSE]

A tester :

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
72
73
74
75
76
77
78
79
80
81
82
83
84
 
Option Explicit
 
Sub ExporterDansFichierExcel()
 
Dim I As Integer, J As Integer, IndexMatrice As Integer
Dim xlApp As Object, FichierExcel As Object
Dim Chemin As String
Dim PptDoc As Presentation
Dim MatriceCheckbox() As Variant, DateSauvegarde As Variant
 
       On Error GoTo Fin
 
       IndexMatrice = 0
       Set PptDoc = ActivePresentation
       Chemin = PptDoc.Path & "\Etat Checkbox Ppt "
       With PptDoc
            .Save
            DateSauvegarde = RecupererLaDate(.Path & "\", .Name)
            For I = 1 To .Slides.Count
                With .Slides(I)
                     For J = 1 To .Shapes.Count
                         With .Shapes(J)
                              If .Type = msoOLEControlObject Then
                              If .OLEFormat.ProgID = "Forms.CheckBox.1" Then
                                 Debug.Print .OLEFormat.ProgID
                                 ReDim Preserve MatriceCheckbox(3, IndexMatrice)
                                 MatriceCheckbox(0, IndexMatrice) = I
                                 MatriceCheckbox(1, IndexMatrice) = .OLEFormat.Object.Name
                                 MatriceCheckbox(2, IndexMatrice) = .OLEFormat.Object.Caption
                                 MatriceCheckbox(3, IndexMatrice) = .OLEFormat.Object.Value
                                 IndexMatrice = IndexMatrice + 1
                              End If
                              End If
                         End With
                     Next J
                End With
            Next I
       End With
 
       Set xlApp = CreateObject("Excel.Application")
       With xlApp
            .Visible = True
            Set FichierExcel = .Workbooks.Add
            With FichierExcel
                 With .sheets(1)
                      .Range(.Cells(1, 1), .Cells(1, 4)) = Array("Diapo", "Nom", "Caption", "Etat")
                      For IndexMatrice = LBound(MatriceCheckbox, 2) To UBound(MatriceCheckbox, 2)
                          .Cells(IndexMatrice + 2, 1) = MatriceCheckbox(0, IndexMatrice)
                          .Cells(IndexMatrice + 2, 2) = MatriceCheckbox(1, IndexMatrice)
                          .Cells(IndexMatrice + 2, 3) = MatriceCheckbox(2, IndexMatrice)
                          .Cells(IndexMatrice + 2, 4) = MatriceCheckbox(3, IndexMatrice)
                      Next IndexMatrice
                 End With
                 .SaveAs FileName:=Chemin & DateSauvegarde & ".xlsm", FileFormat:=52, CreateBackup:=False
                 .Close savechanges:=False
            End With
       End With
 
       GoTo Fin
 
Fin:
 
      xlApp.Quit
      Set xlApp = Nothing: Set FichierExcel = Nothing
      Set PptDoc = Nothing
 
End Sub
 
Function RecupererLaDate(ByVal Repertoire As String, ByVal Fichier As String) As Variant
 
Dim Fso As Object, Fich As Object
Dim GroupeHeure As Variant
 
     Set Fso = CreateObject("Scripting.FileSystemObject")
     For Each Fich In Fso.GetFolder(Repertoire).Files
         If Fich.Name = Fichier Then
            GroupeHeure = Split(Split(Fich.DateLastModified, " ")(1), ":")
            RecupererLaDate = Year(Fich.DateLastModified) & "-" & Format(Month(Fich.DateLastModified), "00") & "-" & Format(Day(Fich.DateLastModified), "00") & " " & Join(GroupeHeure, "-")
         End If
     Next Fich
     Set Fso = Nothing
 
End Function