Bonjour,
je reviens vers vous concernant un projet qui normalement était clos mais dont je viens de voir un dysfonctionnement
Dans l'entreprise où je bosse il y a 2 version d'excel : 2003 et 2007
J'ai crée 2 fichiers avec macro qui sont en lien, grace a excel 2007: Tableau d'enregistrement et formulaire mais enregistré en format .xls ( c'est important pour la suite!!!)
Le programme consiste a transferer des données du tableau vers le formulaire via macro dans le tableau et ensuite le formulaire est envoyé en PJ via une autre macro qui est dans le formulaire par mail via Lotus
Quand l'expediteur et le destinataire du mail sont en excel 2007 il y a pas de probleme tout fonctionne
Par contre si le destinataire est en 2003 lorsqu'il ouvre la PJ, le fichier est comme "codé" il est rempli de caractere au lieu d'avoir le formulaire.
Je precise bien que tous les fichiers sont en .xls
Donc je m'en remet a vous car là je seche totalement
Si besoin je mets ci dessous tous les codes par contre ne me demandez pas les fichiers les données sont confidentiel.
Merci par avance car je suis vraiment decouragé
Code dans le fichier "Tableau"
Code dans le fichier "Formulaire"
je reviens vers vous concernant un projet qui normalement était clos mais dont je viens de voir un dysfonctionnement
Dans l'entreprise où je bosse il y a 2 version d'excel : 2003 et 2007
J'ai crée 2 fichiers avec macro qui sont en lien, grace a excel 2007: Tableau d'enregistrement et formulaire mais enregistré en format .xls ( c'est important pour la suite!!!)
Le programme consiste a transferer des données du tableau vers le formulaire via macro dans le tableau et ensuite le formulaire est envoyé en PJ via une autre macro qui est dans le formulaire par mail via Lotus
Quand l'expediteur et le destinataire du mail sont en excel 2007 il y a pas de probleme tout fonctionne
Par contre si le destinataire est en 2003 lorsqu'il ouvre la PJ, le fichier est comme "codé" il est rempli de caractere au lieu d'avoir le formulaire.
Je precise bien que tous les fichiers sont en .xls
Donc je m'en remet a vous car là je seche totalement
Si besoin je mets ci dessous tous les codes par contre ne me demandez pas les fichiers les données sont confidentiel.
Merci par avance car je suis vraiment decouragé
Code dans le fichier "Tableau"
Code:
Private Sub TransfertFormulaire_Click()
Call Transfert
ThisWorkbook.Close SaveChanges:=True
End Sub
Code:
Sub Transfert()
Dim classeurSource As Workbook, classeurDestination As Workbook
Dim plg As Byte, x As Byte
Dim lig As Integer
Dim chemin As String
chemin = ThisWorkbook.Path & "\"
Set classeurSource = ThisWorkbook
lig = ActiveCell.Row
On Error Resume Next
x = Len(Workbooks("Formulaire-test.xls").Name)
If x = 0 Then
Set classeurDestination = Application.Workbooks.Open(chemin & "Formulaire-test.xls")
Else: Set classeurDestination = Workbooks("Formulaire-test.xls")
End If
On Error GoTo 0
With classeurDestination.Sheets("FOR0015")
plg = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("G7") = classeurSource.Sheets("Feuil1").Range("A" & lig)
.Range("C8") = classeurSource.Sheets("Feuil1").Range("B" & lig)
.Range("A21") = classeurSource.Sheets("Feuil1").Range("E" & lig)
.Range("B21") = classeurSource.Sheets("Feuil1").Range("D" & lig)
.Range("E21") = classeurSource.Sheets("Feuil1").Range("G" & lig)
.Range("F21") = classeurSource.Sheets("Feuil1").Range("F" & lig)
Select Case UCase(classeurSource.Sheets("Feuil1").Range("C" & lig))
Case Is = "LCQ": .Range("C10") = "X"
Case Is = "AQ": .Range("C12") = "X"
Case Is = "LRD": .Range("C14") = "X"
Case Is = "AR": .Range("C16") = "X"
Case Is = "BE": .Range("C18") = "X"
End Select
End With
End Sub
Code dans le fichier "Formulaire"
Code:
Private Sub EnvoyerMail_Click()
Dim extension As String
Dim chemin As String, nomfichier As String
extension = ".xls"
chemin = "C:\Documents and Settings\TECHNICI\Bureau\Fichier\"
nomfichier = ActiveSheet.Range("G7") & extension
bExist = (Dir(chemin & nomfichier) <> "")
If bExist = False Then
Call Send_Active_Sheet
Call Archiver
Else
Call Archiver
End If
End Sub
Code:
Option Explicit
Const EMBED_ATTACHMENT As Long = 1454
'Chemin d'enregistrement du fichier temporaire'
Const stPath As String = "C:\Documents and Settings\TECHNICI\Bureau"
'Message dans le mail'
Const vaMsg As Variant = "Bonjour," & vbCrLf & vbCrLf & vbCrLf & "Voici le formulaire" & vbCrLf & vbCrLf & "Cordialement"
Dim bExist As Boolean
'Rajoute mail en copie
Const vaCopyTo As Variant = "XX@XX.com"
Sub Send_Active_Sheet()
Dim stFileName As String
Dim vaRecipients As Variant
Dim noSession As Object
Dim noDatabase As Object
Dim noDocument As Object
Dim noEmbedObject As Object
Dim noAttachment As Object
Dim stAttachment As String
'Copie la feuille active dans un classeur temporaire'
With ActiveSheet
.Copy
stFileName = .Range("G7").Value
End With
stAttachment = stPath & "\" & stFileName & ".xls"
'Sauvegarde et ferme le classeur temporaire
Application.DisplayAlerts = False
With ActiveWorkbook
.SaveAs stAttachment
.Close
End With
Application.DisplayAlerts = True
'Création de la liste des destinataires
'Pour envoi a plusieurs personnes,mettre l'ensemble des mails entre parentheses separé par ,'
'Ex : ("toto@mail.com","tata@mail.com".....)'
vaRecipients = VBA.Array("XX@XX.fr")
'Preparation de Lotus Notes
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GetDatabase("", "")
'Ouverture de la fenetre d'identification de Lotus si pas ouvert.
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
'Creation du mail et de la piece jointe.
Set noDocument = noDatabase.CreateDocument
Set noAttachment = noDocument.CreateRichTextItem("stAttachment")
Set noEmbedObject = noAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
'Ajout de propriétés au mail crée.
With noDocument
.Form = "Memo"
.SendTo = vaRecipients
'.CopyTo = vaCopyTo
.Subject = stFileName
.Body = vaMsg
.SaveMessageOnSend = True
.PostedDate = Now()
.Send 0, vaRecipients
End With
'supprime le classeur temporaire.
Kill stAttachment
'Supprime objet de la memoire.
Set noEmbedObject = Nothing
Set noAttachment = Nothing
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
MsgBox "Email crée et envoyé avec succès", vbInformation
End Sub
Code:
Sub Archiver()
Dim extension As String
Dim chemin As String, nomfichier As String
Dim style As Integer, bOuvre As Boolean
Application.ScreenUpdating = False
ThisWorkbook.ActiveSheet.Copy
extension = ".xls"
'chemin d'enregistrement du fichier
chemin = "C:\Documents and Settings\TECHNICI\Bureau\Fichier\"
nomfichier = ActiveSheet.Range("G7") & extension
bExist = (Dir(chemin & nomfichier) <> "")
If bExist Then
bOuvre = (MsgBox(PROMPT:="un fichier de ce nom existe déjà, l'ouvrir ?", Buttons:=vbYesNo) = vbYes)
ActiveWorkbook.Close False
If bOuvre Then Workbooks.Open Filename:=chemin & nomfichier
Else
Application.DisplayAlerts = False
With ActiveWorkbook
.SaveAs Filename:=chemin & nomfichier
.Close
End With
Application.DisplayAlerts = True
End If
End Sub
Dernière édition: