Reply to thread

Message

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

[QUOTE="soori19, post: 29909897, member: 560959"] 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 [/QUOTE]

Verification

Hath warak paha keeyada? (hatha wadikireema paha)

Search

Latest ads

Reply to thread