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) <u>_______________________</u></b> " & _
"<br>" & _
"<b>Regular service (Priority 2) <u>_______________________</u></b> " & _
"<br>" & _
"<b>By occasion (Priority 3) <u>_______________________</u></b> " & _
"<br><br>" & _
"<b>Being fixed on this PM? YES<u>______</u> NO<u>______</u></b> <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? YES<u>______</u> NO<u>______</u></b> " & _
"<br><br>" & _
"<b>Contact in store: <u>_______________________</u></b>" & _
"<br><br>" & _
"<b>Description of what NOT OK in the store: <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
Forum start
Forummets regler
Sådan uploader du filer
Marker Accepteret løsning
Del dine regneark
Excel-regneark.dk
Sende mail, hvis cell value = Yes
Emne funktioner
