Agir sur un bouton dans EXCEL [Résolu]

Signaler
Messages postés
710
Date d'inscription
jeudi 20 février 2003
Statut
Membre
Dernière intervention
19 mai 2015
-
Messages postés
710
Date d'inscription
jeudi 20 février 2003
Statut
Membre
Dernière intervention
19 mai 2015
-
Bonjour,
j'ai créer un code pour exporter les données d'une listview vers EXCEL.
Sur une dés feuille j'ai mis un CommandButton1 avec un code.
Peut on au lancement de mon code VB6 agir sur l'évènement Click du CommandButton1
par contre je ne veut pas mettre le code du CommandButton1 dans Workbook_Open mais dans mon code VB6.

Sub exportexcelfacture()

 Call Connect

'**************Lance la procédure pour exporter la facture au format excel*************************************
On Error GoTo err
Dim i_Ligne As Long

Set XlApp = CreateObject("excel.application")

    '********Ouvrir le classeur excel **********
        With XlApp
        XlApp.Visible = True
        .Workbooks.Open App.Path & "\image\Facture.xls"
        
  '*************Feuille 1***************************************************************************************
        .Workbooks(1).Worksheets(1).Cells(7, 6) = Article_frm.lbl_ClientsEnCours.Caption
        .Workbooks(1).Worksheets(1).Cells(8, 6) = Article_frm.lbl_Adresse1ClientEnCours.Caption
        .Workbooks(1).Worksheets(1).Cells(10, 6) = Article_frm.lbl_Adresse2ClientEnCours.Caption
        .Workbooks(1).Worksheets(1).Label2.Caption = Article_frm.nom_fournisseur.Text
'****************Feuille 2*********************************************************************************************
        .Workbooks(1).Worksheets(2).Cells(7, 6) = Article_frm.lbl_ClientsEnCours.Caption
        .Workbooks(1).Worksheets(2).Cells(8, 6) = Article_frm.lbl_Adresse1ClientEnCours.Caption
        .Workbooks(1).Worksheets(2).Cells(10, 6) = Article_frm.lbl_Adresse2ClientEnCours.Caption
        .Workbooks(1).Worksheets(2).Label2.Caption = Article_frm.nom_fournisseur.Text
    Call Connect
        Sql = "SELECT * FROM Article_pose where num='" & Article_frm.num.Text & "'"
        Rs.Open Sql, Db, adOpenStatic, adLockPessimistic
        Rs.MoveLast
        Rs.MoveFirst
        
    For a = 0 To Rs.RecordCount
        .Workbooks(1).Worksheets(1).Cells(15 + a, 1) = UCase(Rs.Fields(3))
        .Workbooks(1).Worksheets(1).Cells(15 + a, 2) = UCase(Rs.Fields(7))
        .Workbooks(1).Worksheets(1).Cells(15 + a, 6) = UCase(Rs.Fields(4))
        .Workbooks(1).Worksheets(1).Cells(15 + a, 8) = UCase(Rs.Fields(8))
        .Workbooks(1).Worksheets(1).Cells(15 + a, 7) = UCase(Rs.Fields(5))
        .Workbooks(1).Worksheets(1).Cells(50, 7) = Article_frm.Label7.Caption '& " €"
        Rs.MoveNext
    Next a
 Call Deconnect
 
   Call Connect
Sql = "SELECT * FROM Article_mat where num='" & Article_frm.num.Text & "'"
        Rs.Open Sql, Db, adOpenStatic, adLockPessimistic
        Rs.MoveLast
    Rs.MoveFirst
    For a = 0 To Rs.RecordCount
        .Workbooks(1).Worksheets(2).Cells(15 + a, 1) = UCase(Rs.Fields(3))
        .Workbooks(1).Worksheets(2).Cells(15 + a, 2) = UCase(Rs.Fields(7))
        .Workbooks(1).Worksheets(2).Cells(15 + a, 6) = UCase(Rs.Fields(4))
        .Workbooks(1).Worksheets(2).Cells(15 + a, 8) = UCase(Rs.Fields(8))
        .Workbooks(1).Worksheets(2).Cells(15 + a, 7) = UCase(Rs.Fields(5))
        .Workbooks(1).Worksheets(2).Cells(50, 7) = Article_frm.Label4.Caption
        Rs.MoveNext
    Next a
       Call Deconnect
        
End With
Set appExcel = Nothing

err:
If err.Number = 3021 Then
If Rs.RecordCount = 0 Then Exit Sub
Resume Next
End If

If err.Number = 1004 Then
XlApp.Quit
Set XlApp = Nothing
MsgBox "Exportation annulée", vbCritical + vbOKOnly, "NTP"
Exit Sub
End If
Resume Next
End Sub


merci
@ plus

3 réponses

Messages postés
30361
Date d'inscription
mercredi 22 octobre 2003
Statut
Modérateur
Dernière intervention
28 novembre 2020
338
Bonjour,
Plutot que de simuler le click sur ton bouton... lances directement la macro.
Il faut pour cela, utiliser Run.

exemple:

Private Sub cdLancerMacro_Click()
  Dim XlApp As Excel.Application
  Dim oWk As Workbook
  Set XlApp= CreateObject("Excel.Application")
  XlApp.Visible = True
  Set oWk = XlApp.Workbooks.Open( App.Path & "\image\Facture.xls")
  On Error GoTo 0
  If oWk Is Nothing Then
    MsgBox "Erreur sur ouverture classeur", vbCritical
    Exit Sub
  End If
 
  XlApp.Run "MaMacro" ' lance la macro
 
  Set oWk = Nothing
  Set XlApp= Nothing 'libération mémoire..
End Sub



Messages postés
710
Date d'inscription
jeudi 20 février 2003
Statut
Membre
Dernière intervention
19 mai 2015
3
bonjour,
merci Jordane pour ta réponse,mais je doit mettre ma macro ou ,car j'ai essayer mais ça ne fonctionne pas.
voila la macro
XlApp.Run "ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True,IgnorePrintAreas:=False" 

voila mon code pour exporter verx EXCEL
Sub exportexcelfacture()

 Call Connect

'**************Lance la procédure pour exporter la facture au format excel*************************************
On Error GoTo err
Dim i_Ligne As Long

Set XlApp = CreateObject("excel.application")

    '********Ouvrir le classeur excel **********
        With XlApp
        XlApp.Visible = True
        .Workbooks.Open App.Path & "\image\Facture.xls"
       
  '*************Feuille 1***************************************************************************************
        .Workbooks(1).Worksheets(1).Cells(7, 6) = Article_frm.lbl_ClientsEnCours.Caption
        .Workbooks(1).Worksheets(1).Cells(8, 6) = Article_frm.lbl_Adresse1ClientEnCours.Caption
        .Workbooks(1).Worksheets(1).Cells(10, 6) = Article_frm.lbl_Adresse2ClientEnCours.Caption
        .Workbooks(1).Worksheets(1).Label2.Caption = Article_frm.nom_fournisseur.Text
'****************Feuille 2*********************************************************************************************
        .Workbooks(1).Worksheets(2).Cells(7, 6) = Article_frm.lbl_ClientsEnCours.Caption
        .Workbooks(1).Worksheets(2).Cells(8, 6) = Article_frm.lbl_Adresse1ClientEnCours.Caption
        .Workbooks(1).Worksheets(2).Cells(10, 6) = Article_frm.lbl_Adresse2ClientEnCours.Caption
        .Workbooks(1).Worksheets(2).Label2.Caption = Article_frm.nom_fournisseur.Text
    Call Connect
        Sql = "SELECT * FROM Article_pose where num='" & Article_frm.num.Text & "'"
        Rs.Open Sql, Db, adOpenStatic, adLockPessimistic
        Rs.MoveLast
        Rs.MoveFirst
        
    For a = 0 To Rs.RecordCount
        .Workbooks(1).Worksheets(1).Cells(15 + a, 1) = UCase(Rs.Fields(3))
        .Workbooks(1).Worksheets(1).Cells(15 + a, 2) = UCase(Rs.Fields(7))
        .Workbooks(1).Worksheets(1).Cells(15 + a, 6) = UCase(Rs.Fields(4))
        .Workbooks(1).Worksheets(1).Cells(15 + a, 8) = UCase(Rs.Fields(8))
        .Workbooks(1).Worksheets(1).Cells(15 + a, 7) = UCase(Rs.Fields(5))
        .Workbooks(1).Worksheets(1).Cells(50, 7) = Article_frm.Label7.Caption '& " €"
        Rs.MoveNext
    Next a
 Call Deconnect
 
   Call Connect
Sql = "SELECT * FROM Article_mat where num='" & Article_frm.num.Text & "'"
        Rs.Open Sql, Db, adOpenStatic, adLockPessimistic
        Rs.MoveLast
    Rs.MoveFirst
    For a = 0 To Rs.RecordCount
        .Workbooks(1).Worksheets(2).Cells(15 + a, 1) = UCase(Rs.Fields(3))
        .Workbooks(1).Worksheets(2).Cells(15 + a, 2) = UCase(Rs.Fields(7))
        .Workbooks(1).Worksheets(2).Cells(15 + a, 6) = UCase(Rs.Fields(4))
        .Workbooks(1).Worksheets(2).Cells(15 + a, 8) = UCase(Rs.Fields(8))
        .Workbooks(1).Worksheets(2).Cells(15 + a, 7) = UCase(Rs.Fields(5))
        .Workbooks(1).Worksheets(2).Cells(50, 7) = Article_frm.Label4.Caption
        Rs.MoveNext
    Next a
       Call Deconnect
         
End With


        
Set appExcel = Nothing

err:
If err.Number = 3021 Then
If Rs.RecordCount = 0 Then Exit Sub
Resume Next
End If

If err.Number = 1004 Then
XlApp.Quit
Set XlApp = Nothing
MsgBox "Exportation annulée", vbCritical + vbOKOnly, "NTP"
Exit Sub
End If
Resume Next
End Sub


merci
bonne journée
Messages postés
710
Date d'inscription
jeudi 20 février 2003
Statut
Membre
Dernière intervention
19 mai 2015
3
oupssss, autant pour moi ,ça fonctionne très bien.
en fait au lieu de mettre la macro j'avais mis le code

merci Jordane