VB6 & Excel

[Résolu]
Signaler
Messages postés
4
Date d'inscription
vendredi 7 mai 2004
Statut
Membre
Dernière intervention
7 octobre 2004
-
Messages postés
4
Date d'inscription
vendredi 7 mai 2004
Statut
Membre
Dernière intervention
7 octobre 2004
-
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

3 réponses

Messages postés
4
Date d'inscription
vendredi 7 mai 2004
Statut
Membre
Dernière intervention
7 octobre 2004

Lanpog

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

Quelques mots de remerciements seront grandement appréciés. Ajouter un commentaire

Codes Sources 112 internautes nous ont dit merci ce mois-ci

Messages postés
437
Date d'inscription
mercredi 18 décembre 2002
Statut
Membre
Dernière intervention
10 août 2010
2
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.
Messages postés
4
Date d'inscription
vendredi 7 mai 2004
Statut
Membre
Dernière intervention
7 octobre 2004

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