Sauvegarde feuille vers nouveau classeur avec mot de passe lecture écriture

Bonjour,

Je souhaite sauvegarder une feuille ver 1 nouveau classeur avec mot de passe.

Protection lecture écriture

Voici le code que j'utilise :

Dim Chemin2 As String 'Variable chemin pour sauvegarde
'
Chemin2 = "H:\DIR\25-commun\SERVICE\SAUVEGARDE DEMANDE DE SOUTIEN\" ' Indication du chemin pour sauvegarde

APPLICATION.DisplayAlerts = False

With ActiveWorkbook
.SaveAs Filename:=Chemin2 & ThisWorkbook.Sheets("Accueil").Range("b9") & " " & Format(Now, "yy-mm-dd hh_mm_ss")
APPLICATION.DisplayAlerts = False

.Close

End With
'
ActiveWorkbook.Save ' sauvegarde automatique
Sheets("Demande de soutien").Visible = False
Sheets("Demande de soutien").Visible = xlVeryHidden
APPLICATION.DisplayAlerts = True

Je souhaite rajouter la protection en lecture écriture avec mot de passe "Toto", par exemple.

Merci d'avance