Mama godak issara liwwe me program eka. Main module eka oyage sheet ekata galapena widiyata wenas karala ganna.
#Const LateBind = True
Const olMinimized As Long = 1
Const olMaximized As Long = 2
Const olFolderInbox As Long = 6
#If LateBind Then
Public Function OutlookApp( _
Optional WindowState As Long = olMinimized, _
Optional ReleaseIt As Boolean = False _
) As Object
Static o As Object
#Else
Public Function OutlookApp( _
Optional WindowState As Outlook.OlWindowState = olMinimized, _
Optional ReleaseIt As Boolean _
) As Outlook.Application
Static o As Outlook.Application
#End If
On Error GoTo ErrHandler
Select Case True
Case o Is Nothing, Len(o.Name) = 0
Set o = GetObject(, "Outlook.Application")
If o.Explorers.Count = 0 Then
InitOutlook:
'Open inbox to prevent errors with security prompts
o.Session.GetDefaultFolder(olFolderInbox).Display
o.ActiveExplorer.WindowState = WindowState
End If
Case ReleaseIt
Set o = Nothing
End Select
Set OutlookApp = o
ExitProc:
Exit Function
ErrHandler:
Select Case Err.Number
Case -2147352567
'User cancelled setup, silently exit
Set o = Nothing
Case 429, 462
Set o = GetOutlookApp()
If o Is Nothing Then
Err.Raise 429, "OutlookApp", "Outlook Application does not appear to be installed."
Else
Resume InitOutlook
End If
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
End Select
Resume ExitProc
Resume
End Function
#If LateBind Then
Private Function GetOutlookApp() As Object
#Else
Private Function GetOutlookApp() As Outlook.Application
#End If
On Error GoTo ErrHandler
Set GetOutlookApp = CreateObject("Outlook.Application")
ExitProc:
Exit Function
ErrHandler:
Select Case Err.Number
Case Else
'Do not raise any errors
Set GetOutlookApp = Nothing
End Select
Resume ExitProc
Resume
End Function
Sub Main()
Dim WS_Main As Worksheet
Dim WS_New As Worksheet
Dim WS_Template As Worksheet
Dim i As Long
Dim WS_Main_ColA_LastRow As Long
Dim EAddress As String
Dim AttachmentPath As String
Set WS_Main = ActiveSheet
Set WS_Template = Worksheets("TemplateSheet")
'Find last row of column A
With WS_Main
WS_Main_ColA_LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
WS_Template.Visible = True
'On Error GoTo ErrorHandler:
For i = 4 To WS_Main_ColA_LastRow
If StrComp(Trim(WS_Main.Range("AD" & i).Value), "Do not send email", vbTextCompare) <> 0 Then
'Create a copy of the template sheet
WS_Template.Copy After:=Sheets(Sheets.Count)
'Sheets("Oct 24, 2015").Select
Set WS_New = ActiveSheet
'START DATE and END DATE
WS_Main.Activate
Range("B1:C1").Select
Selection.Copy
WS_New.Select
WS_New.Range("D9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Pay date
WS_Main.Activate
Range("F1").Select
Selection.Copy
WS_New.Select
WS_New.Range("F9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Name
WS_Main.Activate
Range("T" & i).Select
Selection.Copy
WS_New.Select
WS_New.Range("B11").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Percent and Payment:JMD
WS_Main.Activate
Range("U" & i & ":V" & i).Select
Selection.Copy
WS_New.Select
WS_New.Range("E11").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'remaing values
WS_Main.Activate
Range("W" & i & ":AA" & i).Select
Selection.Copy
WS_New.Select
WS_New.Range("F15").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
WS_Main.Activate
Range("AC" & i).Select
Selection.Copy
WS_New.Select
WS_New.Range("C18").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
WS_New.Range("A1").Select
WS_New.Name = "Paystub_" & WS_New.Range("B11").Value
Call SavePdf(WS_New)
DoEvents
'***
EAddress = WS_Main.Range("AB" & i).Value
AttachmentPath = ThisWorkbook.Path & "\" & _
Trim(WS_Main.Range("T" & i).Value) & "_" & Month(CDate(WS_Main.Range("F1").Value)) & "_" _
& Day(CDate(WS_Main.Range("F1").Value)) & "_" & Year(CDate(WS_Main.Range("F1").Value)) & ".pdf"
Call SendEmail(EAddress, AttachmentPath)
DoEvents
'***
Application.DisplayAlerts = False
WS_New.Delete
Application.DisplayAlerts = True
End If
Next i
'ErrorHandler:
Worksheets("TemplateSheet").Visible = xlVeryHidden
If Err = 0 Then
MsgBox "Completed", vbInformation, ""
Else
MsgBox "Error occured!", vbCritical, "warning!"
End If
End Sub
Sub SavePdf(WS As Worksheet)
'Dim WS As Worksheet
'Set WS = Worksheets("Paystub")
WS.PageSetup.Orientation = xlLandscape
FilePath = ThisWorkbook.Path
WS.Select
Dim fileName As String
fileName = Trim(WS.Range("B11").Value) & "_" & Month(CDate(WS.Range("F9").Value)) & "_" & _
Day(CDate(WS.Range("F9").Value)) & "_" & Year(CDate(WS.Range("F9").Value))
'MsgBox Month(CDate(Range("F9").Value))
'MsgBox Day(CDate(Range("F9").Value))
'MsgBox Year(CDate(Range("F9").Value))
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:=ThisWorkbook.Path & "\" & fileName & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False
'MsgBox "Completed", vbInformation, ""
End Sub
Sub MyMacroThatUseOutlook()
Dim OutApp As Object
Set OutApp = OutlookApp()
'Automate OutApp as desired
End Sub
Sub SendEmail(EmailAddress As String, FilePathtoAdd As String)
Dim messageBody As String
messageBody = "Hi," & vbCrLf & vbCrLf & _
"Here 's your pay information for the week. Please review." & vbCrLf & vbCrLf & _
"Please store this information in a safe place." & vbCrLf & vbCrLf & _
"Regards, " & vbCrLf & _
"Mgmt"
Dim OutApp As Object
Dim objMsg As MailItem
Set OutApp = OutlookApp()
Set objMsg = OutApp.CreateItem(olMailItem)
With objMsg
.To = EmailAddress
.Subject = "Pay Information"
'.Categories = "Test"
.Body = messageBody
.Attachments.Add FilePathtoAdd
'.Display 'use .display to send it automatically
.Send 'to send it automatically
End With
Set objMsg = Nothing
Set OutApp = Nothing
End Sub
