Sujet Précédent Sujet Suivant

Agir sur un bouton dans EXCEL

Résolu
cs_petchy Messages postés 710 Date d'inscription jeudi 20 février 2003 Statut Membre Dernière intervention 19 mai 2015 - 26 mars 2014 à 09:31
cs_petchy Messages postés 710 Date d'inscription jeudi 20 février 2003 Statut Membre Dernière intervention 19 mai 2015 - 27 mars 2014 à 09:26
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

Réponse 1 / 3
jordane45 Messages postés 37504 Date d'inscription mercredi 22 octobre 2003 Statut Modérateur Dernière intervention 28 mai 2023 341
26 mars 2014 à 13:02
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

0
Réponse 2 / 3
cs_petchy Messages postés 710 Date d'inscription jeudi 20 février 2003 Statut Membre Dernière intervention 19 mai 2015 3
27 mars 2014 à 08:00
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
0
Réponse 3 / 3
cs_petchy Messages postés 710 Date d'inscription jeudi 20 février 2003 Statut Membre Dernière intervention 19 mai 2015 3
27 mars 2014 à 09:26
oupssss, autant pour moi ,ça fonctionne très bien.
en fait au lieu de mettre la macro j'avais mis le code

merci Jordane
0
Rejoignez-nous