проблема с моим внешним видом подписи с VBA - PullRequest
Новая
       76

проблема с моим внешним видом подписи с VBA

0 голосов
/ 25 февраля 2020

Я только начал в VBA. Я создаю код VBA для отправки писем через Outlook. Тем не менее, код работает при открытии почты, lo go появляется и исчезает через секунду, и вместо этого появляется красный крест. Я не понимаю, откуда проблема. Вот мой код: 

Private Sub EnvoyerMail()

Dim Mail As Variant
Dim Ligne As Integer
Dim Nom_Fichier As String
Dim DernLigne As Long
Dim SigString As String
Dim Signature As String
Dim strBody As String


Set Mail = CreateObject("Outlook.Application") 
DernLigne = Range("A1048576").End(xlUp).Row 

For Ligne = 2 To 3 'DernLigne ' A changer selon la taille du fichier

    'Change only Mysig.htm to the name of your signature
    SigString = Environ("appdata") & "\Microsoft\Signatures\" 
    f = Dir(SigString & "*.htm")
    If f <> "" Then
        Signature = GetBoiler(SigString & f)
        Signature = Replace(Signature, "src=""", "src=""" & SigString)

    Else
        Signature = ""
    End If

    On Error Resume Next

    With Mail.CreateItem(olMailItem)
        '.HTMLBody = Signature
        strBody = _
        "<Body>Bonjour,<br /><br /></Body>" & _
        "<Body>Veuillez trouver ci-joint le rapport énergétique du mois dernier pour votre site.<br /><br /> Nous vous enverrons de manière régulière des rapports.<br />Notre objectif est de maintenir en continu un équilibre entre économies d’énergie et confort.<br /><br /></Body>" & _
        "<Body>Remarque: Ce rapport est créé de façon automatique, si vous remarquez une erreur, n’hésitez pas à nous faire un retour.<br /><br /></Body>"

        Nom_Fichier = Range("A" & Ligne) 'Chercher la pièce jointe
        .Display
        .Save
        .Subject = Range("B" & Ligne) 
        .To = Range("C" & Ligne) 
        .CC = Range("D" & Ligne) 
        '.BCC = Range("" & Ligne)
        .HTMLBody = strBody & Signature
        .Attachments.Add Nom_Fichier    
        .Display
        .Send

    End With

Next Ligne

End Sub

Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

Function GetSignature(fPath As String) As String
    Dim fso As Object
    Dim TSet As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set TSet = fso.GetFile(fPath).OpenAsTextStream(1, -2)
    GetSignature = TSet.readall
    TSet.Close
End Function

1 Ответ

0 голосов
/ 23 апреля 2020

Это может наткнуться на код, который нужно изменить. 

Option Explicit

Private Sub EnvoyerMail_Signature_Then_EditedSignature_Demo()

    ' Excel code and loop not needed for this demo

    Dim Mail As Object
    Dim SigString As String
    Dim Signature As String
    Dim strBody As String
    Dim F As String

    Set Mail = CreateObject("Outlook.Application")

    SigString = Environ("appdata") & "\Microsoft\Signatures\"

    ' Change only Mysig.htm to the name of your signature
    ' F = dir(SigString & "Mysig.htm")

    ' With the * wildcard it is too vague if more than one signature
    F = dir(SigString & "*.htm")

    If F <> "" Then

        ' signature of unknown composition
        Signature = GetBoiler(SigString & F)

        ' edited signature of unknown composition
        Signature = Replace(Signature, "src=""", "src=""" & SigString)

    Else

        Signature = ""

    End If

    ' Default signature
    With Mail.CreateItem(olMailItem)

        .Display
        MsgBox "Mail #1 - Default signature" & vbCr & vbCr & "Default signature displays and becomes part of .HTMLBody"

        strBody = _
          "<Body>Bonjour,<br /><br /></Body>" & _
          "<Body>Veuillez trouver ci-joint le rapport ?nerg?tique du mois dernier pour votre site.<br /><br /> Nous vous enverrons de mani?re r?guli?re des rapports.<br />Notre objectif est de maintenir en continu un ?quilibre entre ?conomies d??nergie et confort.<br /><br /></Body>" & _
          "<Body>Remarque: Ce rapport est cr?? de fa?on automatique, si vous remarquez une erreur, n?h?sitez pas ? nous faire un retour.<br /><br /></Body>"

        ' Ignore edited F = dir(SigString ...
        ' Overwrite body, which is currently the default signature, with strBody and current .HTMLBody
        .HTMLBody = strBody & .HTMLBody

        MsgBox "Mail #1 - Default signature" & vbCr & vbCr & _
          "Entire body, including default signature, overwritten by strBody and current .HTMLBody"

    End With

    ' Edited F = dir(SigString ...
    With Mail.CreateItem(olMailItem)

        .Display
        MsgBox "Mail #2 - Edited F = dir(SigString ..." & vbCr & vbCr & "Default signature displays and becomes part of .HTMLBody"

        strBody = _
          "<Body>Bonjour,<br /><br /></Body>" & _
          "<Body>Veuillez trouver ci-joint le rapport ?nerg?tique du mois dernier pour votre site.<br /><br /> Nous vous enverrons de mani?re r?guli?re des rapports.<br />Notre objectif est de maintenir en continu un ?quilibre entre ?conomies d??nergie et confort.<br /><br /></Body>" & _
          "<Body>Remarque: Ce rapport est cr?? de fa?on automatique, si vous remarquez une erreur, n?h?sitez pas ? nous faire un retour.<br /><br /></Body>"

        ' Overwrite body, which is currently the signature, with strBody and edited F = dir(SigString ...
        .HTMLBody = strBody & Signature

        MsgBox "Mail #2 - Edited F = dir(SigString ..." & vbCr & vbCr & _
          "Entire body, including default signature, overwritten by strBody and edited version of signature found by" & vbCr & vbCr & _
          "    F = dir(SigString ..." & vbCr & vbCr & _
          "dir(SigString ... is not necessarily the same as the default signature if there is more than one signature."

    End With

End Sub

Function GetBoiler(ByVal sFile As String) As String
    Dim FSO As Object
    Dim ts As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set ts = FSO.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.ReadAll
    ts.Close
End Function

Function GetSignature(fPath As String) As String
    Dim FSO As Object
    Dim TSet As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set TSet = FSO.GetFile(fPath).OpenAsTextStream(1, -2)
    GetSignature = TSet.ReadAll
    TSet.Close
End Function
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Похожие темы

...