Aggiungere nell oggetto della mail il nome del foglio

Question

Aggiungere nell oggetto della mail il nome del foglio

Anonimo

Buongiorno a tutti

ho trovato su questo forum una conversazione che fa proprio al caso mio.

Volevo chiedere se era possibile fare peró una piccola modifica al codice VBA.

Quello che mi servirebbe e´ di aggiungere all´"Oggetto" della mail il nome del foglio dal quale si manda.

Lárgomento in questione era stato creato da "daniloamd" con titolo "Invio selezione per email" il 18 maggio 2018

Grazie intanto a presto

Ivan

Domanda bloccata. Questa domanda è stata eseguita dalla community del supporto tecnico Microsoft. È possibile votare se è utile, ma non è possibile aggiungere commenti o risposte o seguire la domanda.

0 commenti

5 risposte


			  
					
						
		 
		
			
			
				
					
					
					
						
		
	
					
			  
					
			
				
							
								Anonimo
							
					  
				
				
			
		
			  
				
			
			
						 2022-05-09T17:27:28+00:00 
				  
		
		
	
		Ciao Norman...purtroppo oggi la macro non mi funziona piú.
settimana scorsa ho fatto delle modifiche e non so dove ho sbagliato.
al momento la macro mi crea solo il documento nuovo ma non mi apre l´outlook per inviare la mail.
potresti cortesemente dare una occhiata?
e un´altra cosa: sinceramente quella parte che "parla" della password non l´ho capita..... come dovrebbe funzionare; a me non ha mai chiesto nulla
e anche la parte segnata in verde non sono mai riuscito a farla andare.
Grazie Ivan
'=========>> 
Option Explicit 
'--------->> 
Public Sub AvvisoRundlauf() 
Dim srcWB As Workbook 

Dim destWB As Workbook 

Dim srcSH As Worksheet 

Dim Rng As Range, srcRng As Range 

Dim sFilename As String 

Dim sExt As String 

Dim oOutlook As Object 

Dim oMail As Object 

Dim bProtected As Boolean 

Const sPassword As String = "Ivan" 

Const sNomeFileAllegato As String = "TPM" 

Const sEmail As String = \_ 

          "Luca.Oliva@xxxx\*\*\*\*" 

Const sCc As String = \_ 

          "Thomas.Fischer@xxxx\*\*\*\*" 

Const sOggetto As String \_ 

            = "Controllo Spindel Rundlauf" 

Const sCorpo As String \_ 

            = "Prego controllare il Rundlauf del mandrino" 

Set srcWB = ThisWorkbook 

Set srcSH = ActiveSheet 

Set Rng = Selection 

With srcSH 

    bProtected = srcSH.ProtectContents = True 

    If bProtected Then 

        .Unprotect Password:=sPassword 

    End If 

End With 

On Error Resume Next 

Set srcRng = Rng.SpecialCells(xlCellTypeVisible) 

On Error GoTo 0 

If srcRng Is Nothing Then 

    Call MsgBox( \_ 

         Prompt:="La selezione non è un intervallo!" \_ 

                 & vbNewLine & vbNewLine \_ 

                 & "Seleziona l'intervallo di interesse e ripova", \_ 

         Buttons:=vbCritical, \_ 

         Title:="REPORT") 

    Exit Sub 

End If 

On Error GoTo XIT 

With Application 

    .ScreenUpdating = False 

    .EnableEvents = False 

End With 

Set destWB = Workbooks.Add(xlWBATWorksheet) 

srcRng.Copy 

With destWB.Sheets(1) 

    .Cells(1).PasteSpecial Paste:=8  '\\ xlPasteColumnWidths 

    .Cells(1).PasteSpecial Paste:=xlPasteValues 

    .Cells(1).PasteSpecial Paste:=xlPasteFormats 

    .Cells(1).Select 

    Application.CutCopyMode = False 

End With 

Set oOutlook = CreateObject("Outlook.Application") 

Set oMail = oOutlook.CreateItem(0) 

sFilename = sNomeFileAllegato & "\_" \_ 

            & Format(Now, "dd-mmm-yy hh-mm-ss") 

sExt = ".xlsx" 

With destWB 

    .SaveAs Filename:=sFilename & sExt, \_ 

            FileFormat:=51 

    On Error Resume Next 

    With oMail 

        .to = sEmail 

        .CC = sCc 

        .BCC = "" 

        .Subject = sOggetto & " " & srcSH.Name 

        .Body = sCorpo 

        .Attachments.Add destWB.FullName 

        .Display    '.Send 

    End With 

    On Error GoTo 0 

    .Close savechanges:=False 

End With 

Kill sFilename & sExt 

XIT: 
Set oMail = Nothing 

Set oOutlook = Nothing 

With Application 

    .EnableEvents = True 

    .ScreenUpdating = True 

End With 

End Sub 
'<<=========

		
			 
		
			
				
					
		
			
			
				
							
								
		
			La risposta è stata utile?
	
								
									
		
	
									
		
	
								
							
					  
				
					
				
			
		
	
				
			
			
		
		
	
			
		
			
				
					
						
					
					0 commenti
					Nessun commento
				
		  
			
		
		
		
	
		
		
	
		
		
		
			
				
					
		
			
		
	
				
				
			
		
	
		
	
		
	
					
			  
					
						
		 
		
			
			
				
					
					
					
						
		
	
					
			  
					
			
				
							
								Anonimo
							
					  
				
				
			
		
			  
				
			
			
						 2022-04-28T16:31:37+00:00 
				  
		
		
	
		Ciao Ivan,

Favoloso grazie mille.
Funziona perfettamente.

Ti ringrazio per il cortese riscontro.
Per chiudere questo thread ti chiederei gentilmente di contrassegnare la mia risposta precedente  come Risposta.  
===
Regards,
Norman


		
			 
		
			
				
					
		
			
			
				
							
								
		
			La risposta è stata utile?
	
								
									
		
	
									
		
	
								
							
					  
				
					
				
			
		
	
				
			
			
		
		
	
			
		
			
				
					
						
					
					0 commenti
					Nessun commento
				
		  
			
		
		
		
	
		
		
	
		
		
		
			
				
					
		
			
		
	
				
				
			
		
	
		
	
		
	
					
			  
					
						
		 
		
			
			
				
					
					
					
						
		
	
					
			  
					
			
				
							
								Anonimo
							
					  
				
				
			
		
			  
				
			
			
						 2022-04-28T16:25:06+00:00 
				  
		
		
	
		Favoloso grazie mille.
Funziona perfettamente.
Ciao alla prossima
Ivan

		
			 
		
			
				
					
		
			
			
				
							
								
		
			La risposta è stata utile?
	
								
									
		
	
									
		
	
								
							
					  
				
					
				
			
		
	
				
			
			
		
		
	
			
		
			
				
					
						
					
					0 commenti
					Nessun commento
				
		  
			
		
		
		
	
		
		
	
		
		
		
			
				
					
		
			
		
	
				
				
			
		
	
		
	
		
	
					
			  
					
						
		 
		
			
			
				
					
					
					
						
		
	
					
			  
					
			
				
							
								Anonimo
							
					  
				
				
			
		
			  
				
			
			
						 2022-04-28T16:17:45+00:00 
				  
		
		
	
		Ciao Ivan,

ho trovato su questo forum una conversazione che fa proprio al caso mio.
Volevo chiedere se era possibile fare peró una piccola modifica al codice VBA.
Quello che mi servirebbe e´ di aggiungere all´"Oggetto" della mail il nome del foglio dal quale si manda.
Lárgomento in questione era stato creato da "daniloamd" con titolo "Invio selezione per email" il 18 maggio 2018

Prova qualcosa del genere:
'=========>> 
Option Explicit 
'--------->> 
Public Sub Tester() 
Dim srcWB As Workbook 

Dim destWB As Workbook 

Dim srcSH As Worksheet 

Dim Rng As Range, srcRng As Range 

Dim sFilename As String 

Dim sExt As String 

Dim oOutlook As Object 

Dim oMail As Object 

Dim bProtected As Boolean 

Const sPassword As String = "Pippo"                  '&lt;&lt;=== Modifica 

Const sNomeFileAllegato As String = "MioFile"        '&lt;&lt;=== Modifica 

Const sEmail As String = \_ 

          "pippo CHIOCCIOLA gmail.com"               '&lt;&lt;=== Modifica 

Const sOggetto As String \_ 

                        = "Il tuo oggetto qui ..."   '&lt;&lt;===Modifica 

Const sCorpo As String \_ 

   = "Questi sono i dati da considerare ..."         '&lt;&lt;===Modifica 

Set srcWB = ThisWorkbook 

Set srcSH = ActiveSheet 

Set Rng = Selection 

With srcSH 

    bProtected = srcSH.ProtectContents = True 

    If bProtected Then 

        .Unprotect Password:=sPassword 

    End If 

End With 

On Error Resume Next 

Set srcRng = Rng.SpecialCells(xlCellTypeVisible) 

On Error GoTo 0 

If srcRng Is Nothing Then 

    Call MsgBox( \_ 

         Prompt:="La selezione non è un intervallo!" \_ 

                 & vbNewLine & vbNewLine \_ 

                 & "Seleziona l'intervallo di interesse e ripova", \_ 

         Buttons:=vbCritical, \_ 

         Title:="REPORT") 

    Exit Sub 

End If 

On Error GoTo XIT 

With Application 

    .ScreenUpdating = False 

    .EnableEvents = False 

End With 

Set destWB = Workbooks.Add(xlWBATWorksheet) 

srcRng.Copy 

With destWB.Sheets(1) 

    .Cells(1).PasteSpecial Paste:=8  '\\ xlPasteColumnWidths 

    .Cells(1).PasteSpecial Paste:=xlPasteValues 

    .Cells(1).PasteSpecial Paste:=xlPasteFormats 

    .Cells(1).Select 

    Application.CutCopyMode = False 

End With 

Set oOutlook = CreateObject("Outlook.Application") 

Set oMail = oOutlook.CreateItem(0) 

sFilename = sNomeFileAllegato & "\_" \_ 

            & Format(Now, "dd-mmm-yy hh-mm-ss") 

sExt = ".xlsx" 

With destWB 

    .SaveAs Filename:=sFilename & sExt, \_ 

            FileFormat:=51 

    On Error Resume Next 

    With oMail 

        .to = sEmail 

        .CC = "" 

        .BCC = "" 

        .Subject = sOggetto & **" " & srcSH.Name** 

        .Body = sCorpo 

        .Attachments.Add destWB.FullName 

        .Display    '.Send 

    End With 

    On Error GoTo 0 

    .Close savechanges:=False 

End With 

Kill sFilename & sExt 

XIT: 
Set oMail = Nothing 

Set oOutlook = Nothing 

With Application 

    .EnableEvents = True 

    .ScreenUpdating = True 

End With 

End Sub 
'<<=========
===
Regards,
Norman


		
			 
		
			
				
					
		
			
			
				
							
								
		
			La risposta è stata utile?
	
								
									
		
	
									
		
	
								
							
					  
				
					
				
			
		
	
				
			
			
		
		
	
			
		
			
				
					
						
					
					0 commenti
					Nessun commento


				  
		
			
				
		it-it
	 
		
		
		
	
			Scelte sulla privacy
	
	
				
		
			
			
				
					
						
					
					
						
					
					
						
					
				
			
		
	
			
			
				
				
		
		Dichiarazione di non responsabilità relativa all'intelligenza artificiale
	
	

		
		Versioni precedenti
	
	
 
		
		Blog
	
	
 
		
		Collabora
	
	

		
		Privacy
	
	

		
		Privacy dei dati sanitari dei consumatori
	
	

		
		Condizioni per l'utilizzo
	
	

		
		Codice di comportamento
	
	

		
		Accessibilità
	
	

		
		Marchi
	
	
				© Microsoft 2026

Answer 1

Ciao Ivan,

Ciao Norman...purtroppo oggi la macro non mi funziona piú.

settimana scorsa ho fatto delle modifiche e non so dove ho sbagliato.

al momento la macro mi crea solo il documento nuovo ma non mi apre l´outlook per inviare la mail.

potresti cortesemente dare una occhiata?

Ho sostituito il mio codice con la tua versione rivista e questa versione funziona per me senza problemi, creando la seguente email che è pronta per l'invio:

  [![](https://learn-attachment.microsoft.com/api/attachments/fc66e7bc-5ccc-40d5-8561-611ea2d27912?platform=QnA"https://learn-attachment.microsoft.com/api/attachments/50510cce-38d1-4af6-92c9-1d96623569ff?platform=QnA" rel="ugc nofollow">

Answer 2

Ciao Norman...purtroppo oggi la macro non mi funziona piú.

settimana scorsa ho fatto delle modifiche e non so dove ho sbagliato.

al momento la macro mi crea solo il documento nuovo ma non mi apre l´outlook per inviare la mail.

potresti cortesemente dare una occhiata?

e un´altra cosa: sinceramente quella parte che "parla" della password non l´ho capita..... come dovrebbe funzionare; a me non ha mai chiesto nulla

e anche la parte segnata in verde non sono mai riuscito a farla andare.

Grazie Ivan

'=========>>

Option Explicit

'--------->>

Public Sub AvvisoRundlauf()

Dim srcWB As Workbook 

Dim destWB As Workbook 

Dim srcSH As Worksheet 

Dim Rng As Range, srcRng As Range 

Dim sFilename As String 

Dim sExt As String 

Dim oOutlook As Object 

Dim oMail As Object 

Dim bProtected As Boolean 

Const sPassword As String = "Ivan" 

Const sNomeFileAllegato As String = "TPM" 

Const sEmail As String = \_ 

          "Luca.Oliva@xxxx\*\*\*\*" 

Const sCc As String = \_ 

          "Thomas.Fischer@xxxx\*\*\*\*" 

Const sOggetto As String \_ 

            = "Controllo Spindel Rundlauf" 

Const sCorpo As String \_ 

            = "Prego controllare il Rundlauf del mandrino" 

Set srcWB = ThisWorkbook 

Set srcSH = ActiveSheet 

Set Rng = Selection 

With srcSH 

    bProtected = srcSH.ProtectContents = True 

    If bProtected Then 

        .Unprotect Password:=sPassword 

    End If 

End With 

On Error Resume Next 

Set srcRng = Rng.SpecialCells(xlCellTypeVisible) 

On Error GoTo 0 

If srcRng Is Nothing Then 

    Call MsgBox( \_ 

         Prompt:="La selezione non è un intervallo!" \_ 

                 & vbNewLine & vbNewLine \_ 

                 & "Seleziona l'intervallo di interesse e ripova", \_ 

         Buttons:=vbCritical, \_ 

         Title:="REPORT") 

    Exit Sub 

End If 

On Error GoTo XIT 

With Application 

    .ScreenUpdating = False 

    .EnableEvents = False 

End With 

Set destWB = Workbooks.Add(xlWBATWorksheet) 

srcRng.Copy 

With destWB.Sheets(1) 

    .Cells(1).PasteSpecial Paste:=8  '\\ xlPasteColumnWidths 

    .Cells(1).PasteSpecial Paste:=xlPasteValues 

    .Cells(1).PasteSpecial Paste:=xlPasteFormats 

    .Cells(1).Select 

    Application.CutCopyMode = False 

End With 

Set oOutlook = CreateObject("Outlook.Application") 

Set oMail = oOutlook.CreateItem(0) 

sFilename = sNomeFileAllegato & "\_" \_ 

            & Format(Now, "dd-mmm-yy hh-mm-ss") 

sExt = ".xlsx" 

With destWB 

    .SaveAs Filename:=sFilename & sExt, \_ 

            FileFormat:=51 

    On Error Resume Next 

    With oMail 

        .to = sEmail 

        .CC = sCc 

        .BCC = "" 

        .Subject = sOggetto & " " & srcSH.Name 

        .Body = sCorpo 

        .Attachments.Add destWB.FullName 

        .Display    '.Send 

    End With 

    On Error GoTo 0 

    .Close savechanges:=False 

End With 

Kill sFilename & sExt

XIT:

Set oMail = Nothing 

Set oOutlook = Nothing 

With Application 

    .EnableEvents = True 

    .ScreenUpdating = True 

End With

End Sub

'<<=========

Answer 3

Anonimo

Ciao Ivan,

Favoloso grazie mille.

Funziona perfettamente.

Ti ringrazio per il cortese riscontro.

Per chiudere questo thread ti chiederei gentilmente di contrassegnare la mia risposta precedente come Risposta.

===

Regards,

Norman

0 commenti

Answer 4

Anonimo

Favoloso grazie mille.

Funziona perfettamente.

Ciao alla prossima

Ivan

0 commenti

Answer 5

Ciao Ivan,

ho trovato su questo forum una conversazione che fa proprio al caso mio.

Volevo chiedere se era possibile fare peró una piccola modifica al codice VBA.

Quello che mi servirebbe e´ di aggiungere all´"Oggetto" della mail il nome del foglio dal quale si manda.

Lárgomento in questione era stato creato da "daniloamd" con titolo "Invio selezione per email" il 18 maggio 2018

Prova qualcosa del genere:

'=========>>

Option Explicit

'--------->>

Public Sub Tester()

Dim srcWB As Workbook 

Dim destWB As Workbook 

Dim srcSH As Worksheet 

Dim Rng As Range, srcRng As Range 

Dim sFilename As String 

Dim sExt As String 

Dim oOutlook As Object 

Dim oMail As Object 

Dim bProtected As Boolean 

Const sPassword As String = "Pippo"                  '&lt;&lt;=== Modifica 

Const sNomeFileAllegato As String = "MioFile"        '&lt;&lt;=== Modifica 

Const sEmail As String = \_ 

          "pippo CHIOCCIOLA gmail.com"               '&lt;&lt;=== Modifica 

Const sOggetto As String \_ 

                        = "Il tuo oggetto qui ..."   '&lt;&lt;===Modifica 

Const sCorpo As String \_ 

   = "Questi sono i dati da considerare ..."         '&lt;&lt;===Modifica 

Set srcWB = ThisWorkbook 

Set srcSH = ActiveSheet 

Set Rng = Selection 

With srcSH 

    bProtected = srcSH.ProtectContents = True 

    If bProtected Then 

        .Unprotect Password:=sPassword 

    End If 

End With 

On Error Resume Next 

Set srcRng = Rng.SpecialCells(xlCellTypeVisible) 

On Error GoTo 0 

If srcRng Is Nothing Then 

    Call MsgBox( \_ 

         Prompt:="La selezione non è un intervallo!" \_ 

                 & vbNewLine & vbNewLine \_ 

                 & "Seleziona l'intervallo di interesse e ripova", \_ 

         Buttons:=vbCritical, \_ 

         Title:="REPORT") 

    Exit Sub 

End If 

On Error GoTo XIT 

With Application 

    .ScreenUpdating = False 

    .EnableEvents = False 

End With 

Set destWB = Workbooks.Add(xlWBATWorksheet) 

srcRng.Copy 

With destWB.Sheets(1) 

    .Cells(1).PasteSpecial Paste:=8  '\\ xlPasteColumnWidths 

    .Cells(1).PasteSpecial Paste:=xlPasteValues 

    .Cells(1).PasteSpecial Paste:=xlPasteFormats 

    .Cells(1).Select 

    Application.CutCopyMode = False 

End With 

Set oOutlook = CreateObject("Outlook.Application") 

Set oMail = oOutlook.CreateItem(0) 

sFilename = sNomeFileAllegato & "\_" \_ 

            & Format(Now, "dd-mmm-yy hh-mm-ss") 

sExt = ".xlsx" 

With destWB 

    .SaveAs Filename:=sFilename & sExt, \_ 

            FileFormat:=51 

    On Error Resume Next 

    With oMail 

        .to = sEmail 

        .CC = "" 

        .BCC = "" 

        .Subject = sOggetto & **" " & srcSH.Name** 

        .Body = sCorpo 

        .Attachments.Add destWB.FullName 

        .Display    '.Send 

    End With 

    On Error GoTo 0 

    .Close savechanges:=False 

End With 

Kill sFilename & sExt

XIT:

Set oMail = Nothing 

Set oOutlook = Nothing 

With Application 

    .EnableEvents = True 

    .ScreenUpdating = True 

End With

End Sub

'<<=========

===

Regards,

Norman