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
| If Not Mode_debug Then On Error GoTo err:
Dim objApp As Object, objBook As Object, objSheet As Object
Dim qdf As DAO.QueryDef
Dim rst As DAO.Recordset
Dim i As Integer, indice As String
DoCmd.Hourglass True
i = 0
indice = "" 'indice de page (15 lignes par page)
Set qdf = CurrentDb.QueryDefs("imp_F1")
qdf.Parameters("cd") = cd
Set rst = qdf.OpenRecordset
Set objApp = CreateObject("excel.application")
Set objBook = objApp.Workbooks.Open(Client_path & "planet_form1.xls", ReadOnly:=True)
Set objSheet = objBook.Worksheets("Form1")
objApp.Visible = Mode_admin 'si on veut visualiser
With objSheet
.Activate
While Not rst.EOF
i = i + 1
If i = 16 Then 'saut de page
If Not Mode_admin Then .PrintOut Copies:=1, Collate:=True
If indice = "" Then indice = "A" Else indice = Chr(Asc(indice) + 1)
i = 1
End If
If i = 1 Then 'entete et pied de page
.Range("repere").Value = cd & indice
.Range("contrat").Value = rst!contrat
.Range("rmq").Value = rst!Remarques
.Range("sgn").Value = rst!signataire
.Range("jour").Value = rst!date_cre
End If
.Range("adm").Offset(i - 1, 0).Value = rst!adm
.Range("statut").Offset(i - 1, 0).Value = rst!STATUT
.Range("description").Offset(i - 1, 0).Value = rst!libelle
.Range("item").Offset(i - 1, 0).Value = i
.Range("article").Offset(i - 1, 0).Value = rst!ref
.Range("qte").Offset(i - 1, 0).Value = rst!Qte
.Range("lot").Offset(i - 1, 0).Value = rst!lot1
rst.MoveNext
Wend
rst.Close: Set rst = Nothing
If indice > "" Then
While i < 15
i = i + 1
.Range("adm").Offset(i - 1, 0).Value = ""
.Range("statut").Offset(i - 1, 0).Value = ""
.Range("description").Offset(i - 1, 0).Value = ""
.Range("item").Offset(i - 1, 0).Value = ""
.Range("article").Offset(i - 1, 0).Value = ""
.Range("qte").Offset(i - 1, 0).Value = ""
.Range("lot").Offset(i - 1, 0).Value = ""
Wend
End If
End With
'ferme excel & libère
If Not Mode_admin Then
objSheet.PrintOut Copies:=1, Collate:=True
objBook.Close SaveChanges:=False
objApp.Quit
End If
Set objSheet = Nothing
Set objBook = Nothing
Set objApp = Nothing
DoCmd.Hourglass False
Exit Sub
err: msgbox "Erreur " & err.Number & " dans etats.imp_Form1 : " & err.DESCRIPTION
End Sub |
Partager