Just random mumbling: 2020

Tuesday, December 8, 2020

Send gmail with embedded picture in mail body using VBA

'For Early Binding, enable Tools > References > Microsoft CDO for Windows 2000 Library
Option Explicit

Sub SendEmailUsingGmail()
    Dim NewMail As Object
    Dim mailConfig As Object
    Dim subj As String

    Dim fso As Object

    Dim fields As Variant
    Dim msConfigURL As String
    Dim rng As Range

    Workbooks.Open "C:\Users\allso\Desktop\new vba projects\new project subham brother\DPR NOV 2020.xlsb"
    subj = Workbooks("DPR NOV 2020.xlsb").sheets("ZONE").Range("H1").Value
    Workbooks("DPR NOV 2020.xlsb").Close SaveChanges:=True
   Set rng = Nothing
    On Error Resume Next

   ' Set rng = Selection.SpecialCells(xlCellTypeVisible)

    On Error GoTo Err:

    'late binding
    Set NewMail = CreateObject("CDO.Message")
    Set mailConfig = CreateObject("CDO.Configuration")
    Const cdoRefTypeId = 0

    Set fso = CreateObject("Scripting.FileSystemObject")
    ' load all default configurations
    mailConfig.Load -1

    Set fields = mailConfig.fields





    'Set All Email Properties
    With NewMail
        .AutoGenerateTextBody = False
        .Sender = "allsourav2@gmail.com"
        .From = "Sourav Bhattacharya"
        .To = "" 'mail address
        .CC = ""
        .BCC = ""
        .Subject = subj
        .BodyPart.ContentTransferEncoding = "quoted-printable"
        .BodyPart.Charset = "utf-8"
        '.Textbody = "Let me know if you have questions about the attached spreadsheet!"
         ' Adding images as inline attachments with Content IDs which is used with image sources. e.g. <img src="cid:image1" .. >
        .AddRelatedBodyPart fso.GetAbsolutePathName("C:\Users\allso\Desktop\new vba projects\temp1.jpg"), "temp1", cdoRefTypeId
        .AddRelatedBodyPart fso.GetAbsolutePathName("C:\Users\allso\Desktop\new vba projects\temp2.jpg"), "temp2", cdoRefTypeId
        '.Addattachment "C:\Users\allso\Desktop\new vba projects\temp.jpg"
        '.HTMLBody = .Textbody & "<html><p>CPS Daily progress Report of Nov 2020</p>" & _
                "<img src=""cid:temp.jpg"" height='600' width='900'>"
        'append html body from file
        .HTMLBody = fso.OpenTextFile("C:\Users\allso\Desktop\new vba projects\temp.html").ReadAll
    End With

    msConfigURL = "http://schemas.microsoft.com/cdo/configuration"

    With fields
        .Item(msConfigURL & "/smtpusessl") = True             'Enable SSL Authentication
        .Item(msConfigURL & "/smtpauthenticate") = 1          'SMTP authentication Enabled
        .Item(msConfigURL & "/smtpserver") = "smtp.gmail.com" 'Set the SMTP server details
        .Item(msConfigURL & "/smtpserverport") = 465          'Set the SMTP port Details
        .Item(msConfigURL & "/sendusing") = 2                 'Send using default setting
        .Item(msConfigURL & "/sendusername") = "" 'Your gmail address
        .Item(msConfigURL & "/sendpassword") = "" 'Your password or App Password
        .Update                                               'Update the configuration fields
    End With


    NewMail.Configuration = mailConfig


    NewMail.Send

    MsgBox "Your email has been sent", vbInformation

Exit_Err:
    'Release object memory
    Set NewMail = Nothing
    Set mailConfig = Nothing
    Set fso = Nothing

    End

Err:
    Select Case Err.Number
    Case -2147220973 'Could be because of Internet Connection
        MsgBox "Check your internet connection." & vbNewLine & Err.Number & ": " & Err.Description
    Case -2147220975 'Incorrect credentials User ID or password
        MsgBox "Check your login credentials and try again." & vbNewLine & Err.Number & ": " & Err.Description
    Case Else   'Report other errors
        MsgBox "Error encountered while sending email." & vbNewLine & Err.Number & ": " & Err.Description
    End Select

    Resume Exit_Err

End Sub

temp.html file contains

Send gmail using VBA with attachment

Option Explicit

Sub SendEmailUsingGmail()
    Dim NewMail As Object
    Dim mailConfig As Object
    Dim fields As Variant
    Dim msConfigURL As String
    Dim rng As Range
   Set rng = Nothing
    On Error Resume Next

    Set rng = Selection.SpecialCells(xlCellTypeVisible)

    On Error GoTo Err:

    'late binding
    Set NewMail = CreateObject("CDO.Message")
    Set mailConfig = CreateObject("CDO.Configuration")

    ' load all default configurations
    mailConfig.Load -1

    Set fields = mailConfig.fields





    'Set All Email Properties
    With NewMail
        .Sender = "" 'mail address
        .From = "Sourav Bhattacharya"
        .To = "" 'mail address
        .CC = ""
        .BCC = ""
        .Subject = "Demo Spreadsheet Attached"
        .Textbody = "Let me know if you have questions about the attached spreadsheet!"
        .Addattachment "C:\Users\allso\Desktop\new vba projects\temp.jpg"
        .HTMLBody = .Textbody

    End With

    msConfigURL = "http://schemas.microsoft.com/cdo/configuration"

    With fields
        .Item(msConfigURL & "/smtpusessl") = True             'Enable SSL Authentication
        .Item(msConfigURL & "/smtpauthenticate") = 1          'SMTP authentication Enabled
        .Item(msConfigURL & "/smtpserver") = "smtp.gmail.com" 'Set the SMTP server details
        .Item(msConfigURL & "/smtpserverport") = 465          'Set the SMTP port Details
        .Item(msConfigURL & "/sendusing") = 2                 'Send using default setting
        .Item(msConfigURL & "/sendusername") = "" 'Your gmail address
        .Item(msConfigURL & "/sendpassword") = "" 'Your password or App Password
        .Update                                               'Update the configuration fields
    End With


    NewMail.Configuration = mailConfig
    NewMail.Send

    MsgBox "Your email has been sent", vbInformation

Exit_Err:
    'Release object memory
    Set NewMail = Nothing
    Set mailConfig = Nothing
    End

Err:
    Select Case Err.Number
    Case -2147220973 'Could be because of Internet Connection
        MsgBox "Check your internet connection." & vbNewLine & Err.Number & ": " & Err.Description
    Case -2147220975 'Incorrect credentials User ID or password
        MsgBox "Check your login credentials and try again." & vbNewLine & Err.Number & ": " & Err.Description
    Case Else   'Report other errors
        MsgBox "Error encountered while sending email." & vbNewLine & Err.Number & ": " & Err.Description
    End Select

    Resume Exit_Err

End Sub

Convert excel range to a picture using VBA

Option Explicit

Sub Exportrangetopicture(oWs As Worksheet, rng As String, num As Integer)
'Hides alerts
Application.DisplayAlerts = False
'Dim oWs As Worksheet
Dim oRng As range
Dim oChrtO As ChartObject
Dim lWidth As Long, lHeight As Long

'Set oWs = sheets("AREA")

Set oRng = oWs.range(rng).CurrentRegion

oRng.CopyPicture xlScreen, xlPicture
lWidth = oRng.Width
lHeight = oRng.Height

Set oChrtO = oWs.ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight)

oChrtO.Activate
With oChrtO.Chart
.Paste
.Export Filename:="C:\Users\allso\Desktop\new vba projects\temp" & num & ".jpg", Filtername:="JPG"
End With

oChrtO.Delete

'shows alerts
Application.DisplayAlerts = True
End Sub

Sub callingfunc()
Workbooks.Open "C:\Users\allso\Desktop\new vba projects\new project subham brother\DPR NOV 2020.xlsb"
Dim ws As Worksheet
Set ws = Workbooks("DPR NOV 2020.xlsb").sheets("AREA")
Call Exportrangetopicture(ws, "J2", 1)
Set ws = Nothing
Set ws = Workbooks("DPR NOV 2020.xlsb").sheets("Zone")
Call Exportrangetopicture(ws, "H1", 2)
Workbooks("DPR NOV 2020.xlsb").Close SaveChanges:=True
End Sub

Change the range of source data of a pivot table programmatically using VBA

Option Explicit

Sub Copy_Paste_To_DPR_Pivot()
'Find the last used row in both sheets and copy and paste data below existing data.

Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lcopyLastRow As Long
Dim lDestLastRow As Long

'Open method requires full file path to be referenced.

Workbooks.Open "C:\Users\allso\Desktop\new vba projects\new project subham brother\DPR NOV 2020.xlsb"

'Set variables for copy and destination sheets
Set wsCopy = Workbooks("New Raw File Dual@.xlsb").Worksheets("NEW")
Set wsDest = Workbooks("DPR NOV 2020.xlsb").Worksheets("RAW FILE")


'clear content on the destination sheet except header

wsDest.Rows("2:" & wsDest.Rows.Count).ClearContents

   '1. Find last used row in the copy range based on data in column A
lcopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row

'Copy range to clipboard
wsCopy.range("A2:P" & lcopyLastRow).Copy

'PasteSpecial to paste values, formulas, formats, etc.
wsDest.range("A2").PasteSpecial Paste:=xlPasteValues

    'arrange and refresh the pivot table

    'Set variables for copy and destination sheets
Set wsCopy = Workbooks("DPR NOV 2020.xlsb").Worksheets("RAW FILE")
Set wsDest = Workbooks("DPR NOV 2020.xlsb").Worksheets("PIVOT")
lcopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row
Dim datarange As String

   datarange = wsCopy.Name & "!" & range("A1:P" & lcopyLastRow).Address(ReferenceStyle:=xlR1C1)


        wsDest.PivotTables("PivotTable1").ChangePivotCache ActiveWorkbook. _
        PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        datarange)

'Close the workbook

Workbooks("DPR NOV 2020.xlsb").Close SaveChanges:=True

End Sub

Saturday, October 3, 2020

Get unique values from a column of a range and filter the range by those unique values one by one and save the filtered results as pdfs and send mail with those pdfs as attachments using VBA updated

Function RemoveDupesColl(MyArray As Variant) As Variant
'DESCRIPTION: Removes duplicates from your array using the collection method.
'NOTES: (1) This function returns unique elements in your array, but
' it converts your array elements to strings.

'-----------------------------------------------------------------------
    Dim i As Long
    Dim arrColl As New Collection
    Dim arrDummy() As Variant
    Dim arrDummy1() As Variant
    Dim item As Variant
    ReDim arrDummy1(LBound(MyArray) To UBound(MyArray))

    For i = LBound(MyArray) To UBound(MyArray) 'convert to string
        arrDummy1(i) = CStr(MyArray(i))
    Next i
    On Error Resume Next
    For Each item In arrDummy1
       arrColl.Add item, item
    Next item
    Err.Clear
    ReDim arrDummy(LBound(MyArray) To arrColl.Count + LBound(MyArray) - 1)
    i = LBound(MyArray)
    For Each item In arrColl
       arrDummy(i) = item
       i = i + 1
    Next item
    RemoveDupesColl = arrDummy
End Function

Sub filterandpasteandmaildata()

Sheets("Sheet1").Select
If ActiveSheet.AutoFilterMode Or ActiveSheet.FilterMode Then
    On Error Resume Next
    ActiveSheet.ShowAllData
End If

Dim uniquedata()

'MsgBox (samplerange.Rows.Count)
ReDim Preserve uniquedata(ActiveSheet.Range("A2", ActiveSheet.Range("A2").End(xlDown)).Rows.Count)
'MsgBox (UBound(uniquedata))
Dim dict As Object
Dim length As Long
length = 0
Range("B2").Select
While ActiveCell.Value <> ""

uniquedata(length) = ActiveCell.Value
length = length + 1
ActiveCell.Offset(1, 0).Select
Wend

'For length = LBound(uniquedata) To UBound(uniquedata) - 1
'MsgBox (uniquedata(length))
'Next length
Dim uniquedatafinal()
uniquedatafinal = RemoveDupesColl(uniquedata)
'For length = LBound(uniquedatafinal) To UBound(uniquedatafinal) - 1
'MsgBox (uniquedatafinal(length))
'Next length

'now we found the unique names ,let us first delete anysheet containing such unique names and create sheets containing those names
Dim tempsheetname As String
With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With

For length = LBound(uniquedatafinal) To UBound(uniquedatafinal) - 1
tempsheetname = (uniquedatafinal(length))

For Each wks In Application.Worksheets
        If wks.name = tempsheetname Then wks.Delete
    Next

Next length

For length = LBound(uniquedatafinal) To UBound(uniquedatafinal) - 1
     cntsheets = Application.Sheets.Count
    Set NewSheet = Application.Worksheets.Add(After:=Worksheets(cntsheets))
    NewSheet.name = uniquedatafinal(length)
    Next length

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With

'Now creating sheets is done ,let us go back the data sheet and remove any filter from the sheet
'creating the directory for pdf files

Dim output_file As String, ws_count, i As Integer
Dim path, folder As String
path = "C:\Users\allso\Desktop\excel_to_pdf_2"
folder = dir(path, vbDirectory)
If folder = vbNullString Then


                VBA.FileSystem.MkDir (path)


    Else



    End If

Sheets("Sheet1").Select

Dim dataforfilter As String
Dim strtime As String
'set current default printer
Set mynetwork = CreateObject("WScript.network")
mynetwork.setdefaultprinter "Adobe PDF"
Dim objAccess As Object
Set objAccess = CreateObject("Access.Application")
Dim prtLoop As Object
'get current default printer
Set prtLoop = objAccess.Printer
'now we can access the printquality supported by the default printer by using prtloop.printquality
For length = LBound(uniquedatafinal) To UBound(uniquedatafinal) - 1
dataforfilter = Replace(ActiveSheet.Range("A1").CurrentRegion.Address, "$", "")
'MsgBox (dataforfilter)
ActiveSheet.Range(dataforfilter).AutoFilter Field:=2, Criteria1:=uniquedatafinal(length), Operator:=xlFilterValues
'ActiveSheet.Range(dataforfilter).AutoFilter Field:=4, Criteria1:="=Yes", Operator:=xlFilterValues
'sort the filtered range by the column gross sales
dataforfilter = Replace(ActiveSheet.Range("A1").CurrentRegion.Address, "$", "")
'MsgBox (dataforfilter)
Range(dataforfilter).Sort key1:=[h2], Order1:=xlDescending, Header:=xlYes
ActiveSheet.Range("A1").CurrentRegion.Select
Selection.Copy

Sheets(uniquedatafinal(length)).Select
'Range("A1").PasteSpecial xlPasteValues

Range("A1").PasteSpecial xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False

'autofitting the columns
ActiveSheet.Cells.Columns.AutoFit
'removing the borders
'changing the font
With ActiveSheet.Cells.Font

        .name = "Georgia Pro"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With

ActiveSheet.Cells.Borders.LineStyle = xlLineStyleNone

'now saving the sheet as pdf

If Format(CDate(Now), "am/pm") = "am" Then
strtime = Format(Now(), "yyyymmdd\_hhmmss") & " AM"
Else
strtime = Format(Now(), "yyyymmdd\_hhmmss") & " PM"
End If

output_file = path & "\" & Left(ThisWorkbook.name, Len(ThisWorkbook.name) - 5) & "." & ActiveSheet.name & "." & strtime & ".pdf"

'setting the page setup

'ActiveSheet.PageSetup.CenterHeader = "&B&14" & "Financial Data for " & uniquedatafinal(length) & ""

'&""Courier New""

'determine it is am or pm

If Format(CDate(Now), "am/pm") = "am" Then

ActiveSheet.PageSetup.CenterHeader = "&B&14&""Arial Narrow""&K00B0F0" & "Financial Data for " & uniquedatafinal(length) & " on " & "&D" & "," & "&T" & " AM"
Else
ActiveSheet.PageSetup.CenterHeader = "&B&14&""Arial Narrow""&K00B0F0" & "Financial Data for " & uniquedatafinal(length) & " on " & "&D" & "," & "&T" & " PM"

End If

'this is for setting the right footer of print which will print as Page (number of current page) of Total Pages
ActiveSheet.PageSetup.RightFooter = "&B&10&""Arial Narrow""&K00B0F0" & "Page &P of &N"

'change activeprinter to a choice of mine

'this commented out section works best with portrait printing

With ActiveSheet.PageSetup
.CenterHorizontally = True
'.CenterVertically = True
.BottomMargin = 50
.TopMargin = 50
.RightMargin = 10
.LeftMargin = 10
.Zoom = 50
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintTitleRows = ActiveSheet.Rows(1).Address
.Orientation = xlPortrait
.PrintQuality = prtLoop.PrintQuality

End With
'ActiveSheet.PrintPreview
'this section works best for landscape printing
'With ersheet.PageSetup
''for setting portrait or landscape
'.Orientation = xlLandscape
''these next two line will fit all columns in one page
'.FitToPagesWide = 1
'.FitToPagesTall = 1
''this line is responsible for continuing one fixed row on several print pages ,it is similar as excel freeze pane
'.PrintTitleRows = ersheet.Rows(1).Address
'End With
ActiveWorkbook.ActiveSheet.ExportAsFixedFormat xlTypePDF, output_file, xlQualityStandard, openafterpublish:=False


Sheets("Sheet1").Select
If ActiveSheet.AutoFilterMode Or ActiveSheet.FilterMode Then
    On Error Resume Next
    ActiveSheet.ShowAllData
End If

Next length

If ActiveSheet.AutoFilterMode Then

     ActiveSheet.AutoFilterMode = False

End If

'sending mail with pdf attachments

Dim olapp As Outlook.Application
Dim olemail As Outlook.MailItem
'Dim objFSO As Object
'    Dim objFldr As Object
'    Dim objFile As Object
'Dim strfullpath As String
'Set objFSO = CreateObject("Scripting.FileSystemObject")
'    Set objFldr = objFSO.GetFolder(Environ("UserProfile") & "\Desktop\excel_to_pdf_2")

Set olapp = New Outlook.Application
Set olemail = olapp.CreateItem(olMailItem)

With olemail

.BodyFormat = olFormatHTML

.Display
.HTMLBody = "Dear Someone" & "<br>" & .HTMLBody
'.Attachments.Add Environ("UserProfile") & "\Desktop\excel_to_pdf_2\Financial Sample.Canada.20200920_022807.pdf"
'For Each objFile In objFldr.Files
'        strfullpath = objFldr.path & "\" & objFile.Name
'
'        If LCase(Trim(objFSO.GetExtensionName(strfullpath))) = "pdf" Then
'        'MsgBox strfullpath
'            'SendasAttachment (strfullpath)
'          .Attachments.Add strfullpath
'        End If
'    Next
For length = LBound(uniquedatafinal) To UBound(uniquedatafinal) - 1
'Dim tmpfile As String
'tmpfile = getlatestfile(uniquedatafinal(length))
.Attachments.Add getlatestfile(uniquedatafinal(length))

.Attachments.Add tmpfile
'MsgBox (uniquedatafinal(length))

Next length

.To = "allsourav2@gmail.com"
.Subject = "Test using VBA"
.Send

End With
Set olapp = Nothing
Set olemail = Nothing
Set objFldr = Nothing
Set objFSO = Nothing
Set mynetwork = Nothing
Set objAccess = Nothing
Set prtLoop = Nothing
End Sub

' ----------------------------------------------------------------
' Purpose: Add Microsoft Outlook Object Library, call a procedure using that library, then remove Outlook Object Library
' ----------------------------------------------------------------
Sub callingProcedureMSOutlookObjLibrary()

    Dim strGUID As String

    'Microsoft Outlook GUID
    strGUID = "{00062FFF-0000-0000-C000-000000000046}"

    'Check if reference is already added to the project, if not add it
    If F_isReferenceAdded(strGUID) = False Then
        ThisWorkbook.VBProject.REFERENCES.AddFromGuid strGUID, 0, 0
    End If

    'Calling the procedure using Outlook object library
    Call procedureUsingMSOutlookObjectLibrary

    'Check if reference is added to the project, if yes remove
    If F_isReferenceAdded(strGUID) = True Then
        ThisWorkbook.VBProject.REFERENCES.Remove F_idReferenceByGUID(strGUID)
    End If

End Sub
' ----------------------------------------------------------------
' Purpose: Create new Outlook document with early binding, add two paragraphs, align the 2nd one to center
' ----------------------------------------------------------------

'sending mail with pdf attachments

Sub procedureUsingMSOutlookObjectLibrary()
Call filterandpasteandmaildata

End Sub

' ----------------------------------------------------------------
' Purpose: Check if an Object Library refernce is added to a VBAProject or not
' ----------------------------------------------------------------
Function F_isReferenceAdded(referenceGUID As String) As Boolean

    Dim varRef As Variant

    'Loop through VBProject references if input GUID found return TRUE otherwise FALSE
    For Each varRef In ThisWorkbook.VBProject.REFERENCES

        If varRef.GUID = referenceGUID Then
            F_isReferenceAdded = True
            Exit For
        End If

    Next varRef

End Function
' ----------------------------------------------------------------
' Purpose: Return Object Library reference as object, found by its GUID
' ----------------------------------------------------------------
Function F_idReferenceByGUID(referenceGUID As String) As Object

    Dim varRef As Object

    For Each varRef In ThisWorkbook.VBProject.REFERENCES

        If varRef.GUID = referenceGUID Then
            Set F_idReferenceByGUID = varRef
            Exit For
        End If

    Next varRef

End Function

Function getlatestfile(ByVal city As String)
'MsgBox (city)

Dim lowestval As Long
lowestval = 0
Dim counter As Integer
counter = 1
'MsgBox (counter)
Dim objFSO As Object
Dim objFldr As Object
Dim objFile As Object
Dim strfullpath As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFldr = objFSO.GetFolder(Environ("UserProfile") & "\Desktop\excel_to_pdf_2")

'.Attachments.Add Environ("UserProfile") & "\Desktop\excel_to_pdf_2\Financial Sample.Canada.20200920_022807.pdf"
For Each objFile In objFldr.Files
        strfullpath = objFldr.path & "\" & objFile.name

        If LCase(Trim(objFSO.GetExtensionName(strfullpath))) = "pdf" Then
        'MsgBox strfullpath
            'SendasAttachment (strfullpath)
            If InStr(1, objFile.name, city) <> 0 Then

            'MsgBox (strfullpath)
            Dim key As Long, val As String

            If counter = 1 Then
            val = strfullpath
            lowestval = timelapsefromnow(objFile.name, city)
            Else
            If lowestval > timelapsefromnow(objFile.name, city) Then

            val = strfullpath
            End If
            End If


              counter = counter + 1

            End If





        End If


    Next

'
'For Each key1 In dict.Keys
'   MsgBox (dict(key1))
'
'
'Next key1

'MsgBox (dict.Items(0))

'getlatestfile = dict(dict.Keys()(0))
getlatestfile = val

Set objFSO = Nothing
Set objFldr = Nothing
Set objFSO = Nothing

End Function

Function timelapsefromnow(str As String, searchitem As String)

'str = "Financial Sample.Canada.20201003_233001 PM"
'MsgBox (InStr(1, str, "Canada"))
Dim i As Integer, s As String
str = Replace(str, ".pdf", "")

s = Mid(str, InStr(1, str, searchitem) + Len(searchitem & "."), (Len(str) - InStr(1, str, searchitem)) + 1)

's1 = Mid(s, 1, InStr(1, s, "_") - 1)

's1 = Left(s1, 4) + "/" + Mid(s1, 5, 2) + "/" + Right(s1, Len(s1) - 6)
's1 = Left(Mid(s, 1, InStr(1, s, "_") - 1), 4) + "/" + Mid(Mid(s, 1, InStr(1, s, "_") - 1), 5, 2) + "/" + Right(Mid(s, 1, InStr(1, s, "_") - 1), Len(Mid(s, 1, InStr(1, s, "_") - 1)) - 6)
's2 = Mid(s, InStr(1, s, "_") + 1, Len(s))
's2 = " " & Left(Mid(s, InStr(1, s, "_") + 1, Len(s)), 2) + ":" + Mid(Mid(s, InStr(1, s, "_") + 1, Len(s)), 3, 2) + ":" + Right(Mid(s, InStr(1, s, "_") + 1, Len(s)), Len(Mid(s, InStr(1, s, "_") + 1, Len(s))) - 4)
s = Left(Mid(s, 1, InStr(1, s, "_") - 1), 4) + "/" + Mid(Mid(s, 1, InStr(1, s, "_") - 1), 5, 2) + "/" + Right(Mid(s, 1, InStr(1, s, "_") - 1), Len(Mid(s, 1, InStr(1, s, "_") - 1)) - 6) + " " & Left(Mid(s, InStr(1, s, "_") + 1, Len(s)), 2) + ":" + Mid(Mid(s, InStr(1, s, "_") + 1, Len(s)), 3, 2) + ":" + Right(Mid(s, InStr(1, s, "_") + 1, Len(s)), Len(Mid(s, InStr(1, s, "_") + 1, Len(s))) - 4)

'MsgBox (s1)
'
'Dim dateval As Date
''
'dateval = CDate(s)
'MsgBox (dateval)
'MsgBox (s)

'MsgBox (CDate(s))

Dim differenceinseconds As Long
differenceinseconds = DateDiff("s", CDate(s), Now)
timelapsefromnow = (differenceinseconds)

End Function

Sub test()
Dim name As String

Dim s()
s = Array("Canada", "Germany", "France")
For l = LBound(s) To UBound(s)

name = getlatestfile((s(l)))
MsgBox (name)

Next l

End Sub

Wednesday, September 23, 2020

AutomatingTranslation of text as well as numbers in worksheet cells from one language to other using internet explorer and vba

Option Explicit

Function GetNumeric(CellRef As String)
Dim StringLength As Integer, i As Integer, result As String

StringLength = Len(CellRef)
For i = 1 To StringLength
If IsNumeric(Mid(CellRef, i, 1)) Then result = result & Mid(CellRef, i, 1)
Next i
GetNumeric = result
End Function

Sub test()
Sheets("Sheet2").Select
Range("A1").Select
'MsgBox (GetNumeric(ActiveCell.Value))
While ActiveCell.Value <> ""

ActiveCell.Offset(0, 1).Value = Replace(ActiveCell.Value, GetNumeric(ActiveCell.Value), LCase(NumToWords(GetNumeric(ActiveCell.Value))))
ActiveCell.Offset(0, 2).Value = translate_using_vba(ActiveCell.Offset(0, 1).Value, "bn")
ActiveCell.Offset(1, 0).Select
Wend

ActiveSheet.Cells.Columns.AutoFit

End Sub


'Main Function
Function NumToWords(ByVal MyNumber)

    'Written by Philip Treacy
    'http://www.myonlinetraininghub.com/convert-numbers-currency-to-words-with-excel-vba
    'Feb 2014
    'Based on code from Microsoft http://support.microsoft.com/kb/213360
    'This code is not guaranteed to be error free. No warranty is implied or expressed. Use at your own risk and carry out your own testing

    Dim Units As String
    Dim SubUnits As String
    Dim TempStr As String
    Dim DecimalPlace As Integer
    Dim Count As Integer
    Dim DecimalSeparator As String
    Dim UnitName As String
    Dim SubUnitName As String
    Dim SubUnitSingularName As String

    DecimalSeparator = "."

    ReDim Place(9) As String
    Place(2) = " Thousand "
    Place(3) = " Million "
    Place(4) = " Billion "
    Place(5) = " Trillion "

    ' Convert MyNumber to STRING and TRIM white space
    MyNumber = Trim(CStr(MyNumber))

    'If MyNumber is blank then exit
    If MyNumber = "" Then

        NumToWords = ""

        Exit Function

    End If

    ' Find Position of decimal place, 0 if none.
    DecimalPlace = InStr(MyNumber, DecimalSeparator)


    ' Convert SubUnits and set MyNumber to Units amount.
    If DecimalPlace > 0 Then

        SubUnits = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2))
        MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))

    End If


    Count = 1
    Do While MyNumber <> ""

        TempStr = GetHundreds(Right(MyNumber, 3))

        If TempStr <> "" Then Units = TempStr & Place(Count) & Units

        If Len(MyNumber) > 3 Then

            MyNumber = Left(MyNumber, Len(MyNumber) - 3)

        Else

            MyNumber = ""

        End If

        Count = Count + 1

    Loop

    NumToWords = Application.Trim(Units)

End Function


' Converts a number from 100-999 into text
Function GetHundreds(ByVal MyNumber)

    Dim result As String

    If Val(MyNumber) = 0 Then Exit Function

    MyNumber = Right("000" & MyNumber, 3)

    ' Convert the hundreds place.
    If Mid(MyNumber, 1, 1) <> "0" Then

        result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "

    End If


    ' Convert the tens and ones place.
    If Mid(MyNumber, 2, 1) <> "0" Then

        result = result & GetTens(Mid(MyNumber, 2))

    Else

        result = result & GetDigit(Mid(MyNumber, 3))

    End If

    GetHundreds = result

End Function

' Converts a number from 10 to 99 into text.
Function GetTens(TensText)

    Dim result As String

    result = ""           ' Null out the temporary function value.

    If Val(Left(TensText, 1)) = 1 Then   ' If value between 10-19...

        Select Case Val(TensText)

            Case 10: result = "Ten"
            Case 11: result = "Eleven"
            Case 12: result = "Twelve"
            Case 13: result = "Thirteen"
            Case 14: result = "Fourteen"
            Case 15: result = "Fifteen"
            Case 16: result = "Sixteen"
            Case 17: result = "Seventeen"
            Case 18: result = "Eighteen"
            Case 19: result = "Nineteen"
            Case Else

        End Select

    Else                                 ' If value between 20-99...

        Select Case Val(Left(TensText, 1))

            Case 2: result = "Twenty "
            Case 3: result = "Thirty "
            Case 4: result = "Forty "
            Case 5: result = "Fifty "
            Case 6: result = "Sixty "
            Case 7: result = "Seventy "
            Case 8: result = "Eighty "
            Case 9: result = "Ninety "
            Case Else

        End Select

        result = result & GetDigit(Right(TensText, 1))   ' Retrieve ones place.

    End If

    GetTens = result

End Function

' Converts a number from 1 to 9 into text.
Function GetDigit(Digit)

    Select Case Val(Digit)

        Case 1: GetDigit = "One"
        Case 2: GetDigit = "Two"
        Case 3: GetDigit = "Three"
        Case 4: GetDigit = "Four"
        Case 5: GetDigit = "Five"
        Case 6: GetDigit = "Six"
        Case 7: GetDigit = "Seven"
        Case 8: GetDigit = "Eight"
        Case 9: GetDigit = "Nine"
        Case Else: GetDigit = ""

    End Select

End Function
Function translate_using_vba(str, langchoice) As String
' Tools Refrence Select Microsoft internet Control

    Dim IE As Object, i As Long
    Dim inputstring As String, outputstring As String, text_to_convert As String, result_data As String
    Dim CLEAN_DATA







    Set IE = CreateObject("InternetExplorer.application")
    '   TO CHOOSE INPUT LANGUAGE

    inputstring = "auto"

    '   TO CHOOSE OUTPUT LANGUAGE

    outputstring = langchoice

    text_to_convert = str

    'open website

    IE.Visible = False




    IE.navigate "http://translate.google.com/#" & inputstring & "/" & outputstring & "/" & text_to_convert

    Do Until IE.ReadyState = 4
        DoEvents
    Loop

    Application.Wait (Now + TimeValue("0:00:10"))
Do Until IE.ReadyState = 4
        DoEvents
    Loop

    IE.Quit
    translate_using_vba = IE.Document.getElementsByclassname("tlid-translation translation")(0).outertext




End Function

Monday, September 21, 2020

Adding a reference ,using it and remove the reference at the end programmatically using VBA

Most common Office GUID:

Microsoft Excel	{00020813-0000-0000-C000-000000000046}
Microsoft Word	{00020905-0000-0000-C000-000000000046}
Microsoft PowerPoint	{91493440-5A91-11CF-8700-00AA0060263B}
Microsoft Access	{4AFFC9A0-5F99-101B-AF4E-00AA003F0F07}
Microsoft Outlook	{00062FFF-0000-0000-C000-000000000046}

' ----------------------------------------------------------------
' Purpose: Add Microsoft Outlook Object Library, call a procedure using that library, then remove Outlook Object Library
' ----------------------------------------------------------------
Sub callingProcedureMSOutlookObjLibrary()

    Dim strGUID As String

    'Microsoft Outlook GUID
    strGUID = "{00062FFF-0000-0000-C000-000000000046}"

    'Check if reference is already added to the project, if not add it
    If F_isReferenceAdded(strGUID) = False Then
        ThisWorkbook.VBProject.REFERENCES.AddFromGuid strGUID, 0, 0
    End If

    'Calling the procedure using Outlook object library
    Call procedureUsingMSOutlookObjectLibrary

    'Check if reference is added to the project, if yes remove
    If F_isReferenceAdded(strGUID) = True Then
        ThisWorkbook.VBProject.REFERENCES.Remove F_idReferenceByGUID(strGUID)
    End If

End Sub
' ----------------------------------------------------------------
' Purpose: Create new Outlook document with early binding, add two paragraphs, align the 2nd one to center
' ----------------------------------------------------------------

'sending mail with pdf attachments

Sub procedureUsingMSOutlookObjectLibrary()

Dim olapp As Outlook.Application
Dim olemail As Outlook.MailItem
Dim objFSO As Object
Dim objFldr As Object
Dim objFile As Object
Dim strfullpath As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFldr = objFSO.GetFolder(Environ("UserProfile") & "\Desktop\excel_to_pdf_2")

Set olapp = New Outlook.Application
Set olemail = olapp.CreateItem(olMailItem)

With olemail

.BodyFormat = olFormatHTML

.Display
.HTMLBody = "Dear Someone" & "<br>" & .HTMLBody
'.Attachments.Add Environ("UserProfile") & "\Desktop\excel_to_pdf_2\Financial Sample.Canada.20200920_022807.pdf"
For Each objFile In objFldr.Files
        strfullpath = objFldr.Path & "\" & objFile.Name

        If LCase(Trim(objFSO.GetExtensionName(strfullpath))) = "pdf" Then
        'MsgBox strfullpath
            'SendasAttachment (strfullpath)
          .Attachments.Add strfullpath
        End If
    Next

.To = "allsourav2@gmail.com"
.Subject = "Test using VBA"
.Send

End With
Set olapp = Nothing
Set olemail = Nothing
End Sub

' ----------------------------------------------------------------
' Purpose: Check if an Object Library refernce is added to a VBAProject or not
' ----------------------------------------------------------------
Function F_isReferenceAdded(referenceGUID As String) As Boolean

    Dim varRef As Variant

    'Loop through VBProject references if input GUID found return TRUE otherwise FALSE
    For Each varRef In ThisWorkbook.VBProject.REFERENCES

        If varRef.GUID = referenceGUID Then
            F_isReferenceAdded = True
            Exit For
        End If

    Next varRef

End Function
' ----------------------------------------------------------------
' Purpose: Return Object Library reference as object, found by its GUID
' ----------------------------------------------------------------
Function F_idReferenceByGUID(referenceGUID As String) As Object

    Dim varRef As Object

    For Each varRef In ThisWorkbook.VBProject.REFERENCES

        If varRef.GUID = referenceGUID Then
            Set F_idReferenceByGUID = varRef
            Exit For
        End If

    Next varRef

End Function

Source:https://www.excelcise.org/add-or-remove-object-library-reference-via-vba/

Saturday, September 19, 2020

Get unique values from a column of a range and filter the range by those unique values one by one and save the filtered results as pdfs and send mail with those pdfs as attachments using VBA

Tuesday, September 15, 2020

Automating creation of salary structure floating bar chart using excel vba

Option Explicit

Function Difference(r1 As Range, r2 As Range) As Range

Dim s As String

Dim ws As Worksheet

If Not (r1.Parent Is r2.Parent) Then Exit Function

On Error Resume Next

Set ws = Worksheets.Add

ws.Range(r1.Address) = 0

ws.Range(r2.Address).Clear

s = ws.Range(r1.Address).SpecialCells(xlCellTypeConstants).Address

Application.DisplayAlerts = False

ws.Delete

Application.DisplayAlerts = True

If s <> "" Then Set Difference = r1.Parent.Range(s)

End Function

Sub floating_bar_chart()

'so first we have to delete the sheet named HR_Chart

With Application

.ScreenUpdating = False

.DisplayAlerts = False

.EnableEvents = False

End With

Dim achart As Chart

For Each achart In ActiveWorkbook.Charts

achart.Delete

' With ThisWorkbook

' Set wks = .Sheets.Add(After:=.Sheets(.Sheets.Count))

' wks.Name = "HR_Chart"

' End With

With Application

.ScreenUpdating = True

.DisplayAlerts = True

.EnableEvents = True

End With

'first delete all charts in this sheet

Dim Chrt As ChartObject

For Each Chrt In ActiveSheet.ChartObjects

Chrt.Delete

'Declare some variables

Sheets("Sheet1").Select

Dim DataRng As Range

'Dim series1name As String

'Dim series2name As String

'Dim series3name As String

'series1name = ActiveSheet.Range("F3").Value

'series2name = ActiveSheet.Range("F4").Value

'series3.Name = ActiveSheet.Range("F5").Value

Dim seriesnames()

Dim series()

ReDim Preserve seriesnames(0)

ReDim Preserve series(0)

ActiveSheet.Range("F3").Select

While ActiveCell.Value <> ""

ReDim Preserve seriesnames(UBound(seriesnames) + 1)

ReDim Preserve series(UBound(series) + 1)

Set seriesnames(UBound(seriesnames) - 1) = ActiveCell

Set series(UBound(series) - 1) = Difference(Range(Selection, Selection.End(xlToRight)), Selection)

ActiveCell.Offset(1, 0).Select

Wend

Dim counter As Integer

'For counter = 0 To (UBound(series) - 1)

'MsgBox (series(counter))

'Next counter

'Add a chart object, this would be an empty shell

Set Chrt = ActiveSheet.ChartObjects.Add(Left:=200, _

Width:=800, _

Height:=800, _

Top:=50)

'set the chart name

Dim chartname As String

chartname = "hrchart"

Chrt.Name = chartname

'Add the series of data in your chart

For counter = 0 To (UBound(series) - 1)

Chrt.Chart.SeriesCollection.NewSeries

Chrt.Chart.SeriesCollection(counter + 1).Name = "='" & ActiveSheet.Name & "'!" & seriesnames(counter).Address(, , xlR1C1)

Chrt.Chart.FullSeriesCollection(counter + 1).Values = "='" & ActiveSheet.Name & "'!" & series(counter).Address(, , xlR1C1)

Next counter

Sheets("Sheet1").Select

'Set Chrt = ActiveSheet.ChartObjects("hrchart")

'moving the chart to a sheet named "HR_Chart"

'Chrt.Chart.Location Where:=xlLocationAsNewSheet, Name:="HR_Chart"

'move chart to new sheet at the end

Chrt.Chart.Location Where:=xlLocationAsNewSheet, Name:="HR_Chart"

ActiveChart.Move After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)

'Chrt.Chart.Location xlLocationAsObject, "HR_Chart"

ActiveChart.ChartArea.Select

ActiveChart.FullSeriesCollection(1).Select

ActiveChart.ChartGroups(1).Overlap = 100

ActiveChart.ChartGroups(1).GapWidth = 66

ActiveChart.ChartArea.Select

ActiveChart.FullSeriesCollection(3).Select

With Selection.Format.Fill

.Visible = msoTrue

.ForeColor.ObjectThemeColor = msoThemeColorBackground1

.ForeColor.TintAndShade = 0

.ForeColor.Brightness = 0

.Transparency = 0

.Solid

End With

ActiveChart.Axes(xlValue).MajorGridlines.Select

Selection.Delete

'ActiveSheet.ChartObjects("hrchart").Activate

ActiveChart.FullSeriesCollection(1).Select

ActiveChart.FullSeriesCollection(1).ApplyDataLabels

ActiveChart.FullSeriesCollection(2).Select

ActiveChart.FullSeriesCollection(2).ApplyDataLabels

ActiveChart.FullSeriesCollection(3).Select

ActiveChart.FullSeriesCollection(3).ApplyDataLabels

ActiveChart.FullSeriesCollection(2).Select

With Selection.Format.Fill

.Visible = msoTrue

.ForeColor.RGB = RGB(204, 229, 255)

.Solid

End With

' ActiveChart.FullSeriesCollection(2).DataLabels.Select

' With Selection.Format.TextFrame2.TextRange.Font.Fill

' .Visible = msoTrue

' .ForeColor.ObjectThemeColor = msoThemeColorBackground1

' .ForeColor.TintAndShade = 0

' .ForeColor.Brightness = 0

' .Transparency = 0

' .Solid

' End With

ActiveChart.FullSeriesCollection(2).DataLabels.Format.TextFrame2.TextRange.Font.Fill.Visible = msoTrue

ActiveChart.FullSeriesCollection(2).DataLabels.Format.TextFrame2.TextRange.Font.Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1

ActiveChart.FullSeriesCollection(2).DataLabels.Format.TextFrame2.TextRange.Font.Fill.ForeColor.TintAndShade = 0

ActiveChart.FullSeriesCollection(2).DataLabels.Format.TextFrame2.TextRange.Font.Fill.ForeColor.Brightness = 0

ActiveChart.FullSeriesCollection(2).DataLabels.Format.TextFrame2.TextRange.Font.Fill.Transparency = 0

ActiveChart.FullSeriesCollection(2).DataLabels.Format.TextFrame2.TextRange.Font.Fill.Solid

ActiveChart.Deselect

SendKeys "{ESC}"

DoEvents

End Sub

Tuesday, August 18, 2020

Plotting Time series using Python,Matplotlib and Seaborn

# -*- coding: utf-8 -*-
"""Average_Plot_Assignment.ipynb

Automatically generated by Colaboratory.

Original file is located at
https://colab.research.google.com/drive/1je2kMjqPUPUzawk2IernYMR5lkwZgny1
"""

!pip install odfpy

import numpy as np
import datetime
from google.colab import files
import pandas as pd
df=pd.read_excel("/content/sample_data/arable__NIST_A_B_C_C003747_daily_20200818.ods", engine="odf")
#df.drop([df.index[0]],inplace=True)

#df = df.astype({"NIST A": np.float64, "NIST B": np.float64,"NIST C":np.float64},errors='coerce')
cols = ['NIST A', 'NIST B', 'NIST C']
df[cols] = df[cols].apply(pd.to_numeric,errors='coerce',axis=1)

df.fillna(0, inplace=True)

df[['Timestamp']] = df[['Timestamp']].apply(pd.to_datetime,errors='coerce',axis=1)
df.sort_values(by=['Timestamp'], inplace=True, ascending=True)
df['mean'] = df.mean(axis=1)
df= df.set_index('Timestamp')
df

import matplotlib.pyplot as plt
import matplotlib.dates as mdates
# Display figures inline in Jupyter notebook
import seaborn as sns
# Use seaborn style defaults and set the default figure size
sns.set(rc={'figure.figsize':(15, 4)})

fig, ax = plt.subplots()
ax.plot(df['mean'], marker='o', linestyle='-')
ax.set_ylabel('Mean')
ax.set_xlabel('Timestamp')
ax.set_title('Mean Vs Timestamp')
# Set x-axis major ticks to weekly interval, on Mondays
ax.xaxis.set_major_locator(mdates.WeekdayLocator(byweekday=mdates.MONDAY))
# Format x-tick labels as 3-letter month name and day number
ax.xaxis.set_major_formatter(mdates.DateFormatter('%b %d'));

# Specify the data columns we want to include (i.e. exclude Year, Month, Weekday Name)
data_columns = ['mean']
# Resample to weekly frequency, aggregating with mean
df_weekly_mean = df[data_columns].resample('W').mean()

import matplotlib.pyplot as plt
import matplotlib.dates as mdates
# Display figures inline in Jupyter notebook
import seaborn as sns
# Use seaborn style defaults and set the default figure size
sns.set(rc={'figure.figsize':(15, 4)})

# Start and end of the date range to extract
start, end = df.index.min(), df.index.max()
# Plot daily and weekly resampled time series together
fig, ax = plt.subplots()
ax.plot(df.loc[start:end, 'mean'],marker='.', linestyle='-', linewidth=1.0, label='Daily Mean')
ax.plot(df_weekly_mean.loc[start:end, 'mean'],marker='o', markersize=8, linestyle='-', label='Weekly Mean Resample')
ax.set_ylabel('Mean')
ax.legend();
fig.savefig("Fid.jpg",dpi=500,format='jpg', bbox_inches='tight')
files.download("Fid.jpg")

Tuesday, July 7, 2020

Convert word document to pdf using VBA

Option Explicit

Sub vba_word_to_pdf()

Dim output_file As String

output_file = ActivePresentation.Path & "\" & Left(ActivePresentation.Name, Len(ActivePresentation.Name) - 5) & ".pdf"

'MsgBox ("hello")

ActivePresentation.ExportAsFixedFormat output_file, ppFixedFormatTypePDF, ppFixedFormatIntentPrint

End Sub

Convert all slides in a powerpoint presentation to a pdf using VBA

Option Explicit

Sub vba_powerpoint_to_pdf()

Dim output_file As String

output_file = ActivePresentation.Path & "\" & Left(ActivePresentation.Name, Len(ActivePresentation.Name) - 5) & ".pdf"

'MsgBox ("hello")

ActivePresentation.ExportAsFixedFormat output_file, ppFixedFormatTypePDF, ppFixedFormatIntentPrint

End Sub

Monday, July 6, 2020

Read Pdf without Acrobat

Enable Microsoft Scripting Runtime reference

Option Explicit

Const form_filename As String = "C:\Users\allso\Desktop\New Customer Registration Form.pdf"

Sub read_pdf_form_vals()

Dim fso As New FileSystemObject

Dim tStream As TextStream

Dim vLine As String, vKey As String, fieldlist() As Variant, arrIndx As Integer

Dim i As Integer

vKey = ") Tj"

Set tStream = fso.OpenTextFile(form_filename, ForReading, False)

Do While Not tStream.AtEndOfStream

vLine = tStream.ReadLine

If InStr(vLine, vKey) > 0 Then

vLine = Replace(Right(vLine, Len(vLine) - 1), vKey, "", 1)

ReDim Preserve fieldlist(0 To arrIndx)

fieldlist(arrIndx) = vLine

Debug.Print vLine

arrIndx = arrIndx + 1

End If

'Debug.Print vLine

Loop

For i = UBound(fieldlist) To LBound(fieldlist) Step -1

Debug.Print fieldlist(i)

Next i

Set tStream = Nothing

Set fso = Nothing

End Sub

Monday, June 29, 2020

Determine if an employee should appear using predetermined rules of attendance system

Option Explicit
Sub evenoddconditionalformatting()
'Dim days() As String
Sheets("Sheet1").Select
ActiveSheet.Cells.ClearFormats
'get the days in the days array
Dim selectioncells As Range
Range(Range("B1"), Range("B1").End(xlToRight)).Select

Set selectioncells = selection

'MsgBox (selection.Address)
'MsgBox (selection.Count)
Dim arraylength As Integer

ReDim days(selection.Count)
'MsgBox (UBound(days))
Dim cell As Range, i As Integer
i = 1
For Each cell In selectioncells
days(i) = cell.Value

i = i + 1

Next

Dim names() As String
Range("a2", Range("a2").End(xlDown)).Select
'MsgBox (selection.Count)
'Dim arraylength As Integer

Set selectioncells = selection
ReDim names(selectioncells.Count)
'MsgBox (UBound(days))
'Dim cell As Range, i As Integer

For i = 1 To selectioncells.Count
names(i) = selectioncells(i).Value

Next
'
' For i = 1 To UBound(names)
'
' MsgBox (names(i))
'
' Next i
'
Dim dict As Object 'Declare a generic Object reference
Set dict = CreateObject("Scripting.Dictionary") 'Late Binding of the Dictionary

For i = 1 To UBound(names)

Dim key, val
key = names(i): val = Application.RandBetween(0, 1)
'Add item to VBA Dictionary
If Not dict.Exists(key) Then
    dict.Add key, val
End If

Next i
'
'Debug.Print dict.Count 'Result: 1
'
For Each key In dict.Keys
   Debug.Print key
Next key
'
''Print all items
'For Each val In dict.Items
'   Debug.Print val
'Next val

Range("L2").Select
For Each key In dict.Keys
   'Debug.Print key
   ActiveCell.Value = key
   ActiveCell.Offset(0, 1).Value = dict(key)
   ActiveCell.Offset(1, 0).Select



Next key

Set selectioncells = Range("B2:H11")
For Each cell In selectioncells
'Debug.Print cell.End(xlToLeft).Value
'Debug.Print cell.End(xlUp).Value

Dim pos As Integer
For i = 1 To UBound(days)
If cell.End(xlUp).Value = days(i) Then
pos = i
Exit For
End If
Next i
'MsgBox (pos)
pos = pos - 1
pos = pos Mod 2
'MsgBox (pos)
Dim pos2 As Integer
For Each key In dict.Keys
   'Debug.Print key
   If cell.End(xlToLeft).Value = key Then
   pos2 = dict(key)
   Exit For
   End If

Next key
'MsgBox (pos2)
If pos = pos2 Then
cell.Value = "Should be present"
Else
cell.Value = "Should be absent"
End If

Next cell

ActiveSheet.Columns.AutoFit

Dim mydate As String

mydate = Format(Date, "dddd")

Range(Range("B1"), Range("B1").End(xlToRight)).Select

Set selectioncells = selection

For Each cell In selectioncells
If mydate = cell.Value Then

Range(cell, cell.End(xlDown)).Select

Exit For

End If

Next
Set selectioncells = selection

'MsgBox (selectioncells.Address)

For Each cell In selectioncells
If cell.Value Like "*present" Then

cell.Interior.ColorIndex = 44
Else

End If

'MsgBox (cell.Value)

Next

End Sub

Sunday, June 28, 2020

Delete single or multiple pages from pdf file automatically using VBA and Acrobat Pro

Option Explicit

Sub deletepagefrompdf()
Dim aapp As Acrobat.AcroApp
Dim todoc As Acrobat.AcroPDDoc

Set aapp = CreateObject("AcroExch.App")
Set todoc = CreateObject("AcroExch.PDDoc")

aapp.Show
todoc.Open ("C:\Users\allso\Desktop\excel_to_pdf\merged_firstpage.pdf")

If todoc.DeletePages(0, 1) = True Then
Debug.Print "Deleted"
Else
Debug.Print "Failed To Delete"
End If

If todoc.Save(PDSaveFull, "C:\Users\allso\Desktop\excel_to_pdf\edited_deleted_firstpage.pdf") = False Then
Debug.Print "Failed to save the file"
Else
Debug.Print "Saved"

End If

todoc.Close

aapp.Exit

Set aapp = Nothing
Set todoc = Nothing

'close the blank acrobat window

Dim sKillExcel As String

sKillExcel = "TASKKILL /F /IM Acrobat.exe"
Shell sKillExcel, vbHide

End Sub

Combine pdfs together automatically using VBA and Acrobat Pro

Option Explicit

Sub combine_pdf_files()

Dim aapp As Acrobat.AcroApp
Dim todoc As Acrobat.AcroPDDoc
Dim fromdoc As Acrobat.AcroPDDoc
Set aapp = CreateObject("AcroExch.App")
Set todoc = CreateObject("AcroExch.PDDoc")
Set fromdoc = CreateObject("AcroExch.PDDOc")
aapp.Show
todoc.Open ("C:\Users\allso\Desktop\blank_pdf.pdf")
fromdoc.Open ("C:\Users\allso\Desktop\201753431466049.pdf")
If todoc.InsertPages(-1, fromdoc, 0, fromdoc.GetNumPages(), True) = False Then
'Here by using -1 we are trying to copy the frompdf to the first
'page of topdf,if the number is 0 it will be the next page from the first,if it is 1 it will be the second page from beginning

Debug.Print "Failed to insert the page"
End If
If todoc.Save(PDSaveFull, "C:\Users\allso\Desktop\excel_to_pdf\merged_firstpage.pdf") = False Then
Debug.Print "Failed to save the file"
Else
Debug.Print "Saved"

End If

todoc.Close
fromdoc.Close
aapp.Exit

Set aapp = Nothing
Set todoc = Nothing
Set fromdoc = Nothing

'closing the blank window of Acrobat

Dim sKillExcel As String

sKillExcel = "TASKKILL /F /IM Acrobat.exe"
Shell sKillExcel, vbHide

End Sub

Saturday, June 27, 2020

Kill a running process(In my case it is acrobat) using VBA

Sub test2()
Dim sKillExcel As String

sKillExcel = "TASKKILL /F /IM Acrobat.exe"
Shell sKillExcel, vbHide

End Sub

Source:https://stackoverflow.com/questions/26303173/how-can-i-kill-task-manager-processes-through-vba-code

Friday, June 26, 2020

Automated multiple PDF files batch data entry using VBA and Acrobat Library

Option Explicit
Public Const pdf_form_file As String = "C:\Users\allso\Desktop\New Customer Registration Form.pdf"
Sub readpdfformfield()
Sheets("PDF_Form_Fields").Select
Cells.Clear
Dim eapp As Acrobat.AcroApp
Dim av_doc As Acrobat.AcroAVDoc
Dim pdf_form As AFORMAUTLib.AFormApp
Dim pdf_form_flds As AFORMAUTLib.Fields
Dim pdf_form_fld As AFORMAUTLib.Field
Dim rng, firstcell As Range
Dim rownum, colnum As Integer
rownum = 1: colnum = 1
Set eapp = CreateObject("AcroExch.App")
Set av_doc = CreateObject("AcroExch.AVDoc")
If av_doc.Open(pdf_form_file, "") = True Then
av_doc.BringToFront
eapp.Hide
Set pdf_form = CreateObject("AFORMAUT.App")
Set pdf_form_flds = pdf_form.Fields

For Each pdf_form_fld In pdf_form_flds

With pdf_form_fld
'Debug.Print .Name & "|" & .Type & "|" & .Value
Cells(rownum, colnum) = .Name & "|" & .Type & "|" & .Value
Cells(rownum, colnum).Select
Set rng = Cells(rownum, colnum)
'MsgBox (rng.Address)
'rng.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="|", TrailingMinusNumbers:=True
Set firstcell = Cells(rownum, rng.Column)
'MsgBox (firstcell.Address)
rng.TextToColumns Destination:=firstcell, DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="|", TrailingMinusNumbers:=True

rownum = rownum + 1

End With
Next pdf_form_fld

av_doc.Close False

End If

eapp.Exit

Set av_doc = Nothing
Set eapp = Nothing

End Sub

Sub write_to_pdf_form()
Dim filenamepart As Integer
filenamepart = 1
Sheets("DataForPDF").Select
Range("A1").Select
Dim startrange As Range
Set startrange = Selection
While ActiveCell.Value <> ""

Dim pdfapp As Acrobat.AcroApp
Dim pdfdoc As Acrobat.AcroAVDoc
Dim support_doc As Acrobat.AcroPDDoc

Dim pdf_form As AFORMAUTLib.AFormApp
Dim pdf_form_flds As AFORMAUTLib.Fields

Dim givenname As AFORMAUTLib.Field
Dim familyname As AFORMAUTLib.Field
Dim address1 As AFORMAUTLib.Field
Dim phonenumber As AFORMAUTLib.Field
Dim findsource As AFORMAUTLib.Field
Dim email As AFORMAUTLib.Field
Dim willingtorecommend As AFORMAUTLib.Field
Set pdfapp = CreateObject("AcroExch.App")
Set pdfdoc = CreateObject("AcroExch.AVDoc")

If pdfdoc.Open(pdf_form_file, "") = True Then
pdfdoc.BringToFront
pdfapp.Hide
Set pdf_form = CreateObject("AFORMAUT.App")
Set pdf_form_flds = pdf_form.Fields

Set givenname = pdf_form.Fields("fullName3[first]")
Set familyname = pdf_form.Fields("fullName3[last]")
Set address1 = pdf_form.Fields("address4[addr_line1]")
Set phonenumber = pdf_form.Fields("phoneNumber5[full]")
Set email = pdf_form.Fields("email6")
Set findsource = pdf_form.Fields("howDid8")
Set willingtorecommend = pdf_form.Fields("willYou[0]")

Sheets("DataForPDF").Select
Cells(filenamepart, 1).Select

givenname.Value = ActiveCell.Value

familyname.Value = ActiveCell.Offset(0, 1).Value
address1.Value = ActiveCell.Offset(0, 2).Value
phonenumber.Value = ActiveCell.Offset(0, 3).Value
email.Value = ActiveCell.Offset(0, 4).Value
findsource.Value = ActiveCell.Offset(0, 5).Value
willingtorecommend.Value = ActiveCell.Offset(0, 6).Value

Set support_doc = pdfdoc.GetPDDoc

Dim path As String
path = "C:\Users\allso\Desktop\excel_to_pdf\output_" & filenamepart & ".pdf"
filenamepart = filenamepart + 1
'MsgBox (path)
If support_doc.Save(PDSaveFull, path) Then
Debug.Print "Saved"
Else
Debug.Print "Failed to save"

End If

pdfdoc.Close True
support_doc.Close
pdfapp.Exit

Set givenname = Nothing
Set familyname = Nothing
Set address1 = Nothing
Set phonenumber = Nothing
Set email = Nothing
Set findsource = Nothing
Set willingtorecommend = Nothing
Set pdfdoc = Nothing
Set support_doc = Nothing
End If

Wend

End Sub

Get the first cell of a range in VBA

Sub test()
Dim rng As Range
Set rng = Cells(1, 1)
Dim rng2 As Range

'MsgBox (Range(Cells(1, rng.Column)))
Set rng2 = Cells(1, rng.Column)
MsgBox (rng2.Address)
End Sub

Read Form fields from pdf using acrobat pro library and write them in excel and perform a texttocolumns operation for every time the loop rotates using VBA

I already add a reference of adobe acrobat 10.0 type library,I also need to add AForm Aut 1.0 Type Library reference to my project

Option Explicit

Public Const pdf_form_file As String = "C:\Users\allso\Desktop\Business Loan Application Form.pdf"
Sub readpdfformfield()
Sheets("PDF_Form_Fields").Select
Cells.Clear
Dim eapp As Acrobat.AcroApp
Dim av_doc As Acrobat.AcroAVDoc
Dim pdf_form As AFORMAUTLib.AFormApp
Dim pdf_form_flds As AFORMAUTLib.Fields
Dim pdf_form_fld As AFORMAUTLib.Field
Dim rng, firstcell As Range
Dim rownum, colnum As Integer
rownum = 1: colnum = 1
Set eapp = CreateObject("AcroExch.App")
Set av_doc = CreateObject("AcroExch.AVDoc")
If av_doc.Open(pdf_form_file, "") = True Then
av_doc.BringToFront
eapp.Hide
Set pdf_form = CreateObject("AFORMAUT.App")
Set pdf_form_flds = pdf_form.Fields

For Each pdf_form_fld In pdf_form_flds

With pdf_form_fld
'Debug.Print .Name & "|" & .Type & "|" & .Value
Cells(rownum, colnum) = .Name & "|" & .Type & "|" & .Value
Cells(rownum, colnum).Select
Set rng = Cells(rownum, colnum)
'MsgBox (rng.Address)
'rng.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="|", TrailingMinusNumbers:=True
Set firstcell = Cells(rownum, rng.Column)
'MsgBox (firstcell.Address)
rng.TextToColumns Destination:=firstcell, DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="|", TrailingMinusNumbers:=True

rownum = rownum + 1

End With
Next pdf_form_fld

av_doc.Close False

End If

eapp.Exit

Set av_doc = Nothing
Set eapp = Nothing

End Sub

Performing Text to Column automatically using VBA

I have a string variable containing a string which contains lots of "|" character,I need to do a text to column using VBA,My string variable in in cell A1

Sub Macro1()
'
' Macro1 Macro
'

'
Dim rng As Range
Set rng = Range("A1")

    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="|", TrailingMinusNumbers:=True

'        Selection.TextToColumns _
'      Destination:=Range("A2"), _
'      DataType:=xlDelimited, _
'      TextQualifier:=xlDoubleQuote, _
'      ConsecutiveDelimiter:=False, _
'      Tab:=True, _
'      Semicolon:=False, _
'      Comma:=False, _
'      Space:=False, _
'      Other:=True, _
'      OtherChar:="-"
End Sub