none
Run-time error '91': Object variable or with block variable not set RRS feed

  • Question

  • I need advice to resolve error 91. The error appears if Excel is running. If Excel has not been running, no error, the vba runs fine.

        strObj = "Excel.exe"
        Set objType = GetObject("winmgmts:").ExecQuery("Select * from win32_process where name='" & strObj & "'")
        If objType.Count < 1 Then
            Set ExcelApp = CreateObject("Excel.application")
        End If
        Set objWord = CreateObject("Word.application")
        For Each wb In Workbooks
            If wb.Name = "Recovery.xlsm" Then
                wbOpened = True
                Exit For
            Else
                wbOpened = False
            End If
        Next
        strFolderpath = "d:\recovery\"
        If wbOpened = False Then
            Workbooks.Open strFolderpath & "Recovery.xlsm"
        End If
        Set wb = Workbooks("Recovery.xlsm")
        Set ws = wb.Worksheets("data")
        ws.Activate
        ExcelApp.Visible = True                            'Run-time error 91 if Excel is present in memory
        ExcelApp.ActiveWindow.WindowState = xlMaximized


    Valuable skills are not learned, learned skills aren't valuable.


    • Edited by SingChung Friday, July 8, 2016 8:54 AM
    Monday, July 4, 2016 9:40 AM

All replies

  • What application are you using (where are you putting this code)?

    http://www.ambienteoffice.com.br - http://www.clarian.com.br

    Monday, July 4, 2016 11:55 AM
  • Microsoft Outlook.

    The code will read a table off an e-mail, copy into Excel, do a lot of manipulation and reply the e-mail.


    Valuable skills are not learned, learned skills aren't valuable.

    Monday, July 4, 2016 12:09 PM
  • Try something like this:

    Option Explicit
    
    Private aExcelApplication 'Excel.Application
    Private aWordApplication 'Word.Application
    Private aWorkbook As Object 'Excel.Workbook
    Private aWorksheet As Object 'Excel.Worksheet
    
    Sub Main()
        If Init = False Then GoTo Quit
        
        aWorksheet.Activate
    Quit:
    End Sub
    
    Private Function Init() As Boolean
        Set aExcelApplication = GetExcel
        If aExcelApplication Is Nothing Then GoTo Quit
        
        Set aWordApplication = GetWord
        If aWordApplication Is Nothing Then GoTo Quit
    
        Set aWorkbook = GetWorkbook
        If aWorkbook Is Nothing Then GoTo Quit
    
        Set aWorksheet = GetWorksheet
        If aWorksheet Is Nothing Then GoTo Quit
    
        Init = True
    Quit:
    End Function
    
    Private Function GetWorksheet() As Object 'Excel.Worksheet
        Dim Result As Object 'Excel.Worksheet
    
        On Error Resume Next
        Set Result = aWorkbook.Worksheets("data")
        On Error GoTo 0
        
        Set GetWorksheet = Result
    End Function
    
    Private Function GetWorkbook() As Object 'Excel.Workbook
        Const WORKBOOK_NAME As String = "Recovery.xlsm"
        Const FOLDER_PATH As String = "d:\recovery\"
        
        Dim Result As Object 'Excel.Workbook
    
        On Error Resume Next
        Set Result = aExcelApplication.Workbooks(WORKBOOK_NAME)
        On Error GoTo 0
        
        If Result Is Nothing Then
            On Error Resume Next
            Set Result = aExcelApplication.Workbooks.Open(FOLDER_PATH & WORKBOOK_NAME)
            On Error GoTo 0
        End If
        
        Set GetWorkbook = Result
    End Function
    
    Private Function GetExcel() As Object 'Excel.Application
        Dim Result As Object 'Excel.Application
        
        On Error Resume Next
        Set Result = GetObject(, "Excel.Application")
        On Error GoTo 0
        If Result Is Nothing Then
            Set Result = CreateObject("Excel.Application")
        End If
        
        If Result Is Nothing Then GoTo Quit
        
        Result.Visible = True
        
    Quit:
        Set GetExcel = Result
    End Function
    
    Private Function GetWord() As Object 'Word.Application
        Dim Result As Object 'Word.Application
        
        On Error Resume Next
        Set Result = GetObject(, "Word.Application")
        On Error GoTo 0
        If Result Is Nothing Then
            Set Result = CreateObject("Word.Application")
        End If
        
        If Result Is Nothing Then GoTo Quit
        
        Result.Visible = True
    Quit:
        Set GetWord = Result
    End Function
    


    http://www.ambienteoffice.com.br - http://www.clarian.com.br

    Monday, July 4, 2016 12:31 PM
  • Felipe, that is useful.

    Trying putting your int() function into my main sub, I am getting the error 91 at "If cells(lngCount,3).value="" Then" line below. I need to learn a lot more to be able to handle better codes.

    Sub Main()
        Dim objfso As Scripting.FileSystemObject, objFolder As Scripting.Folder, objsubfolder As Scripting.Folder, objFile As Scripting.File
        Dim wb As Workbook, ws As Worksheet, rng As Range, cells As Range, cell As Range
        Dim ObjAttachments As Outlook.Attachments, objItem As MailItem
        Dim objWord As Word.Application, objDoc As Word.Document, objTbl As Object, objShell As Object, wdrange As Word.Range, wdparagraph As Word.Paragraph
        Dim i As Integer, intTotalEquipment As Integer, lngRows As Long, lngColumns As Long, lngCount As Long
        Dim RowDeleted As Boolean
        Dim lngFirstRow As Long, lngLastRow As Long
       
        If Init = FalseThenGoTo Quit
        aWorksheet.Activate
        strFolderpath = "d:\recovery\"
        Set wb = Workbooks("Recovery.xlsm")
        Set ws = wb.Worksheets("data")
        ws.Activate
        aExcelApplication.Visible = True
        aExcelApplication.ActiveWindow.WindowState = xlMaximized
        Set objShell = CreateObject("Wscript.shell")
        Set objItem = GetCurrentItem()  'get current highlighted e-mail in Outlook
        objItem.Display'Display the e-mail on the screen
        
        Set objDoc = ActiveInspector.WordEditor'process table in current e-mail
        If objDoc.tables.Count = 0Then
            MsgBox"This message doesn't contain a table!", vbExclamation
            ExitSub
        EndIf
        Set objTbl = objDoc.tables(1)
        lngRows = objTbl.Rows.Count
        lngColumns = objTbl.Columns.Count
        objTbl.Range.Copy
        
        With ws'copy table from e-mail to Excel
            lngFirstRow = .cells(.Rows.Count, "B").End(xlUp).Row + 1
            Range("B" & lngFirstRow).Select
            ActiveCell.PasteSpecial xlPasteValues
            lngLastRow = .cells(.Rows.Count, "B").End(xlUp).Row
        EndWith
        aExcelApplication.DisplayAlerts = False
        aExcelApplication.CutCopyMode = False
        RowDeleted = True
        Set rng = Range(Range("C" & lngFirstRow), Range("C" & lngLastRow))
        For lngCount = lngLastRowTo lngFirstRowStep -1    'remove rows that has no transaction or not BCV
            If cells(lngCount, 3).Value = ""Then   '................Error 91 encountered....
                ExitFor
            EndIf
            IfUCase(Trim(cells(lngCount, 9).Value)) <> "YES"OrUCase(Trim(Left(cells(lngCount, 5).Value, 3))) <> "BCV"Then
                Rows(lngCount).EntireRow.Delete
            EndIf
        Next
        
    <<other codes here.....>>

        aExcelApplication.DisplayAlerts = True
        Set objFolder = Nothing
        Set objItem = Nothing
        Set objMailSMRT = Nothing
        Set objMailSBST = Nothing
        Set ObjAttachments = Nothing
        Set objDoc = Nothing
        Set objTbl = Nothing
        Set objShell = Nothing
        Set objfso = Nothing
        Set objFolder = Nothing
        Set objFile = Nothing
    Quit:
    EndSub

    Do I need to re-declare Excel, Word and Outlook objects in this sub?

    Sample of table in e-mail:

    Org

    Location

    Vehicle

    Equipment No

    Error

    Occurred (DD/MM/YY)

    Received (DD/MM/YY)

    TXN

    Org1

    BL

    SM3006

    BFC-14-0.2-0.6-22417

    Error code 588571

    4-Jul-16

    5-Jul-16

    YES

    Org2

    BL

    SM3006

    BCV-14-0.2-0.6-22309

    Unable to communicate

    4-Jul-16

    5-Jul-16

    YES

    Org2

    BN

    G1006

    BCV-14-0.2-0.6-20212

    Unable to communicate

    4-Jul-16

    5-Jul-16

    YES

    Org3

    WL

    G1006

    BFC-14-0.2-0.6-22463

    Unable to communicate

    4-Jul-16

    5-Jul-16

    YES


    structure of worksheet 'Data':

    # Org Location Vehicle Equipment No Error Occurred Submitted Received Uploaded Server Uploaded No. of files Filename File Date
    1 org1 WL SM0084 BCV-13-0.2-0.5-57312  faulty 2/7/2016 5/7/2016 5/7/2016 5/7/2016 WL1 11    


    • Edited by SingChung Friday, July 8, 2016 9:30 AM
    Friday, July 8, 2016 9:27 AM
  • There were a lot of unnecessary code - seems like you copied and pasted code from various sources. Don't do that or you'll get an spaghetti code. Variable's name were also not significative.

    I can't test the code, but I refactored it:

    Option Explicit
    
    Private aExcelApplication As Object 'Excel.Application
    Private aWorkbook As Object 'Excel.Workbook
    Private aWorksheet As Object 'Excel.Worksheet
    
    Sub Main()
        Dim CurrentItem As MailItem
        Dim WordDocument As Object 'Word.Document
        Dim WordTable As Object 'Word.Table
        Dim iRow As Long
        Dim FirstRow As Long
        Dim LastRow As Long
       
        If Init = False Then GoTo Quit
        
        Set CurrentItem = ActiveExplorer.Selection(1)  'get current highlighted e-mail in Outlook
        CurrentItem.Display 'Display the e-mail on the screen
        
        Set WordDocument = ActiveInspector.WordEditor 'process table in current e-mail
        If WordDocument.Tables.Count = 0 Then
            MsgBox "This message doesn't contain a table!", vbExclamation
            GoTo Quit
        End If
        
        Set WordTable = WordDocument.Tables(1)
        WordTable.Range.Copy
        
        With aWorksheet 'copy table from e-mail to Excel
            FirstRow = .Cells(.Rows.Count, "B").End(-4162).Row + 1
            .Range("B" & FirstRow).PasteSpecial -4163
            LastRow = .Cells(.Rows.Count, "B").End(-4162).Row
        End With
        
        aExcelApplication.DisplayAlerts = False
        
        For iRow = LastRow To FirstRow Step -1    'remove rows that has no transaction or not BCV
            If aWorksheet.Cells(iRow, 3).Value2 = "" Then   '................Error 91 encountered....
                GoTo Quit
            End If
            If UCase(Trim(aWorksheet.Cells(iRow, 9).Value2)) <> "YES" Or UCase(Trim(Left(aWorksheet.Cells(iRow, 5).Value2, 3))) <> "BCV" Then
                aWorksheet.Rows(iRow).EntireRow.Delete
            End If
        Next iRow
        
        aExcelApplication.DisplayAlerts = True
        
    Quit:
        Set aWorksheet = Nothing
        Set aWorkbook = Nothing
        Set aExcelApplication = Nothing
        Set CurrentItem = Nothing
        Set WordDocument = Nothing
        Set WordTable = Nothing
    End Sub
    
    Private Function Init() As Boolean
        Set aExcelApplication = GetExcel
        If aExcelApplication Is Nothing Then GoTo Quit
        
        Set aWorkbook = GetWorkbook
        If aWorkbook Is Nothing Then GoTo Quit
    
        Set aWorksheet = GetWorksheet
        If aWorksheet Is Nothing Then GoTo Quit
    
        Init = True
    Quit:
    End Function
    
    Private Function GetWorksheet() As Object 'Excel.Worksheet
        Dim Result As Object 'Excel.Worksheet
    
        On Error Resume Next
        Set Result = aWorkbook.Worksheets("data")
        On Error GoTo 0
        
        Set GetWorksheet = Result
    End Function
    
    Private Function GetWorkbook() As Object 'Excel.Workbook
        Const WORKBOOK_NAME As String = "Recovery.xlsm"
        Const FOLDER_PATH As String = "d:\recovery\"
        
        Dim Result As Object 'Excel.Workbook
    
        On Error Resume Next
        Set Result = aExcelApplication.Workbooks(WORKBOOK_NAME)
        On Error GoTo 0
        
        If Result Is Nothing Then
            On Error Resume Next
            Set Result = aExcelApplication.Workbooks.Open(FOLDER_PATH & WORKBOOK_NAME)
            On Error GoTo 0
        End If
        
        Set GetWorkbook = Result
    End Function
    
    Private Function GetExcel() As Object 'Excel.Application
        Dim Result As Object 'Excel.Application
        
        On Error Resume Next
        Set Result = GetObject(, "Excel.Application")
        On Error GoTo 0
        If Result Is Nothing Then
            Set Result = CreateObject("Excel.Application")
        End If
        
        If Result Is Nothing Then GoTo Quit
        
        Result.Visible = True
        
    Quit:
        Set GetExcel = Result
    End Function
    


    http://www.ambienteoffice.com.br - http://www.clarian.com.br

    Friday, July 8, 2016 11:40 AM
  • That is very useful.

    I had re-written my script, still I think there are unnecessary codes though able to achieve most of my objectives.

    There are 2 difficult tasks I wish the script can achieve:

    1. I want to be able to copy the filtered excel spreadsheet (filtered at column 'uploaded date' and 'org') then paste into the replying e-mail. I had tried something like this but failed (did a year ago, couldn't remember what was the exact problem):

            'Copy table from Excel Range from A & FirstRow to N & LastRow filtered at column B for "Company2"
            ws.Range(Range("A" & firstrow), Range("N" & LastRow)).AutoFilter Field:=2, Criteria1:="Company2"
            Set rng = ws.AutoFilter.Range
            ws.AutoFilter.Range.Resize(ws.Rows.Count - 1, 8).Copy
            Set objDoc = objMailSBST.GetInspector.WordEditor
            Set wdrange = objDoc.Range(0, 0)
            wdrange.Move wdparagrah, 5
            objMailCompany2.Display
            wdrange.Paste

    2. The number of lines in the cells of columns 'File name' and 'file date' must be the same. Whenever they are not the same, some correction must be done. So I wish to automate it. Basically the 'file date' is taken from the .idx file but the 'file name' is the corresponding file after .idx is converted to .dat file. Sometimes one .idx file is converted to more than one .dat file, under such a situation I have to duplicate the 'file date' whenever .idx has more than 1 corresponding .dat files.

    example in the excel spreadsheet, at 2nd row, there are 2 DF_YYYYMMDD_HHMMSS_0214_BFC.DAT files, so the date 8/10/2015 must be duplicated and appended after 8/10/2015. I had tried using 2 arrays, then looping through each element of the array, when it encounter same number at the 20th to 24th position of the current element with the previous element in the first array, the corresponding element in the 2nd array is duplicated. I couldn't get it to work, may be to complicated for me.

    # Org Location Vehicle Equipment No Incident Incident Date Date Processed Date Received Date Uploaded Server No. of files Filename File Date
    1 TTT BL XYZ3432 BCV-12-0.2-0.4-05784 Unit faulty error code : error 46 24/7/2016 25/7/2016 25/7/2016 25/7/2016 BL1 11 DF_20160725_171051_0037_BFC.DAT DF_20160725_171051_0038_BFC.DAT DF_20160725_171051_0039_BFC.DAT DF_20160725_171051_0040_BFC.DAT DF_20160725_171052_0041_BFC.DAT 24/6/2016 28/6/2016 3/7/2016 7/7/2016 11/7/2016
    5 Company2 BB XYZ7379 BCV-13-0.2-0.5-50933 Not specified 19/7/2016 25/7/2016 28/7/2016 28/7/2016 BB1 14 DF_20160728_162302_0077_BFC.DAT DF_20160728_162302_0212_BFC.DAT DF_20160728_162302_0213_BFC.DAT DF_20160728_162302_0214_BFC.DAT DF_20160728_162303_0214_BFC.DAT 16/12/2000 5/10/2015 8/10/2015 12/10/2015
    Sub Main()
        Const strFolderPath As String = "d:\documents\Recovery\"
        Dim CurrentItem As MailItem, ObjAttachments As Outlook.Attachments
        Dim WordDocument As Object 'Word.Document
        Dim WordTable As Object 'Word.Table
        Dim iRow As Long, cell As Range
        Dim iCount As Integer, intAttachmentCount As Integer
        Dim intTotalEquipment As Integer
        Dim intCompany1Recovered As Integer, intCompany2Recovered As Integer, intCompany1Total As Integer, intCompany2TOtal As Integer
        Dim strOrg As String, strCompany2 As String, strCompany1 As String, strCC As String, strMessage1 As String, strMessage2 As String, strMessage3 As String, strMessage4 As String
        Dim strRecipient As String, strCompany1Locations As String, strCompany2Locations As String, strFile As String
        Dim FirstRow As Long, LastRow As Long
        Dim objShell As Object
        Dim objfso As Scripting.FileSystemObject, objFolder As Scripting.Folder, objsubfolder As Scripting.Folder, objFile As Scripting.File
        Dim strEquipmentNo As String, strEquipmentFolder As String, strBus As String, strOutputPath As String
        Dim strReceivedDateTime As String, strIDXDates As String, strDATFiles As String
    
        Set objShell = CreateObject("wscript.shell")
    
        If Init = False Then GoTo Quit
        Set CurrentItem = ActiveExplorer.Selection(1)  'get current highlighted e-mail in Outlook
        CurrentItem.Display 'Display the e-mail on the screen
        
        Set WordDocument = ActiveInspector.WordEditor 'process table in current e-mail
        If WordDocument.Tables.Count = 0 Then
            MsgBox "This message doesn't contain a table!", vbExclamation
            GoTo Quit
        End If
        
        Set ObjAttachments = CurrentItem.Attachments
        intAttachmentCount = ObjAttachments.Count
        If intAttachmentCount > 0 Then 'process the attachments
            For iCount = intAttachmentCount To 1 Step -1
                strFile = ObjAttachments.Item(iCount).FileName
                strFile = strFolderPath & strFile
                ObjAttachments.Item(iCount).SaveAsFile strFile
            Next iCount
                objShell.Run strFolderPath & "unzip.bat"
        Else
            MsgBox "This message doesn't contain any attachment!", vbExclamation
            Exit Sub
        End If
        
        Set WordTable = WordDocument.Tables(1)
        WordTable.Range.Copy
        
        With aWorksheet 'copy table from e-mail to Excel
            FirstRow = .cells(.Rows.Count, "B").End(-4162).Row + 1
            .Range("B" & FirstRow).PasteSpecial -4163
            LastRow = .cells(.Rows.Count, "B").End(-4162).Row
        End With
        
        aExcelApplication.DisplayAlerts = False
        
        For iRow = LastRow To FirstRow Step -1    'remove rows that has no transaction or not BCV
            If aWorksheet.cells(iRow, 3).Value2 = "" Then   '................Error 91 encountered....
                GoTo Quit
            End If
            If UCase(Trim(aWorksheet.cells(iRow, 9).Value2)) <> "YES" Or UCase(Trim(Left(aWorksheet.cells(iRow, 5).Value2, 3))) <> "BCV" Then
                aWorksheet.Rows(iRow).EntireRow.Delete
            End If
        Next iRow
        
        aExcelApplication.DisplayAlerts = True
        
        'Process the extracted attachments
        intTotalEquipment = 0
        Set objfso = CreateObject("Scripting.FileSystemObject")
        Set objFolder = objfso.GetFolder(strFolderPath & "temp\txn\")
        For Each objsubfolder In objFolder.SubFolders   'process folders from extracted attachments
            strEquipmentFolder = strEquipmentFolder & vbCrLf & objsubfolder.Name 'get list of sub-folders in the extracted (equipment) folder
        Next objsubfolder
        
        'Conversion, based on Excel data
        For Each cell In Range(Range("C" & FirstRow), Range("C" & LastRow))
            If cell.Value = "" Then Exit For
            cell.Offset(0, 6).Value = Date  'populate receiveddate
            cell.Offset(0, 7).Value = Date  'populate uploaded date
            strEquipmentNo = cell.Offset(0, 2).Value
            If InStr(strEquipmentFolder, strEquipmentNo) = False Then
                MsgBox "Mismatch between Equipment Folder name and Equipment ID in the Excel spreadsheet. Please correct " & cell.Offset(0, 2).Value
            End If
            
            Set objFolder = objfso.GetFolder(strFolderPath & "temp\txn\" & strEquipmentNo)
            If objFolder.Files.Count > 0 Then
                For Each objFile In objFolder.Files 'Process the IDX files
                    If Right(objFile.Name, 3) = "idx" Then
                        If Date - objFile.DateLastModified < 7 Then 'count files that are not more than 7 days old
                            If cell.Offset(0, -1).Value = "Company1" Then
                                intCompany1Recovered = intCompany1Recovered + 1
                            End If
                            If cell.Offset(0, -1).Value = "Company2" Then
                                intCompany2Recovered = intCompany2Recovered + 1
                            End If
                        End If
                        strIDXDates = strIDXDates & Format(objFile.DateLastModified, "d/m/yyyy") & Chr(10)  'gather list of IDX files' dates
                    End If
                Next objFile
                strIDXDates = Left(strIDXDates, Len(strIDXDates) - 1) 'remove the trailing chr(10)
          
    '            ChDrive d:  'Change active drive
                ChDir strFolderPath & "temp\txn"    'change working directory
                objShell.Run strFolderPath & "BCVtoBFCDataConversion.exe " & strFolderPath & "temp\txn\" & strEquipmentNo 'convert the folder
                strBus = cell.Offset(0, 1).Value
     
                Sleep 5000
                If Not objfso.FolderExists(strFolderPath & "temp\txn\BFC_DATA_OUTPUT") And objfso.FolderExists("c:\BFC_DATA_OUTPUT") Then 'check if output folder has gone to c:
                    strOutputPath = "c:\BFC_DATA_OUTPUT"
                Else
                    strOutputPath = strFolderPath & "temp\txn\BFC_DATA_OUTPUT"
                End If
                Set objFolder = objfso.GetFolder(strOutputPath)
                For Each objFile In objFolder.Files 'process DAT files
                    If InStr(strDATFiles, Right(objFile.Name, 9)) Then
                        MsgBox "Repeated DAT files encountered! Please duplicate the corresponding dates to adjacent column", vbOKOnly
                    End If
                    strDATFiles = strDATFiles & objFile.Name & Chr(10)  'compile list of DAT files per converted folder
                    If Trim(cell.Offset(0, -1).Value) = "Company1" Then
                        intCompany1Total = intCompany1Total + 1
                    End If
                    If Trim(cell.Offset(0, -1).Value) = "Company2" Then
                        intCompany2TOtal = intCompany2TOtal + 1
                    End If
                Next objFile
                If Not objfso.FolderExists(strFolderPath & "\temp\" & Trim(cell.Offset(0, -1).Value) & "\" & Trim(cell.Value)) Then
                    objfso.CreateFolder strFolderPath & "temp\" & Trim(cell.Offset(0, -1).Value) & "\" & Trim(cell.Value)   'create Location folder
                End If
                If Not objfso.FolderExists(strFolderPath & "temp\" & Trim(cell.Offset(0, -1).Value) & "\" & Trim(cell.Value) & "\" & Trim(strBus)) Then   'move output files to bus folders
                    objfso.CreateFolder strFolderPath & "temp\" & Trim(cell.Offset(0, -1).Value) & "\" & Trim(cell.Value) & "\" & Trim(strBus)
                End If
                For Each objFile In objFolder.Files
                    objfso.MoveFile objFile.Path, strFolderPath & "temp\" & Trim(cell.Offset(0, -1).Value) & "\" & Trim(cell.Value) & "\" & Trim(strBus) & "\"
                Next objFile
                    objfso.DeleteFolder strOutputPath, True
                strDATFiles = Left(strDATFiles, Len(strDATFiles) - 1) 'remove the trailing chr(10)
            
                cell.Offset(0, 10).Value = strDATFiles  'populate the list of DAT files into cell
                strDATFiles = ""
                cell.Offset(0, 11).Value = strIDXDates
                strIDXDates = ""
    
                If Trim(cell.Offset(0, -1).Value) = "Company1" Then 'put in Company1 Locations and Company2 Locations into strings
                    If InStr(strCompany1, Trim(cell.Offset(0, -1).Value)) = 0 Then
                        strOrg = strCompany1 & Trim(cell.Offset(0, -1).Value)
                    End If
                    If InStr(strCompany1Locations, Trim(cell.Value)) = 0 Then 'to get unique values
                        strCompany1Locations = strCompany1Locations & Trim(cell.Value) & "/"
                    End If
                End If
                If Trim(cell.Offset(0, -1).Value) = "Company2" Then
                    If InStr(strCompany2, Trim(cell.Offset(0, -1).Value)) = 0 Then
                        strOrg = strCompany2 & Trim(cell.Offset(0, -1).Value)
                    End If
                    If InStr(strCompany2Locations, Trim(cell.Value)) = 0 Then 'to get unique values
                        strCompany2Locations = strCompany2Locations & Trim(cell.Value) & "/"
                    End If
                End If
            Else
                Rows(ActiveCell.Row).Delete
            End If
        Next cell
        'Location names
        If Len(strCompany1Locations) > 4 Then
            strCompany1Locations = Left(strCompany1Locations, Len(strCompany1Locations) - 1)
            If Len(strCompany1Locations) = 3 Then
                strCompany1Locations = Left(strCompany1Locations, 2)
            End If
        End If
        If Len(strCompany2Locations) > 4 Then
            strCompany2Locations = Left(strCompany2Locations, Len(strCompany2Locations) - 1)
            If Len(strCompany2Locations) = 3 Then
                strCompany2Locations = Left(strCompany2Locations, 2)
            End If
        End If
        If InStr(CurrentItem.Subject, "Company1") > 0 Then
            strOrg = "Company1"
            intCompany1Percent = (intCompany1Recovered / intCompany1Total) * 100
            strRecipient = "Supervisor1,"
            Set objMailCompany1 = objItem.Reply
            objMailCompany1.To = "abc@Company1.com;edf@Company1.com;"
            objMailCompany1.CC = "vxy@Company1.com;yz@Company1.com;" & strCC
            objMailCompany1.HTMLBody = "Dear " & strRecipient & "<br><br/>" & strMessage1 & strOrg & " " & strCompany1Locations & ".<br><br/>" & _
                            strMessage2 & intCompany1Recovered & " / " & intCompany1Total & strMessage3 & intCompany1Percent & " %)." & _
                            strMessage4 & objItem.HTMLBody
           objMailCompany1.Display
         End If
         'sending e-mail
         strCC = "xyz@mycompany.com"
         strMessage1 = "Here is the detail of transactions upload at " & vbCrLf
         strMessage2 = "Summary: " & vbCrLf & vbCrLf & "Total "
         strMessage3 = " transaction files recovered in time for settlement ("
         strMessage4 = "<p><span style='color:#0000A0'><b> Paste filter Worksheet Here </b></span><p/><p>Best Regards,<p/><p>" & Environ("UserName") & "</p><p>MyCompany</p>"
    
         If InStr(CurrentItem.Subject, "Company2") > 0 Then
            strOrg = "Company2"
            intCompany2Percent = Round((intCompany2Recovered / intCompany2TOtal) * 100, 2)
            strRecipient = "Dennis,"
            Set objMailCompany2 = CurrentItem.Reply
            objMailCompany2.To = "ddd@Company2.com"
            objMailCompany2.CC = "fff@Company2.com;" & strCC
            objMailCompany2.HTMLBody = "Dear " & strRecipient & "<br /><br />" & strMessage1 & strOrg & " " & strCompany2Locations & ".<br /><br />" & _
                            strMessage2 & intCompany2Recovered & " / " & intCompany2TOtal & strMessage3 & intCompany2Percent & " %)" & _
                            strMessage4 & CurrentItem.HTMLBody
            objMailCompany2.Display
         End If
         If InStr(CurrentItem.Subject, "Company1") = 0 And InStr(strOrg, "Company2") = 0 Then
            strOrg = ""
            MsgBox "Not correct e-mail!", vbExclamation, "Wrong e-mail"
            Exit Sub
         End If
         CurrentItem.Close olSave
    
    Quit:
        objfso.DeleteFolder (strFolderPath & "temp\txn\*")
        objShell.Run "Runas /user:admin1 " & strFolderPath & "uploadfiles.bat"
        Set aWorksheet = Nothing
        Set aWorkbook = Nothing
        Set aExcelApplication = Nothing
        Set CurrentItem = Nothing
        Set WordDocument = Nothing
        Set WordTable = Nothing
        Set objFolder = Nothing
        Set objMailCompany1 = Nothing
        Set objMailCompany2 = Nothing
        Set ObjAttachments = Nothing
        Set objShell = Nothing
        Set objfso = Nothing
        Set objFile = Nothing
    End Sub
    
    Private Function Init() As Boolean
        Set aExcelApplication = GetExcel
        If aExcelApplication Is Nothing Then GoTo Quit
        
        Set aWorkbook = GetWorkbook
        If aWorkbook Is Nothing Then GoTo Quit
    
        Set aWorksheet = GetWorksheet
        If aWorksheet Is Nothing Then GoTo Quit
    
        Init = True
    Quit:
    End Function
    
    Private Function GetWorksheet() As Object 'Excel.Worksheet
        Dim Result As Object 'Excel.Worksheet
    
        On Error Resume Next
        Set Result = aWorkbook.Worksheets("data")
        On Error GoTo 0
        
        Set GetWorksheet = Result
    End Function
    
    Private Function GetWorkbook() As Object 'Excel.Workbook
        Const WORKBOOK_NAME As String = "Recovery.xlsm"
        Const FOLDER_PATH As String = "d:\documents\Recovery\"
        
        Dim Result As Object 'Excel.Workbook
    
        On Error Resume Next
        Set Result = aExcelApplication.Workbooks(WORKBOOK_NAME)
        On Error GoTo 0
        
        If Result Is Nothing Then
            On Error Resume Next
            Set Result = aExcelApplication.Workbooks.Open(FOLDER_PATH & WORKBOOK_NAME)
            On Error GoTo 0
        End If
        
        Set GetWorkbook = Result
    End Function
    
    Private Function GetExcel() As Object 'Excel.Application
        Dim Result As Object 'Excel.Application
        
        On Error Resume Next
        Set Result = GetObject(, "Excel.Application")
        On Error GoTo 0
        If Result Is Nothing Then
            Set Result = CreateObject("Excel.Application")
        End If
        
        If Result Is Nothing Then GoTo Quit
        
        Result.Visible = True
        
    Quit:
        Set GetExcel = Result
    End Function


    Valuable skills are not learned, learned skills aren't valuable.

    Thursday, July 28, 2016 9:41 AM
  • I'm sorry I can't help you right now, I'd have to spend way too much time to answer your question and don't have that time now.

    http://www.ambienteoffice.com.br - http://www.clarian.com.br

    Thursday, July 28, 2016 1:05 PM