VB6 & ExcelRésolu

Question

A partir de vb, je dois charger des infos dans plusieurs classeurs excel que je dois laisser ouverts ( fermeture par l'utilisateur)

Si excel n'etait pas en marche, pas de probleme

S'il etait en en route, J'obtiens un code erreur d'ouverture (Err.number) à 0, en bricolant j'arrive a m'en sortir pour la premiere feuille, par contre des la deuxieme, des que j'attaque des changements de couleurs, soit je me plante, soit les fonctions ne s'executent pas.
Merci d'avance

lanpog · Accepted Answer

Lanpog

Merci à tous, j'ai réglé mon problème

cs_PhilippeE · Answer

Tu pourrais mettre le début de ton code s'il te plait ?
Normalement, tu devrais ouvrir Excel et si ce n'est pas possible en créer une instance.

Regardes les exemples sur le site de Microsoft pour les fonction GetObject et CreateObject. Tu as un exemple avec Word il me semble.

lanpog · Answer

Sub GetExcel() Dim myxl As excel.Application Dim mybook As excel.Workbook vnbpassage = vnbpassage + 1 vfichier = "\Planning de " & cmbmois & " " & txtannee & " " & Left(Time, 2) & Mid(Time, 4, 2) & ".xls" FileCopy chemin, App.Path & vfichier On Error Resume Next 'ignore errors Set myxl = GetObject(, "Excel.Application") 'rechercher une copie d'Excel en cours MsgBox (Err.Number) '''''''' si err.number=429 (pas d'excel ouvert), pas de probleme, toutes les feuilles fonctionnent If Err.Number <> 0 Then Set myxl = CreateObject("Excel.Application") 'le lancer Else If vnbpassage = 1 Then '''''''' vnbpassage pour controler le premier passage avec err.number=0, dans ce cas la premiere feuille fonctionne '''''''' mais si je relance le programme, je plante a partir des selections de couleur et de justification Set myxl = CreateObject("Excel.Application") 'le lancer End If End If Err.Clear ' Effacer l'objet Err en cas d'erreur. On Error GoTo 0 'Reprendre le traitement d'erreur normal Set mybook = myxl.Workbooks.Open(App.Path & vfichier) myxl.Application.Visible = True myxl.Parent.Windows(1).Visible = True myxl.Range("E2").Select myxl.ActiveCell.FormulaR1C1 = cmbmois myxl.Range("U2").Select myxl.ActiveCell.FormulaR1C1 = txtannee Select Case cmbmois Case "Janvier" vmois = "01" Case "Février" vmois = "02" Case "Mars" vmois = "03" Case "Avril" vmois = "04" Case "Mai" vmois = "05" Case "Juin" vmois = "06" Case "Juillet" vmois = "07" Case "Août" vmois = "08" Case "Septembre" vmois = "09" Case "Octobre" vmois = "10" Case "Novembre" vmois = "11" Case "Décembre" vmois = "12" End Select vdatedebut = "01/" & vmois & "/" & txtannee If vmois = "12" Then vmoisfin = "01" vanneefin = Val(txtannee) + 1 Else vmoisfin = Val(vmois) + 1 vanneefin = txtannee End If vnbj = DateDiff("d", vdatedebut, "01/" & vmoisfin & "/" & vanneefin) vdatefin = vnbj & "/" & vmois & "/" & txtannee vindex = 7 vancienvilla = "" sqlfiche1 = "Select * from Reservations where du < " & ConvDateMJA(vdatefin) sqlfiche1 = sqlfiche1 & " And au > " & ConvDateMJA(vdatedebut) sqlfiche1 = sqlfiche1 & " order by cvilla" rstfiche1.Open sqlfiche1, cnn While Not rstfiche1.EOF If UCase(vancienvilla) <> UCase(rstfiche1("cvilla")) Then vindex = vindex + 1 End If vancienvilla = rstfiche1("cvilla") myxl.Cells(vindex, 3).Value = rstfiche1("cvilla") sqlfiche2 = "Select code,nom from Villas where code='" & rstfiche1("cvilla") & "'" rstfiche2.Open sqlfiche2, cnn If Not rstfiche2.EOF Then myxl.Cells(vindex, 4).Value = rstfiche2("nom") End If rstfiche2.Close vtest = Left(rstfiche1("du"), 5) vtest = Right(vtest, 2) If vtest vmois And Right(rstfiche1("du"), 4) txtannee Then Vdb = Val(Left(rstfiche1("du"), 2)) vcased = 5 Else Vdb = 1 vcased = 4 End If vtest = Left(rstfiche1("au"), 5) vtest = Right(vtest, 2) If vtest vmois And Right(rstfiche1("au"), 4) txtannee Then vfb = Val(Left(rstfiche1("au"), 2)) vcasef = 4 Else vfb = vnbj vcasef = 5 End If myxl.Range(myxl.Cells(vindex, Vdb + (Vdb - 1) + vcased), myxl.Cells(vindex, vfb + (vfb - 1) + vcasef)).Select Call testcouleur '''''' Plantage a partir d'ici dans le cas d'un deuxieme passage avec une erreur.number=0 a l'origine With Selection.Interior .ColorIndex = vcoul .Pattern = xlSolid .PatternColorIndex = xlAutomatic End With ' Affichage de delimitateur de debut With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThick .ColorIndex = xlAutomatic End With ' Affichage de delimitateur de fin With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThick .ColorIndex = xlAutomatic End With 'fusion des cellules et nom du client centré With Selection .HorizontalAlignment = xlGeneral .VerticalAlignment = xlBottom .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = True End With With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = True End With sqlfiche2 = "Select code,nom from Clients where code='" & rstfiche1("CClient") & "'" rstfiche2.Open sqlfiche2, cnn If Not rstfiche2.EOF Then myxl.ActiveCell.FormulaR1C1 = rstfiche2("nom") & " ->" & rstfiche1("Typeprovenance") End If rstfiche2.Close rstfiche1.MoveNext Wend rstfiche1.Close myxl.Cells(1, 1).Select 'MsgBox ("Le fichier " & App.Path & vfichier & " a été généré") Workbooks(1).Worksheets("feuil1").Activate 'If ExcelWasNotRunning = True Then 'ActiveWorkbook.Save 'ActiveWorkbook.Close 'myxl.Application.Quit 'End If Set myxl = Nothing ' Libère la référence à l'application End Sub

VB6 & Excel

3 réponses

Discussions similaires