aworthey
10-06-2016, 06:50 AM
Hello,
I've been using VBA for several months now. I realize that most of what I write is possibly not the most efficient solution. I'm seeking ways to improve my code. Are there common tricks to be aware of? I'm attaching sample code I'm using in Outlook as a learning example.
Thanks!
Sub CopyInfoToExcel(olItem As MailItem)
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim xlSheet2 As Object
Dim tiFolder As Folder
Dim txtContact As String, txtCompany As String, txtSubject As String ', txtEmail As String
Dim sText As String
Dim sAddr As String
Dim vAddr As Variant
Dim vItem As Variant
Dim rCount As Long
Dim bXStarted As Boolean
Dim start As Date
Dim Finish As Date
Dim kItem As String
Dim quoteID As Long
Dim kNumber As String
Dim wbTEST As Object
Dim T0 As Long
Dim objOwner As Outlook.Recipient
Dim Rng As Range
Dim NxtQuote As Long
Dim Pass As String
Dim olkSnd As Outlook.AddressEntry, olkExu As Outlook.ExchangeUser
Dim olkMsg As Outlook.MailItem
Pass = "12345"
start = Now
Excel.Application.DisplayAlerts = False
Set xlWB = Excel.Application.Workbooks.Open("\\uswifs05\Matisse\Source\Prod\QuoteView\Data\KPS (file://\\uswifs05\Matisse\Source\Prod\QuoteView\Data\KPS) Sales Quote Index.xlsm")
If xlWB.ReadOnly Then
Do Until Not xlWB.ReadOnly
xlWB.Close savechanges:=False
Do Until Now > start + TimeValue("0:00:05")
Loop
Debug.Print "If not closed, close the original ReadWrite version now."
Set xlWB = Excel.Application.Workbooks.Open("\\uswifs05\Matisse\Source\Prod\QuoteView\Data\KPS (file://\\uswifs05\Matisse\Source\Prod\QuoteView\Data\KPS) Sales Quote Index.xlsm")
start = Now
Loop
End If
Debug.Print "Read write version should be ready now."
Set olApp = Outlook.Application
Set xlApp = Excel.Application
Set xlSheet = xlWB.Sheets("DATA")
Set xlSheet2 = xlWB.Sheets("CustomerContacts")
Set objNS = olApp.GetNamespace("MAPI")
Set objOwner = objNS.CreateRecipient("appengineer@kohler.com")
objOwner.Resolve
Set olFolder = objNS.GetSharedDefaultFolder(objOwner, olFolderInbox)
Set tiFolder = olFolder.Folders("Information")
Set olkSnd = olItem.Sender
If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
Set olkExu = olkSnd.GetExchangeUser
GetSMTPAddress = olkExu.PrimarySmtpAddress
Else: GetSMTPAddress = olItem.SenderEmailAddress
End If
'txtEmail = Trim(olItem.Body)
'Find the next empty line of the worksheet
rCount = xlSheet.Range("C" & xlSheet.Rows.Count).End(-4162).Row + 1
'Create K number
xlSheet.UnProtect (Pass)
'On Error GoTo ERRORHANDLER
With xlSheet
Set Rng = .Range("C:C")
If Format(Date, "YYYY") = 2016 Then
If xlApp.WorksheetFunction.Max(Rng) >= 1600000 Then
NxtQuote = xlApp.WorksheetFunction.Max(Rng) + 1
Else: NxtQuote = 1600000
End If
ElseIf Format(Date, "YYYY") = 2017 Then
If xlApp.WorksheetFunction.Max(Rng) >= 1700000 Then
NxtQuote = xlApp.WorksheetFunction.Max(Rng) + 1
Else: NxtQuote = 1700000
End If
ElseIf Format(Date, "YYYY") = 2018 Then
If xlApp.WorksheetFunction.Max(Rng) >= 1800000 Then
NxtQuote = xlApp.WorksheetFunction.Max(Rng) + 1
Else: NxtQuote = 1800000
End If
ElseIf Format(Date, "YYYY") = 2019 Then
If xlApp.WorksheetFunction.Max(Rng) >= 1900000 Then
NxtQuote = xlApp.WorksheetFunction.Max(Rng) + 1
Else: NxtQuote = 1900000
End If
ElseIf Format(Date, "YYYY") = 2020 Then
If xlApp.WorksheetFunction.Max(Rng) >= 2000000 Then
NxtQuote = xlApp.WorksheetFunction.Max(Rng) + 1
Else: NxtQuote = 2000000
End If
End If
End With
'quoteID = NxtQuote 'Project ID
kNumber = "K" & NxtQuote & "-" & "TI" & "-1"
'Add K number to subject line
kItem = kNumber
txtSubject = olItem.Subject
olItem.Subject = kItem & " | " & txtSubject
xlSheet2.Range("G" & 2) = GetSMTPAddress 'Sender email address to be processed for Contact name
xlSheet2.Range("I" & 2) = GetSMTPAddress 'Sender email address to be processed for Company
start = Now
Do Until Now > start + TimeValue("0:00:01")
Loop
txtContact = xlSheet2.Range("G" & 4) 'Contact name gets assigned variable
txtCompany = xlSheet2.Range("I" & 4) 'Company gets assigned variable
xlSheet.Range("L" & rCount) = txtContact 'Contact Name
xlSheet.Range("K" & rCount) = txtCompany 'Company
xlSheet.Range("D" & rCount) = "TI" 'Category ID (TI, TA, SG, LG)
xlSheet.Range("N" & rCount) = GetSMTPAddress 'email
xlSheet.Range("E" & rCount) = "1" 'Revision
xlSheet.Range("C" & rCount) = NxtQuote 'Quote ID
xlSheet.Range("F" & rCount) = "TIG" 'Queue Type (TAG, Large Gas, Switchgear)
xlSheet.Range("G" & rCount) = "Email" 'Request Type
xlSheet.Range("H" & rCount) = "Technical Information" 'Quote Category (Generator/ATS | Tank & Enclosure | Switchgear | Large Gas | Technical Information)
xlSheet.Range("I" & rCount) = "5" 'Category Priority (1-5)
xlSheet.Range("AJ" & rCount) = "Open"
xlSheet.Range("AZ" & rCount) = "Open"
xlSheet.Range("AX" & rCount) = "Open"
xlSheet.Range("BA" & rCount) = "Open"
xlSheet.Range("BE" & rCount) = "Open"
xlSheet.Range("BG" & rCount) = "Open"
'xlSheet.Range("BI" & rCount) = txtEmail 'Email body
olItem.UnRead = True
olItem.Move tiFolder
'Date and time from time stamp
xlSheet.Range("AS" & rCount) = Format(olItem.ReceivedTime, "mm/dd/yyyy hh:mm:ss AM/PM")
xlSheet.Range("AR" & rCount) = Format(olItem.ReceivedTime, "mm/dd/yyyy")
xlSheet.Range("AT" & rCount) = "Automated" 'Created By
'ERRORHANDLER:
Excel.Application.ScreenUpdating = True
Excel.Application.DisplayAlerts = True
xlSheet.Protect (Pass)
xlWB.Save
xlWB.Close savechanges:=True
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olkSnd = Nothing
Set olkExu = Nothing
End Sub
I've been using VBA for several months now. I realize that most of what I write is possibly not the most efficient solution. I'm seeking ways to improve my code. Are there common tricks to be aware of? I'm attaching sample code I'm using in Outlook as a learning example.
Thanks!
Sub CopyInfoToExcel(olItem As MailItem)
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim xlSheet2 As Object
Dim tiFolder As Folder
Dim txtContact As String, txtCompany As String, txtSubject As String ', txtEmail As String
Dim sText As String
Dim sAddr As String
Dim vAddr As Variant
Dim vItem As Variant
Dim rCount As Long
Dim bXStarted As Boolean
Dim start As Date
Dim Finish As Date
Dim kItem As String
Dim quoteID As Long
Dim kNumber As String
Dim wbTEST As Object
Dim T0 As Long
Dim objOwner As Outlook.Recipient
Dim Rng As Range
Dim NxtQuote As Long
Dim Pass As String
Dim olkSnd As Outlook.AddressEntry, olkExu As Outlook.ExchangeUser
Dim olkMsg As Outlook.MailItem
Pass = "12345"
start = Now
Excel.Application.DisplayAlerts = False
Set xlWB = Excel.Application.Workbooks.Open("\\uswifs05\Matisse\Source\Prod\QuoteView\Data\KPS (file://\\uswifs05\Matisse\Source\Prod\QuoteView\Data\KPS) Sales Quote Index.xlsm")
If xlWB.ReadOnly Then
Do Until Not xlWB.ReadOnly
xlWB.Close savechanges:=False
Do Until Now > start + TimeValue("0:00:05")
Loop
Debug.Print "If not closed, close the original ReadWrite version now."
Set xlWB = Excel.Application.Workbooks.Open("\\uswifs05\Matisse\Source\Prod\QuoteView\Data\KPS (file://\\uswifs05\Matisse\Source\Prod\QuoteView\Data\KPS) Sales Quote Index.xlsm")
start = Now
Loop
End If
Debug.Print "Read write version should be ready now."
Set olApp = Outlook.Application
Set xlApp = Excel.Application
Set xlSheet = xlWB.Sheets("DATA")
Set xlSheet2 = xlWB.Sheets("CustomerContacts")
Set objNS = olApp.GetNamespace("MAPI")
Set objOwner = objNS.CreateRecipient("appengineer@kohler.com")
objOwner.Resolve
Set olFolder = objNS.GetSharedDefaultFolder(objOwner, olFolderInbox)
Set tiFolder = olFolder.Folders("Information")
Set olkSnd = olItem.Sender
If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
Set olkExu = olkSnd.GetExchangeUser
GetSMTPAddress = olkExu.PrimarySmtpAddress
Else: GetSMTPAddress = olItem.SenderEmailAddress
End If
'txtEmail = Trim(olItem.Body)
'Find the next empty line of the worksheet
rCount = xlSheet.Range("C" & xlSheet.Rows.Count).End(-4162).Row + 1
'Create K number
xlSheet.UnProtect (Pass)
'On Error GoTo ERRORHANDLER
With xlSheet
Set Rng = .Range("C:C")
If Format(Date, "YYYY") = 2016 Then
If xlApp.WorksheetFunction.Max(Rng) >= 1600000 Then
NxtQuote = xlApp.WorksheetFunction.Max(Rng) + 1
Else: NxtQuote = 1600000
End If
ElseIf Format(Date, "YYYY") = 2017 Then
If xlApp.WorksheetFunction.Max(Rng) >= 1700000 Then
NxtQuote = xlApp.WorksheetFunction.Max(Rng) + 1
Else: NxtQuote = 1700000
End If
ElseIf Format(Date, "YYYY") = 2018 Then
If xlApp.WorksheetFunction.Max(Rng) >= 1800000 Then
NxtQuote = xlApp.WorksheetFunction.Max(Rng) + 1
Else: NxtQuote = 1800000
End If
ElseIf Format(Date, "YYYY") = 2019 Then
If xlApp.WorksheetFunction.Max(Rng) >= 1900000 Then
NxtQuote = xlApp.WorksheetFunction.Max(Rng) + 1
Else: NxtQuote = 1900000
End If
ElseIf Format(Date, "YYYY") = 2020 Then
If xlApp.WorksheetFunction.Max(Rng) >= 2000000 Then
NxtQuote = xlApp.WorksheetFunction.Max(Rng) + 1
Else: NxtQuote = 2000000
End If
End If
End With
'quoteID = NxtQuote 'Project ID
kNumber = "K" & NxtQuote & "-" & "TI" & "-1"
'Add K number to subject line
kItem = kNumber
txtSubject = olItem.Subject
olItem.Subject = kItem & " | " & txtSubject
xlSheet2.Range("G" & 2) = GetSMTPAddress 'Sender email address to be processed for Contact name
xlSheet2.Range("I" & 2) = GetSMTPAddress 'Sender email address to be processed for Company
start = Now
Do Until Now > start + TimeValue("0:00:01")
Loop
txtContact = xlSheet2.Range("G" & 4) 'Contact name gets assigned variable
txtCompany = xlSheet2.Range("I" & 4) 'Company gets assigned variable
xlSheet.Range("L" & rCount) = txtContact 'Contact Name
xlSheet.Range("K" & rCount) = txtCompany 'Company
xlSheet.Range("D" & rCount) = "TI" 'Category ID (TI, TA, SG, LG)
xlSheet.Range("N" & rCount) = GetSMTPAddress 'email
xlSheet.Range("E" & rCount) = "1" 'Revision
xlSheet.Range("C" & rCount) = NxtQuote 'Quote ID
xlSheet.Range("F" & rCount) = "TIG" 'Queue Type (TAG, Large Gas, Switchgear)
xlSheet.Range("G" & rCount) = "Email" 'Request Type
xlSheet.Range("H" & rCount) = "Technical Information" 'Quote Category (Generator/ATS | Tank & Enclosure | Switchgear | Large Gas | Technical Information)
xlSheet.Range("I" & rCount) = "5" 'Category Priority (1-5)
xlSheet.Range("AJ" & rCount) = "Open"
xlSheet.Range("AZ" & rCount) = "Open"
xlSheet.Range("AX" & rCount) = "Open"
xlSheet.Range("BA" & rCount) = "Open"
xlSheet.Range("BE" & rCount) = "Open"
xlSheet.Range("BG" & rCount) = "Open"
'xlSheet.Range("BI" & rCount) = txtEmail 'Email body
olItem.UnRead = True
olItem.Move tiFolder
'Date and time from time stamp
xlSheet.Range("AS" & rCount) = Format(olItem.ReceivedTime, "mm/dd/yyyy hh:mm:ss AM/PM")
xlSheet.Range("AR" & rCount) = Format(olItem.ReceivedTime, "mm/dd/yyyy")
xlSheet.Range("AT" & rCount) = "Automated" 'Created By
'ERRORHANDLER:
Excel.Application.ScreenUpdating = True
Excel.Application.DisplayAlerts = True
xlSheet.Protect (Pass)
xlWB.Save
xlWB.Close savechanges:=True
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olkSnd = Nothing
Set olkExu = Nothing
End Sub