Print side | Luk vindue

Sende mail, hvis cell value = Yes

Udskrevet fra: Dansk Regneark Forum
Kategori: Hjælp til regneark.
Forum navn: Makro og VBA
Forum beskrivelse: Hjælp til Makroer og VBA-programmering
Web-adresse: https://forum.excel-regneark.dk/forum_posts.asp?TID=4703
Udskrevet den: 22.Nov.2024 kl. 17:08


Emne: Sende mail, hvis cell value = Yes
Besked fra: Hartig
Emne: Sende mail, hvis cell value = Yes
Posteringsdato: 24.Mar.2022 kl. 14:51
Jeg har et ark med ret meget kode i, men nu kunne jeg godt tænke mig, OGSÅ at få det til at sende en mail med PDF-filen vedhæftet til kunden, hvis kunden selv ønsker dette i forbindelse med eftersynet (Dvs. E7 bliver til "Yes")


Svar:
Besked fra: Hartig
Posteringsdato: 24.Mar.2022 kl. 14:52
Private Sub GemSomPDF_Click()

    Dim rngCheck As Range
    Dim cllCheck As Range
    Dim bRedCell As Boolean
    Dim bCheckX As Boolean
    
    Dim OutApp As Object
    Dim OutMail As Object
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    Dim sht As Worksheet
    Set sht = ActiveSheet
    
    If Len(Dir("c:\1_Completed_PM", vbDirectory)) = 0 Then
       MkDir "c:\1_Completed_PM"
    End If
    
    'Set path to Folder
    fPath = "c:\1_Completed_PM\"
    
    'Build File Name from Sheet1 A3, A4 & C4
    With sht
    
    fName = .Range("A3") & "-" & _
            .Range("A4") & "-" & _
            .Range("C4")
    fName = Replace(fName, "/", "_", , , vbTextCompare)
            
    End With

    'Export as PDF to Folder
    Set rngCheck = sht.Range("A1:E200")
   
    For Each cllCheck In rngCheck.Cells
   
        If cllCheck.DisplayFormat.Interior.Color = 8696052 Then
             
            MsgBox "There are still red cells in the PM checklist", vbOKOnly + vbCritical, "Cell-check"
           
            bRedCell = True
           
            Exit For
       
        End If
   
    Next cllCheck
   
    If Not bRedCell Then
    Application.PrintCommunication = False
     With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(0)
        .BottomMargin = Application.InchesToPoints(0)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
        '.Orientation = xlLandscape
        .Orientation = xlPortrait
        .PaperSize = ePaperSize
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 0
    End With
    
        sht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fPath & fName, _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, OpenAfterPublish:=False
            
            If Err = 0 Then
                       
                MsgBox "The PM checklist are now saved with success. It can be found in the folder= C:\1_Completed_PM\ to attach Work Order in IFS.", vbInformation
                               
                 Set rngCheck = sht.Range("D9:D200")
                
                 For Each cllCheck In rngCheck.Cells
                
                     If UCase(cllCheck) = "X" Then
                    
                         bCheckX = True
                        
                         Exit For
                    
                     End If
                
                 Next cllCheck
    
                If bCheckX Then
                
                    If MsgBox("According to PM WO " & sht.Range("A3") & ", is one ore more things in " & sht.Range("A4") & " Not OK" & vbNewLine & vbNewLine & _
                              "Do you wish to send an e-mail to customerservice, so they can create a new Work Order? (INFO: The mail will be send, when the computer has internet, and Outlook is open)", _
                              vbYesNo + vbQuestion, "Send e-mail to get new Work Order?") = vbYes Then
                    
                        With OutMail
                            
                            .To = Sheets("Customer service e-mail address").Range("G1")
                                
                            .Attachments.Add fPath & fName & ".pdf"
                            
                            .CC = ""
                            .BCC = ""
                            
                            .Subject = "According to PM WO number " & sht.Range("A3") & ", a new Work Orders is needed in " & sht.Range("A4") & " IFS-number: " & sht.Range("A2") & ""
                            
                            .display
                            
                            .HTMLbody = "<HTML><BODY>" & _
                            "<span style=""color:#FF0000"">On the Preventive Maintenance is one ore more things <u>''NOT OK''</u></span style=""color:#FF0000"">" & _
                            "<br>" & _
                            "<span style=""color:#FF0000"">A new Work Order needs to be created to fix this</span style=""color:#FF0000"">" & _
                            "<br><br>" & _
                            "(Make X's below if it's urgent, and if it should be invoiced. Insert the name of the contact/reference)" & _
                            "<br><br>" & _
                            "<b>Urgent (Priority 1) &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <u>_______________________</u></b>   " & _
                            "<br>" & _
                            "<b>Regular service (Priority 2) &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <u>_______________________</u></b> " & _
                            "<br>" & _
                            "<b>By occasion (Priority 3) &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<u>_______________________</u></b> " & _
                            "<br><br>" & _
                            "<b>Being fixed on this PM? &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; YES<u>______</u> &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; NO<u>______</u></b> &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span style=""color:#FF0000"">If YES - a Work Order should be created to <u>" & sht.Range("C3") & "</u> ASAP</span style=""color:#FF0000"">" & _
                            "<br><br>" & _
                            "<b>Should this be invoiced? &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; YES<u>______</u> &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; NO<u>______</u></b> " & _
                            "<br><br>" & _
                            "<b>Contact in store: &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <u>_______________________</u></b>" & _
                            "<br><br>" & _
                            "<b>Description of what NOT OK in the store:&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<u> " & sht.Range("A36") & "</b></u>" & _
                            "<br><br>" & _
                            "</BODY></HTML>" & _
                            "<br><br>" & _
                            OutMail.HTMLbody
                        
                        End With
                        
                    End If
                
                End If
                
            End If
       
    Else
   
        MsgBox "PDF-file NOT SAVED because of red cells", vbOKOnly + vbCritical, "PDF-file NOT SAVED"
   
    End If

End Sub


Print side | Luk vindue