Is there a fast way to possible convert a VBA code to Google sheet script?
Option Explicit
Const MODULE_NAME As String = "modMail"
Private fileCounter As Integer
Private activeSht As Worksheet
'Display all the files in a folder. Searches all the sub folders.
'Prints Folder Names in Column A and and the file Names in Column B
Sub SearchFiles()
Dim pth As String
Dim fso As FileSystemObject
Dim baseFolder As Folder
'remove existing data
Range("A12").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete
Range("A12").Select
On Error Resume Next
'define folder where macro should search for attachments (here: subfolder "output files" of directory with the macro)
pth = ActiveWorkbook.Path & "\output files\"
Set fso = New FileSystemObject
''check if the folder actually exists or not
If (Not (fso.FolderExists(pth))) Then
'the folder path is invalid.
MsgBox "Invalid Path. Check if 'output files' sub-folder exists and has correct name"
Exit Sub
End If
Set baseFolder = fso.GetFolder(pth)
fileCounter = 1
Set activeSht = ActiveSheet
activeSht.Range("A2").FormulaR1C1 = "E-mail subject NL:"
activeSht.Range("B2").FormulaR1C1 = "=""DEALER NAME""&'email addresses'!R[4]C[7]"
activeSht.Range("A3").FormulaR1C1 = "E-mail subject EN:"
activeSht.Range("B3").FormulaR1C1 = "=""DEALER NAME""&'email addresses'!R[1]C[7]"
activeSht.Range("A4").FormulaR1C1 = "E-mail subject FR:"
activeSht.Range("A5").FormulaR1C1 = "Send out form mailbox:"
activeSht.Range("B5").FormulaR1C1 = "=IF('email addresses'!R[-4]C[7]=0,"""",'email addresses'!R[-4]C[7])"
activeSht.Range("A6").FormulaR1C1 = "CC in every mail:"
activeSht.Range("B6").FormulaR1C1 = "=IF('email addresses'!R[-4]C[7]=0,"""",'email addresses'!R[-4]C[7])"
activeSht.Range("A7").FormulaR1C1 = "Copy Collector?"
activeSht.Range("B7").FormulaR1C1 = ""
activeSht.Range("A8").FormulaR1C1 = "Copy Team?"
activeSht.Range("B8").FormulaR1C1 = ""
activeSht.Range("A9").FormulaR1C1 = "Team`s mailbox:"
activeSht.Range("B9").FormulaR1C1 = "=IF('email addresses'!R[-6]C[7]=0,"""",'email addresses'!R[-6]C[7])"
activeSht.Range("A10").FormulaR1C1 = "Empty ""To"" fields:"
activeSht.Range("B10").FormulaR1C1 = ""
activeSht.Range("A11").Value = "Folder Name"
activeSht.Range("B11").Value = "File Name"
activeSht.Range("C11").Value = "Business Partner"
Sheets("email addresses").Select
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Range("A1").Select
Sheets("breaking-data").Select
On Error GoTo ErrHandler
''' Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
PrintFileNames baseFolder
'Once all the items are identified, copy the values into the list and remove duplicates
Range("C12:C" & ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row).Select
Selection.Copy
Range("F12").Select
ActiveSheet.paste
Application.CutCopyMode = False
ActiveSheet.Range("$F$12:$F$" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlYes
'check Send From mailbox presence
Dim msg6 As Integer
If Sheets("email addresses").Range("I1").Value = 0 Then
msg6 = MsgBox("'From:' mailbox address is not defined. Your default mailbox will be used. Continue?", vbYesNo + vbQuestion, "From: is empty")
Sheets("breaking-data").Range("B5").FormulaR1C1 = "='email addresses'!R[-4]C[7]"
If msg6 = vbNo Then
Exit Sub
Else
Sheets("breaking-data").Range("B5").Value = "user default"
End If
End If
'Populate list with email addresses from the emailaddress tab
Dim lastrow As Long
If Sheets("breaking-data").Range("F13").Value = vbNullString Then lastrow = 13 Else lastrow = Worksheets("breaking-data").Range("F12").End(xlDown).Row
'find dealer name
Range("G12").Select
' ActiveCell.FormulaR1C1 = "=MID(RC[-5], 12 , SEARCH("".xlsb"",RC[-5])-12)"
Dim MidStart As Long
Do
MidStart = InStr(ActiveCell.Offset(0, -5), " ") + 1
ActiveCell.FormulaR1C1 = "=MID(RC[-5]," & MidStart & ", SEARCH("".xlsb"",RC[-5])-" & MidStart & ")"
ActiveCell.Offset(1, 0).Select
Loop Until IsEmpty(ActiveCell.Offset(0, -1))
'find "To"
Range("H12").Select
ActiveCell.FormulaR1C1 = _
"=IF(VLOOKUP(RC[-5],'email addresses'!R1C1:R5000C3,3,FALSE)="""",0,VLOOKUP(RC[-5],'email addresses'!R1C1:R5000C3,3,FALSE))"
Range("H12").Select
Range("H12").AutoFill Destination:=Range("H12:H" & lastrow&)
'define "CC1"
Range("I12").Select
ActiveCell.FormulaR1C1 = _
"=IF(VLOOKUP(RC[-6],'email addresses'!R1C1:R5000C4,4,FALSE) = 0,"""",VLOOKUP(RC[-6],'email addresses'!R1C1:R5000C4,4,FALSE))"
Range("I12").Select
Range("I12").AutoFill Destination:=Range("I12:I" & lastrow&)
'define "CC2" (WSA)?
Dim msg3 As Integer
msg3 = MsgBox("Would you like to copy Collector?", vbYesNo + vbQuestion, "Reminders - copy Collector?")
If msg3 = vbYes Then
Range("J12").FormulaR1C1 = _
"=VLOOKUP(VLOOKUP(RC[-4],'email addresses'!C[-9]:C[-4],6,0),'email addresses'!C[-2]:C[-1],2,0)"
Range("J12").Select
Range("J12").AutoFill Destination:=Range("J12:J" & lastrow&)
Range("B7").FormulaR1C1 = "Yes"
Else
Range("J12").FormulaR1C1 = Null
Range("J12").Select
Range("J12").AutoFill Destination:=Range("J12:J" & lastrow&)
Range("B7").FormulaR1C1 = "No"
End If
If lastrow = 13 And Sheets("breaking-data").Range("F13").Value = vbNullString Then
Range("G13:J13").ClearContents
End If
'copy CLSC?
Dim msg4 As Integer
msg4 = MsgBox("Would you like to copy Team`s mailbox?", vbYesNo + vbQuestion, "Reminders - copy Team`s mailbox?")
If msg4 = vbYes Then
Range("B8").FormulaR1C1 = "Yes"
Else
Range("B8").FormulaR1C1 = "No"
End If
ErrHandler:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
'autofit rows
Dim countIt As Integer
Rows("12:12").Select
countIt = Sheets("breaking-data").Cells(Sheets("breaking-data").Rows.Count, 1).End(xlUp).Row
Rows("12:" & countIt).Select
Selection.EntireRow.AutoFit
Selection.Copy
Selection.PasteSpecial paste:=xlPasteValues, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("A12").Select
'count emtpy "To" fields
Range("B10").Formula = "=COUNT(R[2]C[6]:R[" & countIt - 10 & "]C[6])+(COUNTA(R[2]C[4]:R[" & countIt - 10 & "]C[4])-COUNTA(R[2]C[6]:R[" & countIt - 10 & "]C[6]))"
Range("A12").Select
End Sub
Sub PrintFileNames(baseFolder As Folder)
Dim folder_ As Folder
Dim file_ As File
For Each folder_ In baseFolder.SubFolders
'call recursive function.
PrintFileNames folder_
Next folder_
For Each file_ In baseFolder.Files
'print files here
If (Right(file_.Name, 4) = "xlsb") Then
activeSht.Range("A11").Offset(fileCounter, 0).Value = baseFolder.Path
activeSht.Range("B11").Offset(fileCounter, 0).Value = file_.Name
'activeSht.Range("C4").Offset(fileCounter, 0).Value = Mid(file_.Name, 32, 10)
'activeSht.Range("D4").Offset(fileCounter, 0).Value = Left(file_.Name, 4)
' activeSht.Range("C11").Offset(fileCounter, 0).Value = Left(file_.Name, 10)
activeSht.Range("C11").Offset(fileCounter, 0).Value = Left(file_.Name, InStr(file_.Name, " ") - 1)
fileCounter = fileCounter + 1
Else
'fileCounter = fileCounter + 1
End If
Next file_
End Sub
Sub emailInvoices(simulation As String)
Dim cell As Range
Dim curPath As String
Dim loc_simulation As String
loc_simulation = simulation
Dim lstSales As Range
Dim myList As Range
Dim i As Long
'
' Dim statementMonth As Integer
' Dim statementYear As Integer
'
' Dim currentDate As Date
' Dim deferredDeliveryDate As Date
'
' currentDate = DateAdd("m", -1, Now)
' statementMonth = Format(currentDate, "m")
' statementYear = Format(currentDate, "yyyy")
'deferredDeliveryDate = DateAdd("d", 2, Now) 'delay time of 2 minutes before sending
'clear range extractionList
Range(Range("Extract"), Range("Extract").End(xlDown)).ClearContents
'check empty To: fields
Dim msg5 As Integer
If Range("B10").Value > 0 Then
msg5 = MsgBox("There is at least one empty field with 'To:' e-mail address. Would you like to continue?", vbYesNo + vbQuestion, "To: is empty")
If msg5 = vbNo Then
Range("A10").ClearContents
Exit Sub
Else
Range("A10").ClearContents
End If
End If
'check if there are any attachments to send out
Dim pth1 As String
Dim fsc As FileSystemObject
Dim objFiles As Files
Dim lngFileCount As Long
pth1 = ActiveWorkbook.Path & "\output files\" 'path to folder with attachments
Set fsc = CreateObject("Scripting.FileSystemObject")
Set objFiles = fsc.GetFolder(pth1).Files
lngFileCount = objFiles.Count
If lngFileCount = 0 Then
MsgBox ("There is no attachment in sub-folder 'output files'")
Exit Sub
End If
Set objFiles = Nothing
Set fsc = Nothing
'define ranges for simulation/production run
''' Application.ScreenUpdating = False
Application.DisplayAlerts = False
If loc_simulation = "Y" Then 'Use full range for prod run
Set lstSales = Range("lstSalesman")
ElseIf loc_simulation = "X" Then 'Use smaller range to perform test
Set lstSales = Sheets("breaking-data").Range("F11:J16")
End If
Set myList = Sheets("breaking-data").Range("A11:C" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1)
'start loop for each line in table with contacts (in test for the first 5 lines)
For i = 2 To lstSales.Rows.Count
'stop For if next line in 1stSales is empty
If lstSales(i, 1) = "" Then
Exit For
End If
'copy details of attachment to extractList
[valSalesman] = lstSales(i, 1)
myList.AdvancedFilter Action:=xlFilterCopy, _
criteriarange:=Range("Criteria"), copyToRange:=Range("Extract"), unique:=False
'EMAILING using OUTLOOK - Working in Excel 2000-2013
Dim OutApp As Object
Dim OutMail As Object
Dim extractList As Range
Set extractList = Sheets("breaking-data").Range("L11:N50")
Dim CCForAll As Range
Set CCForAll = Range("CCForAll")
Dim CC_CLSC As Range
Set CC_CLSC = Sheets("email addresses").Range("I3")
Dim toMail As String
Dim ccMail As String
'change Sent Items folder (not finished!!)
'Set Item.SaveSentMessageFolder = OutApp.Session.Folders("collections-ukroi@cnhind.com").Folders("Sent Items")
toMail = lstSales(i, 3)
If Sheets("breaking-data").Range("B8").Value = "Yes" Then
ccMail = lstSales(i, 4) & "; " & lstSales(i, 5) & "; " & CCForAll & "; " & CC_CLSC
Else
ccMail = lstSales(i, 4) & "; " & lstSales(i, 5) & "; " & CCForAll
End If
'open email template and copy contents
Dim WDObj As Object
Dim WDapp As Object
Dim WDDoc As Object
'Email Template
Dim language1 As String
language1 = Application.WorksheetFunction.VLookup(lstSales(i, 1), Sheets("email addresses").Range("A:E"), 5, False)
If language1 = "FR" Then
Set WDObj = ThisWorkbook.Sheets("email addresses").OLEObjects("EmailTemplateFR")
ElseIf language1 = "NL" Then
Set WDObj = ThisWorkbook.Sheets("email addresses").OLEObjects("EmailTemplateNL")
Else
Set WDObj = ThisWorkbook.Sheets("email addresses").OLEObjects("EmailTemplateEN")
End If
WDObj.Activate
WDObj.Object.Application.Visible = False
Set WDapp = GetObject(, "Word.Application")
Set WDDoc = WDapp.ActiveDocument
WDDoc.Content.Copy
WDDoc.Close SaveChanges:=False
' WDapp.Quit
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
'set up mailbox address, subject and mail body
Dim Mailbox As String
Dim Subject As String
Dim attachmentPath As String
Mailbox = Sheets("email addresses").Range("I1").Value
If language1 = "FR" Then
Subject = Sheets("email addresses").Range("I5").Value
ElseIf language1 = "NL" Then
Subject = Sheets("email addresses").Range("I6").Value
Else
Subject = Sheets("email addresses").Range("I4").Value
End If
attachmentPath = extractList(2, 1) & "\" & extractList(2, 2)
'compose e-mail
With OutMail
Dim DealerName As String
DealerName = extractList(2, 4)
.SentOnBehalfOfName = Mailbox
.Subject = UCase(lstSales(i, 2)) & Subject
.To = toMail
.CC = ccMail
.BCC = ""
.Attachments.Add attachmentPath
' .Attachments.Add extractList(2, 1) & "\" & extractList(2, 2)
If loc_simulation = "Y" Then ' only kill the attachment when performing the production run
Kill extractList(2, 1) & "\" & extractList(2, 2)
End If
' Next j
.HTMLBody = ""
' .Text
.Display
'wait a bit before pasting message body from the template
AppActivate (UCase(lstSales(i, 2)) & Subject & " - Message (HTML)")
On Error GoTo 0
Application.Wait (Now() + CDate("00:00:02"))
SendKeys "^v", True
SendKeys "^{HOME}", True
Application.Wait (Now() + CDate("00:00:02"))
'Simulation button
If loc_simulation = "X" Then
GoTo Clean_up:
ElseIf loc_simulation = "Y" Then 'Production Run button
'.DeferredDeliveryTime = deferredDeliveryDate 'defer delivery date
'wait a bit before pasting message body from the template
Application.Wait (Now() + CDate("00:00:02"))
.Send
'wait x seconds in the application before processing the next delivery
Application.Wait (Now() + CDate("00:00:02"))
Dim countMails As Long
countMails = countMails + 1
End If
End With
On Error GoTo 0
Clean_up:
Range("A1").Select
Selection.Copy
Application.CutCopyMode = False
Set OutMail = Nothing
Set OutApp = Nothing
Set WDObj = Nothing
Set WDapp = Nothing
' END mailing routine
'Range(Range("Extract"), Range("Extract").End(xlDown)).ClearContents
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
' count reminders not picked up
Dim fsc2 As FileSystemObject
Dim objFiles2 As Files
Dim lngFileCount2 As Long
Dim pth As String
pth = ActiveWorkbook.Path & "\output files\"
Set fsc2 = CreateObject("Scripting.FileSystemObject")
Set objFiles2 = fsc2.GetFolder(pth).Files
lngFileCount2 = objFiles2.Count
Sheets("breaking-data").Select
Range("A1").Select
AppActivate Application.Caption
DoEvents
If loc_simulation = "X" Then
If MsgBox("Test mails prepared." & vbLf & "If all is fine go to Step 4 otherwise check data and run Step 1 again", vbQuestion) = vbQuestion Then
GoTo End_it:
End If
ElseIf loc_simulation = "Y" Then
If lngFileCount2 > 0 Then
MsgBox ("There is/are: " & lngFileCount2 & "reminder(s) not picked up by the macro. Please check!")
GoTo Delete_input:
Else
If MsgBox(countMails & " mails sent out." & vbLf & "If any remains open please check it for errors and send out manually.", vbQuestion) = vbQuestion Then
GoTo Delete_input:
End If
End If
End If
Delete_input:
Dim msg2 As Integer
If loc_simulation = "X" Then
GoTo End_it:
Else
msg2 = MsgBox("Everything OK? Delete input data?", vbYesNo + vbQuestion, "Reminders delete input")
If msg2 = vbYes Then
Sheets("breaking-data").Select
Range("B7").ClearContents
Range("B8").ClearContents
Range("A12").Select
Range("A12:N" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1).Select
' Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete
Range("A12").Select
On Error Resume Next
Application.DisplayAlerts = False
Sheets("input").Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Worksheets.Add(Before:=Worksheets("email addresses")).Name = "input"
End If
End If
End_it:
Sheets("breaking-data").Select
Range("A1").Select
ActiveWorkbook.Save
SendKeys "{NUMLOCK}"
SendKeys "{INSERT}"
End Sub
'' Validate email address
Public Function ValidateEmailAddress(ByVal strEmailAddress As String) As Boolean
On Error GoTo Catch
Dim objRegExp As New RegExp
Dim blnIsValidEmail As Boolean
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "^([a-zA-Z0-9_\-\.]+)@[a-z0-9-]+(\.[a-z0-9-]+)*(\.[a-z]{2,3})$"
blnIsValidEmail = objRegExp.Test(strEmailAddress)
ValidateEmailAddress = blnIsValidEmail
Exit Function
Catch: ValidateEmailAddress = False
MsgBox "Module: " & MODULE_NAME & " - ValidateEmailAddress function" & vbCrLf & vbCrLf _
& "Error#: " & Err.Number & vbCrLf & vbCrLf & Err.Description
End Function
Ive been trying to make a script with google sheets to send a bulk of reminder to customers with a list of open invoices attached. I was able to make a script where the mails are sent to separate mail addresses, but unable to add an attachment. The problem that im experiencing
I was able to make the code below, but i'm having trouble adding the attachment. Also if there are multiple open invoices, there should only be 1 attachment made.
// This constant is written in column C for rows for which an email
// has been sent successfully.
var EMAIL_SENT = 'EMAIL_SENT';
/**
* Sends non-duplicate emails with data from the current spreadsheet.
*/
function sendEmails2() {
var sheet = SpreadsheetApp.getActiveSheet();
var startRow = 2; // First row of data to process
var numRows = 5; // Number of rows to process
// Fetch the range of cells A2:B3
var dataRange = sheet.getRange(startRow, 1, numRows, 3);
// Fetch values for each row in the Range.
var data = dataRange.getValues();
for (var i = 0; i < data.length; ++i) {
var row = data[i];
var emailAddress = row[1]; // Second column
var message = row[2]; // third column
var subject = row[3]; // Fourth column
var emailSent = row[5]; // Sixt column
if (emailSent != EMAIL_SENT) { // Prevents sending duplicates
MailApp.sendEmail(emailAddress, subject, message);
sheet.getRange(startRow + i, 6).setValue(EMAIL_SENT);
// Make sure the cell is updated right away in case the script is interrupted
SpreadsheetApp.flush();
}
}
}
I've seen several add-ons, but these are all blacklisted by our administrator.
Comments
Post a Comment