Rompre les liaisons avant d'envoyer par Courriel

Le 04/11/2019 à 22:50

Bonjour,

Dans mon fichier Excel, j'ai un bouton pour envoyer par courriel l'onglet actif. Y a t'il un moyen

de rompre les liaisons avant de l'envoyer. Le but est que quand je vais recevoir la pièce jointe

qu'il n'y ait aucune liaison en l'ouvrant.

Je joins mon fichier exemple.

Merci

Jean.

8modification-v-2.xlsm (86.71 Ko)
Le 05/11/2019 à 00:13

Salut Jean,

juste après

ActiveSheet.Copy

ajoute cette ligne

ActiveWorkbook.BreakLink Name:=Sourcewb.FullName, Type:=xlExcelLinks
Le 05/11/2019 à 00:15

Bonjour,

pour moi ton fichier n'a aucune liaison...

eric

Le 05/11/2019 à 01:33

Bonsoir i20100,

J'ai copié le code, mais j'ai toujours le message des liaisons.

Je joins les photos de mon résultat.

Bonsoir eriiic,

Les liaisons apparaissent sur le fichier envoyer seulement.

Merci i20100 & eriiic

Jean.

1 2
Le 05/11/2019 à 02:42

re,

le message t'invite à activer la Mise automatique des liens, qu'arrive t'il si tu clic sur le bouton "Activer le contenu"

Le 05/11/2019 à 11:57

Bonjour i20100,

Quand je clic sur Activer le Contenu, le message disparait. Et quand je ré-ouvre le fichier, là j'ai le message de Mettre à Jour les liaisons.

Merci

Jean.

Le 06/11/2019 à 22:44

re,

malheureusement BreakLink ne brise pas toutes les liens,

par exemple:

  • plage nommée,
  • requête

quels sont les liens du fichier ?

Le 06/11/2019 à 22:49

Bonjour i20100,

Je pense que c'est un des icônes à gauche du fichier.

  • Effacer le Formulaire
  • Courriel
ou

-Imprimer.

Merci

Jean.

liens
Le 06/11/2019 à 23:24

re,

j'ai fais un test avec le fichier que tu as joint et les boutons ne crées pas de lien, il n'y a pas non plus de plage nommées

Le 07/11/2019 à 01:29

Bonsoir i20100,

J'ai fait le test avec le fichier que j'ai joins et il y a une liaison.

Je l'envoi par courriel, et je le sauvegarde sur mon bureau.

Ensuite je ferme tous les fichiers Excel et ré-ouvre seulement la sauvegarde.

C'est là que le fichier indique une liaison.

Voir photo.

Merci

Jean.

test courriel
Le 07/11/2019 à 02:00

Salut Jean,

tu as bien ajouté la ligne BreakLink juste après ActiveSheet.Copy

à tester,

Public Sub Send_Mail()
If MsgBox("*** PRÊT À ENVOYER LA DEMANDE PAR COURRIEL ***", vbYesNo) = vbNo Then Exit Sub
Dim Sourcewb As Workbook, Destwb As Workbook
Dim OutApp As Object, OutMail As Object
Dim TempFilePath As String, TempFileName As String
Dim strBody As String
Const FileExtStr As String = ".xlsx", FileFormatNum As Long = 51
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
ActiveSheet.Copy
ActiveWorkbook.BreakLink Name:=Sourcewb.FullName, Type:=xlExcelLinks '  <---------------------------------ici
Set Destwb = ActiveWorkbook
TempFilePath = Environ$("temp") & "\"
TempFileName = "Modification d'une Pièce SAP  " & Format(Now, "yyyy-mm-dd hh.mm.ss")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strBody = "<H2><B>*** MODIFICATION D'UNE PIÈCE SAP ***</B></H2><H3>" & _
Worksheets("Pièce_à_Modifier").Range("D3").Value & "<H3><B></B></H3>" & _
Worksheets("Pièce_à_Modifier").Range("D5").Value & "<H3><B></B></H3><H3><B></B></H3><H2><B>Merci !</B></H2>"
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "moekolisse@gmail.com"
.CC = ""
.BCC = ""
.Subject = "MODIFICATION D'UNE PIÈCE:   " & _
Worksheets("Pièce_à_Modifier").Range("C2").Value & _
Worksheets("Pièce_à_Modifier").Range("V1").Value & _
Worksheets("Pièce_à_Modifier").Range("D3").Value & _
Worksheets("Pièce_à_Modifier").Range("W1").Value & _
Worksheets("Pièce_à_Modifier").Range("D5").Value
.HTMLBody = strBody & "<br>" & .HTMLBody
.Attachments.Add Destwb.FullName
.display
End With
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
Application.EnableEvents = True
End Sub
Le 07/11/2019 à 12:22

Bonjour i20100,

Ça fonctionne toujours pas, même avec le code ajouté:

ActiveWorkbook.BreakLink Name:=Sourcewb.FullName, Type:=xlExcelLinks

Est-ce que le code peut se modifier pour l'envoyer en PDF à la place. Ça m'enlèverait

ce problème.

Sinon, je vais faire avec.

Un GROS MERCI pour ton aide soutenu.

Jean.

Le 07/11/2019 à 18:56

Bonjour Jean,

à tester,

Public Sub Send_Mail()
If MsgBox("*** PRÊT À ENVOYER LA DEMANDE PAR COURRIEL ***", vbYesNo) = vbNo Then Exit Sub
Dim Sourcewb As Workbook, Destwb As Workbook
Dim OutApp As Object, OutMail As Object
Dim TempFilePath As String, TempFileName As String
Dim strBody As String

'Const FileExtStr As String = ".xlsx", FileFormatNum As Long = 51

With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
End With

Set Sourcewb = ActiveWorkbook
Set Destwb = ActiveWorkbook
TempFilePath = Environ$("temp") & "\"
TempFileName = "Modification d'une Pièce SAP  " & Format(Now, "yyyy-mm-dd hh.mm.ss")

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=TempFilePath & TempFileName & ".pdf", Quality:= _
        xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strBody = "<H2><B>*** MODIFICATION D'UNE PIÈCE SAP ***</B></H2><H3>" & _
Worksheets("Pièce_à_Modifier").Range("D3").Value & "<H3><B></B></H3>" & _
Worksheets("Pièce_à_Modifier").Range("D5").Value & "<H3><B></B></H3><H3><B></B></H3><H2><B>Merci !</B></H2>"
With Destwb
'.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "moekolisse@gmail.com"
.CC = ""
.BCC = ""
.Subject = "MODIFICATION D'UNE PIÈCE:   " & _
Worksheets("Pièce_à_Modifier").Range("C2").Value & _
Worksheets("Pièce_à_Modifier").Range("V1").Value & _
Worksheets("Pièce_à_Modifier").Range("D3").Value & _
Worksheets("Pièce_à_Modifier").Range("W1").Value & _
Worksheets("Pièce_à_Modifier").Range("D5").Value
.HTMLBody = strBody & "<br>" & .HTMLBody

.Attachments.Add TempFilePath & TempFileName & ".pdf"

.display
End With
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
Application.EnableEvents = True
End Sub
Le 07/11/2019 à 22:17

Bonjour i20100,

Ça fonctionne très bien. Ça répond à mon besoin.

Il a fallu que je rajoute:

Dim FileExtStr as Variant

La macro bloquait à FileExtStr.

Un TRÈS GROS MERCI pour ton AIDE.

Jean

fileextstr
Rechercher des sujets similaires à "rompre liaisons envoyer courriel"