VB.Net: DAO Object won't create DBEngine - vb.net

I'm using a dynamically created Access database as a temporary storage for a file being inputed. I know that everything works, as on my dev machine I can get this code to run. But on another system (Win 7) it's not working. I'm being stopped at this line...
DAOEngine = New DAO.DBEngine
When it gets here, it just throws an error...
Creating an instance of the COM component with CLSID {00000010-0000-0010-8000-00AA006D2EA4} from the IClassFactory failed due to the following error: 80040112.
I have searched for the error, and I can't make sense of what it's telling me other then I'm using an old way of creating databases. And right now, I was hoping for a quick fix rather then rewriting the way my storage is working.
Again, I know my code is correct because my Dev machine compiles and runs this code just fine. I'll post the entire method in case there's something else I'm missing.
Private Sub ProcessFile(ByVal Exportname As String, ByVal ExportFile As String, ByVal ImportFile As String)
' Aperture variables
Dim Table As Object 'OETable
Dim Fields As Object 'OEFields
' DAO database variables
Dim DAOEngine As DAO.DBEngine
Dim rst As DAO.Recordset
Dim ws As DAO.Workspace
Dim db As DAO.Database
Dim tbl As DAO.TableDef
Dim fld As DAO.Field
' Integer vars
Dim fieldcount As Integer
Dim I As Integer
Dim j As Integer
' Boolean Variables
Dim CalcTotals As Boolean = False
' String Array Variables
Dim headers() As String = Nothing
' String Variables
Dim lvl_lookup As String
Dim outputlist As String
Dim throwaway As String = ""
Dim totalstring As String
' Array vars
Dim totals() As Object
' Use an access database to add the serial numbers
'ws = DAODBEngine_definst.Workspaces(0)
DAOEngine = New DAO.DBEngine
ws = DAOEngine.Workspaces(0)
If File.Exists(alAperture.prjPath & "\temp.mdb") Then
File.Delete(alAperture.prjPath & "\temp.mdb")
End If
db = ws.CreateDatabase(alAperture.prjPath & "\temp.mdb", DAO.LanguageConstants.dbLangGeneral)
tbl = db.CreateTableDef("legend")
If alAperture.tbls.Item(Exportname & " Table") Is Nothing Then
Table = alAperture.tbls.Item("Legend Text Table")
Else
Table = alAperture.tbls.Item(Exportname & " Table")
End If
Fields = Table.Fields
fieldcount = Fields.Count
' Create the fields
For I = 0 To fieldcount - 1
If Fields.Item(I).DataType = 2 Then
' We have a numeric field
fld = tbl.CreateField(Fields.Item(I).Name, 6)
CalcTotals = True
Else
fld = tbl.CreateField(Fields.Item(I).Name, 10, 255)
fld.AllowZeroLength = True
End If
tbl.Fields.Append(fld)
Next
' Create the table
db.TableDefs.Append(tbl)
' Open the table as a recordset
rst = db.OpenRecordset("legend", DAO.RecordsetTypeEnum.dbOpenTable)
' Open the exportfile for read
Dim streamIn As StreamReader = New StreamReader(ExportFile)
ReDim totals(fieldcount - 1)
I = 0
lvl_lookup = ""
Do
' Grab next record and redim to dimension of table, minus the series column
Dim nextRecord() As String = Split(streamIn.ReadLine, """,""")
ReDim Preserve nextRecord(fieldcount - 1)
If I = 0 Then
headers = nextRecord
I = 1
Else
' *** HEADER RECORD
If lvl_lookup = "" Then
lvl_lookup = nextRecord(0)
' Add the header record
rst.AddNew()
rst.Fields(0).Value = lvl_lookup
rst.Fields(1).Value = 0
For j = 2 To fieldcount - 1
If rst.Fields(j).Type = 10 Then
rst.Fields(j).Value = Replace(headers(j - 1), """", "")
Else
rst.Fields(j).Value = 0
End If
Next
rst.Update()
End If
' *** RECORDS
If nextRecord(0) = lvl_lookup Then
' addrecords
addrecord(totals, nextRecord, rst, fieldcount, I)
Else
' add total row
' padlines
If CalcTotals Then
rst.AddNew()
rst.Fields(0).Value = lvl_lookup
rst.Fields(1).Value = I
totalstring = "Total:"
For j = 2 To fieldcount - 2
If rst.Fields(j).Type = 6 Then
If IsNothing(totals(j)) Then
rst.Fields(j).Value = 0
Else
rst.Fields(j).Value = totals(j)
End If
Else
rst.Fields(j).Value = totalstring
totalstring = ""
End If
Next
rst.Fields(9).Value = 0
rst.Update()
I = I + 1
End If
'padlines
While I <= 80
rst.AddNew()
rst.Fields(0).Value = lvl_lookup
rst.Fields(1).Value = I
rst.Update()
I = I + 1
End While
I = 1
lvl_lookup = nextRecord(0)
ReDim totals(fieldcount - 2)
' add record
addrecord(totals, nextRecord, rst, fieldcount, I)
End If
If streamIn.EndOfStream Then
' add total row
' padlines
If CalcTotals Then
rst.AddNew()
rst.Fields(0).Value = lvl_lookup
rst.Fields(1).Value = I
totalstring = "Total:"
For j = 2 To fieldcount - 2
If rst.Fields(j).Type = 6 Then
If IsNothing(totals(j)) Then
rst.Fields(j).Value = 0
Else
rst.Fields(j).Value = totals(j)
End If
Else
rst.Fields(j).Value = totalstring
totalstring = ""
End If
Next
rst.Fields(9).Value = 0
rst.Update()
I = I + 1
End If
'padlines
While I <= 80
rst.AddNew()
rst.Fields(0).Value = lvl_lookup
rst.Fields(1).Value = I
rst.Update()
I = I + 1
End While
End If
End If
Loop Until streamIn.EndOfStream
streamIn.Close()
' ok lets write the import file
Dim streamOut As StreamWriter = New StreamWriter(ImportFile)
rst.MoveFirst()
Do Until rst.EOF
outputlist = Chr(34) & rst.Fields(0).Value & Chr(34) & "," & Chr(34) & VB6.Format(rst.Fields(1).Value, "00") & Chr(34)
For j = 2 To fieldcount - 1
outputlist = outputlist & "," & Chr(34) & rst.Fields(j).Value & Chr(34)
Next
streamOut.WriteLine(outputlist)
rst.MoveNext()
Loop
streamOut.Close()
rst.Close()
db.Close()
ws.Close()
rst = Nothing
db = Nothing
ws = Nothing
fld = Nothing
tbl = Nothing
Table = Nothing
Fields = Nothing
End Sub

Are you using Microsoft DAO 3.6? Using 'Microsoft DAO 2.5/3.51 Compatibility Library' is very old. DAO 3.5 is the version which comes with Access 97.
Later I should've done a search on the GUID in the error message. Yes, that GUID is for DAO 3.5 which is very old and comes with Access 97 and Visual Basic 6. Use DAO 3.6/Jet 4.0 which comes with Weindows 2000 and newer OSs.
From PRB: CLSID {00000010-0000-0010-8000-00AA006D2EA4} Not Found When You Run an Application "The {00000010-0000-0010-8000-00AA006D2EA4} CLSID is associated with DAO350.dll."

Related

How to Solve "Out of Memory" when applying InStr to Japanese characters?

When I process emails in a folder I get "Out of Memory" error.
Searching online I see many suggests to clear the memory, so I added code like below:
Set objItem = Nothing
Set objMailItem = Nothing
Redim arrLines(0)
Option Explicit
Private Sub btnStart_Click()
Dim StartDate As Date
Dim EndDate As Date
StartDate = DateValue("October 1, 2015")
EndDate = DateValue("January 28, 2023")
Call ProcessOrderEmails(StartDate, EndDate)
End Sub
Sub ProcessOrderEmails(StartDate As Date, EndDate As Date)
Dim objCurFolder As Folder
Dim objItem As Object
Dim objMailItem As MailItem
Dim nCSVFileNum As Integer
' Create the CSV file
nCSVFileNum = FreeFile
If Dir("E:\Temp\OrderStat.csv") <> "" Then
Kill ("E:\Temp\OrderStat.csv")
End If
Open "E:\Temp\OrderStat.csv" For Output Lock Write As #nCSVFileNum
' Get statistics
Set objCurFolder = Application.ActiveExplorer.CurrentFolder
For Each objItem In objCurFolder.Items
If TypeOf objItem Is MailItem Then
Set objMailItem = objItem
' Check if the mail is in the date range
If (objMailItem.SentOn >= StartDate) And (objMailItem.SentOn <= EndDate) Then
Select Case objMailItem.SenderEmailAddress
Case "automated#mycommerce.com"
Print #nCSVFileNum, ProcessRegNowOrderEmail(objMailItem)
End Select
End If
End If
' Set objItem to nothing to free memory
Set objItem = Nothing
Set objMailItem = Nothing
Next
' Close the file
Close nCSVFileNum
End Sub
Private Function ReplaceNewLine(strText As String, strNewLine As String) As String
ReplaceNewLine = Replace(strText, vbCrLf, strNewLine)
ReplaceNewLine = Replace(ReplaceNewLine, vbCr, strNewLine)
ReplaceNewLine = Replace(ReplaceNewLine, vbLf, strNewLine)
End Function
Private Function SplitLines(strText As String) As Variant
SplitLines = Split(ReplaceNewLine(strText, vbNewLine), vbNewLine)
End Function
' strEntryName should include :, like this RegNow OrderItemID:
Private Function GetEntryValue(strEntryLine As String, strEntryName As String, ByRef strEntryValue) As Boolean
Dim strLine As String
' Initialize result to False by default
GetEntryValue = False
' Parse the line
strLine = ReplaceNewLine(Trim(strEntryLine), "")
If InStr(1, strLine, strEntryName, vbTextCompare) > 0 Then
strEntryValue = Trim(Replace(strLine, strEntryName, "", 1, -1, vbTextCompare))
GetEntryValue = True
End If
End Function
Private Function ProcessRegNowOrderEmail(objMailItem As MailItem) As String
Dim arrLines() As String
Dim strLine As String
Dim strOrderID As String
Dim strProduct As String
Dim strProfit As String
Dim I As Integer
arrLines = SplitLines(objMailItem.Body)
For I = LBound(arrLines, 1) To UBound(arrLines, 1)
Call GetEntryValue(arrLines(I), "RegNow OrderItemID:", strOrderID)
Call GetEntryValue(arrLines(I), "Product Name:", strProduct)
Call GetEntryValue(arrLines(I), "Profit:", strProfit)
Next I
ProcessRegNowOrderEmail = "RegNow," & strOrderID & "," & strProduct & "," & strProfit
ReDim arrLines(0)
End Function
Sample email to be processed:
********** DO NOT REPLY TO THIS EMAIL **********
*** Transaction Identification ***
Date: 2017-03-14 02:14:14 (Pacific Standard Time)
RegNow OrderID: XXXXXX-XXXXX
RegNow OrderItemID: XXXXXX-XXXXX
*** Gift Information ***
Gift: no
Pickup: no
*** Product Information ***
Item #: #####-#
Product Name: My Product
Quantity: 1
Tax: 0.00 USD
Total: 199.95 USD
Profit: 189.15
The error is caused by the following line:
If InStr(1, strLine, strEntryName, vbTextCompare) > 0 Then
when strLine contains Japanese characters:
Address2: パティオたまプラーザ308
Searching online, I find similar posts:
[VBA][excel] Occurred error When Using 'Japanese - Katakana' in 'inStr'
https://social.msdn.microsoft.com/Forums/en-US/06df9b54-ad75-4c18-9577-84e52b6e03a1/how-can-i-use-the-japanese-for-instr-vba-?forum=exceldev
It is difficult to see how labels you are not interested in are processed.
This code will process specified labels only.
Option Explicit
Function ParseTextLinePair(strSource As String, strLabel As String)
' https://learn.microsoft.com/en-us/previous-versions/office/developer/office-2007/dd492012(v=office.12)
Dim intLocLabel As Integer
Dim intLocCRLF As Integer
Dim intLenLabel As Integer
Dim strText As String
' locate the label in the source text
intLocLabel = InStr(strSource, strLabel)
intLenLabel = Len(strLabel)
If intLocLabel > 0 Then
intLocCRLF = InStr(intLocLabel, strSource, vbCrLf)
If intLocCRLF > 0 Then
intLocLabel = intLocLabel + intLenLabel
strText = Mid(strSource, intLocLabel, intLocCRLF - intLocLabel)
Else
intLocLabel = Mid(strSource, intLocLabel + intLenLabel)
End If
End If
ParseTextLinePair = Trim(strText)
End Function
Private Function ProcessRegNowOrderEmail_Label(objMailItem As MailItem) As String
Dim strOrderID As String
Dim strProduct As String
Dim strProfit As String
strOrderID = ParseTextLinePair(objMailItem.body, "RegNow OrderItemID:")
strProduct = ParseTextLinePair(objMailItem.body, "Product Name:")
strProfit = ParseTextLinePair(objMailItem.body, "Profit:")
ProcessRegNowOrderEmail_Label = "RegNow," & strOrderID & "," & strProduct & "," & strProfit
End Function
Replace
Print #nCSVFileNum, ProcessRegNowOrderEmail(objMailItem)
with
Print #nCSVFileNum, ProcessRegNowOrderEmail_Label(objMailItem)
Apparently memory allocated to objItem in a For Each cannot be freed.
Change to an indexed For Next so there is no objItem.
Sub ProcessOrderEmails(StartDate As Date, EndDate As Date)
Dim objCurFolder As Folder
Dim objMailItem As MailItem
Dim nCSVFileNum As Integer
' Create the CSV file
nCSVFileNum = FreeFile
If dir("E:\Temp\OrderStat.csv") <> "" Then
Kill ("E:\Temp\OrderStat.csv")
End If
Open "E:\Temp\OrderStat.csv" For Output Lock Write As #nCSVFileNum
' Get statistics
Set objCurFolder = Application.ActiveExplorer.currentFolder
Dim curFolderItems As Items
Set curFolderItems = objCurFolder.Items
Dim curFolderItemsCount As Long
curFolderItemsCount = curFolderItems.count
Dim i As Long
For i = 1 To curFolderItemsCount
If TypeOf curFolderItems(i) Is MailItem Then
Set objMailItem = curFolderItems(i)
With objMailItem
' Check if the mail is in the date range
If (.SentOn >= StartDate) And (.SentOn <= EndDate) Then
Select Case .senderEmailAddress
Case "automated#mycommerce.com"
Print #nCSVFileNum, ProcessRegNowOrderEmail(objMailItem)
End Select
End If
End With
' free memory
Set objMailItem = Nothing
End If
Next
' Close the file
Close nCSVFileNum
End Sub
Appears there is something else involved. With your original code using objItem I can generate a file with over 30,000 entries.
Unlikely this will be any better but rather than assigning objMailItem, you could use curFolderItems(i) directly.
Sub ProcessOrderEmails(StartDate As Date, EndDate As Date)
Dim objCurFolder As Folder
Dim nCSVFileNum As Integer
Dim pathFile As String
pathFile = "E:\Temp\OrderStat.csv"
' Create the CSV file
nCSVFileNum = FreeFile
Debug.Print nCSVFileNum
If dir(pathFile) <> "" Then
Kill pathFile
End If
Open pathFile For Output Lock Write As #nCSVFileNum
' Get statistics
Set objCurFolder = Application.ActiveExplorer.currentFolder
Dim curFolderItems As Items
Set curFolderItems = objCurFolder.Items
Dim curFolderItemsCount As Long
curFolderItemsCount = curFolderItems.count
Dim i As Long
Dim j As Long
' for testing the limit
'For j = 1 To Int(1000 / curFolderItemsCount) + 1
For i = 1 To curFolderItemsCount
If TypeOf curFolderItems(i) Is MailItem Then
Dim n As Long
n = n + 1
Debug.Print n
With curFolderItems(i)
' Check if the mail is in the date range
If (.SentOn >= StartDate) And (.SentOn <= EndDate) Then
'Select Case .senderEmailAddress
'Case "automated#mycommerce.com"
Print #nCSVFileNum, ProcessRegNowOrderEmail(curFolderItems(i))
'End Select
End If
End With
End If
Next
'Next
' Close the file
Close nCSVFileNum
End Sub
After testing for several times, I find out
For Japanese characters in TextBox1.Text, call InStr with vbTextCompare will cause "Out of memory":
nPos = InStr(1, TextBox1.Text, "Address2", vbTextCompare)
But with vbBinaryCompare, everything is fine:
nPos = InStr(TextBox1.Text, "Address2")
nPos = InStr(1, TextBox1.Text, "Address2")
nPos = InStr(1, TextBox1.Text, "Address2", vbBinaryCompare)
Thanks to all of your great helps!

How to find desired field at SAPGUI using VBA

I've recently found out the way below to select the desired TAB (when within a sales order, for instance).
For T = 0 To 15
If Len(T) = 1 Then T = "0" & T
If SapSession.findById("wnd[0]/usr/tabsTAXI_TABSTRIP_HEAD/tabpT\" & T).Text = "Sales" Then
SapSession.findById("wnd[0]/usr/tabsTAXI_TABSTRIP_HEAD/tabpT\" & T).Select
Exit For
End If
Next T
I am looking now for a similar way to loop through the fields in the current active window in order to select (setfocus) on a specific field.
Is it possible?
I found this piece of code at SAP community site and it works fine.
Sub ScanFields(Area As Object, Application As SAPFEWSELib.GuiApplication)
Dim Children As Object
Dim i As Integer
Dim Obj As Object
Dim ObjChildren As Object
Dim NextArea As Object
Set Children = Area.Children()
For i = 0 To Children.Count() - 1
Set Obj = Children(CInt(i))
'If Obj.Type = "GuiTextField" Then 'If Obj.Name = "MyField" Then 'Obj.SetFocus
Debug.Print Obj.Name & " " & Obj.Type & " " & Obj.Text
If Obj.ContainerType() = True Then
Set ObjChildren = Obj.Children()
If ObjChildren.Count() > 0 Then
Set NextArea = Application.FindById(Obj.ID)
ScanFields NextArea, Application
Set NextArea = Nothing
End If
End If
Next i
Set Children = Nothing
End Sub
Sub Test()
Dim SapGuiAuto As Object
Dim Application As SAPFEWSELib.GuiApplication
Dim Connection As SAPFEWSELib.GuiConnection
Dim Session As SAPFEWSELib.GuiSession
Dim UserArea As SAPFEWSELib.GuiUserArea
Set SapGuiAuto = GetObject("SAPGUI")
If Not IsObject(SapGuiAuto) Then
Exit Sub
End If
Set Application = SapGuiAuto.GetScriptingEngine()
If Not IsObject(Application) Then
Exit Sub
End If
Set Connection = Application.Connections(0)
If Not IsObject(Connection) Then
Exit Sub
End If
Set Session = Connection.Sessions(0)
If Not IsObject(Session) Then
Exit Sub
End If
'-Get the user area and scan it recursively-----------------------
Set UserArea = Session.FindById("wnd[0]/usr")
ScanFields UserArea, Application
Set UserArea = Nothing
End Sub

Read a CSV file and list of folders and then compare in VB

What I am trying to achieve is I currently have a (main) folder filled with many Sub-folders and these sometimes get drag & dropped into another Sub-folder by accident.
I have an CSV file containing all the names of the current (main) folder list as it should stand and I want to check this against the current version of Sub-folders found in the (main) folder and output a message box with the results of matching files and missing files.
This is the code I have got so far although I am unsure how to check the list of folders against the CSV file.
Read data from an CSV file.
'Holds Data from CSV file
Dim arrValue As String()
'create a new TextFieldParser and opens the file
Using MyReader As New Microsoft.VisualBasic.FileIO.TextFieldParser("C:\Users\USERNAME\Dropbox (Personal)\IT\jobs.csv")
'Define the TextField type and delimiter
MyReader.TextFieldType = FileIO.FieldType.Delimited
MyReader.SetDelimiters(",")
While Not MyReader.EndOfData
Dim arrCurrentRow As String() = MyReader.ReadFields()
If arrValue Is Nothing Then
ReDim Preserve arrValue(0)
arrValue(0) = arrCurrentRow(0)
Else
ReDim Preserve arrValue(arrValue.Length)
arrValue((arrValue.Length - 1)) = arrCurrentRow(0)
End If
End While
Read list of folders
'check against the Clients folder
Set w = WScript.CreateObject("WScript.Shell")
w.Popup ShowFolders("C:\Users\USERNAME\Dropbox (Innovation PS)\Clients")
Function ShowFolders(folderName)
'Setting Variables
Dim fs, f, f1, fc, s
'holds folder name
s = ""
'Obtain folder Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderName)
'Obtain SubFolders collection within folder
Set fc = f.SubFolders
'Examine each item in the collection
For Each f1 in fc
s = s & f1.name
s = s & (Chr(13) & Chr(10)) ' Chr(13) & Chr(10) = Carriage return–linefeed combination
Next
ShowFolders = s
End Function
'See if it matches the .CSV file
Thank you in advance. (Also if you could include comments it would be appreciated)
Run this script to get a base line, it wil create a spreadsheet of the folders files and properties, Then runt it again copy the sheet in to the baseline work bbok and do a vlookup. You could also use this as a base line to create a csv and compare the it that way. Not exactly waht you are looking for but it is a workable solution
Const ForReading = 1, ForWriting = 2, Forappending = 8
'Option Explicit
'DIM Objects
'Dim variabbles
Dim folderspec
'Dim
DIM arrBlk(3)
DIM arrFLN(3)
DIM arrInfo(3)
Set objXL = Wscript.CreateObject("Excel.Application")
Set ofso = CreateObject("Scripting.FileSystemObject")
folderspec = InputBox("Please enter the path", "FileList", " ")
If folderspec = "" Then
' if cancel is selected quit the program
wscript.quit
ElseIf folderspec = " " Then
' if nothing is entered give a warning message ang quit the program
msgbox "No Directory has been seleted " & vbCrLf
wscript.quit
End If
intRow = 2
buildsheet() 'Build the XLS spreadsheet
'folderspec ="C:\_epas_5.0\Web_Server\ASP"
'folderspec ="C:\_epas_5.0\Web_Server\COM+ Source"
strFldrCmp = folderspec
Set root = ofso.GetFolder(folderspec)
ShowFileList(root)
For Each oFolder in root.subfolders
walkfolder oFolder
Next
Sub walkfolder(f)
ShowFileList(f)
For Each sf in f.subfolders
walkfolder sf
Next
End Sub
Function ShowFileList(folderspec)
Dim oFolder
Dim oFiles
Dim oFile
Set oFolder = ofso.GetFolder(folderspec)
' Wscript.echo oFolder.name
Set oFiles = oFolder.Files
' If IsEmpty(oFiles) Then Wscript.echo oFolder.name
'i = 0
For Each oFile in oFiles
i = 1 + i
'If i < 1 Then
'Wscript.echo oFolder.name,i
'End If
Next
If i < 1 Then
Wscript.echo oFolder.name & " Null"
ReDim arrB(3)
'strPath = Replace(oFolder.path,strFldrCmp,"", 1 ,1 ,vbTextCompare)
arrB(0) = "\" & Trim(oFolder.Name) 'oFolder.path
arrB(1) = ""
arrB(2) = ""
arrB(3) = ""
AddLineToXLS(arrB)
End If
For Each oFile in oFiles
ReDim arrB(3)
srtfldr = oFolder.path
' MsgBox srtfldr& " " & strFldrCmp
'strPath = Replace(srtfldr,strFldrCmp,"", 1 ,1 ,vbTextCompare)
strPath = Replace(oFolder.path,strFldrCmp,"", 1 ,1 ,vbTextCompare)
'strPath = Replace("C:\_5Test\Web_Server\ASP\app\admin","C:\_5Test\Web_Server\ASP","",,,vbTestCompare)
arrB(0) = Trim(strPath) 'oFolder.path
arrB(1) = Trim(oFile.name)
arrB(2) = Trim(oFile.Size)
arrB(3) = Trim(oFile.DateLastModified)
If LCase(ofso.GetExtensionName(oFile)) <> "scc" Then 'skip VSS .scc files
AddLineToXLS(arrB)
End If
Next
End Function
Function buildsheet
intRow = 1
objXL.Visible = True
objXL.WorkBooks.Add
'** Set Row Height
objXL.Rows(1).RowHeight = 17
'** Set Column widths
objXL.Columns(1).ColumnWidth = 40.14
objXL.Columns(2).ColumnWidth = 33.14
objXL.Columns(3).ColumnWidth = 15
objXL.Columns(4).ColumnWidth = 23
objXL.Columns(5).ColumnWidth = 23
objXL.Columns(6).ColumnWidth = 23
'** Set Cell Format for Column Titles ***
objXL.Range("A1:F1").Select
objXL.Selection.Font.Bold = True
' objXL.Selection.Font.Size = 8
objXL.Selection.Interior.ColorIndex = 15
objXL.Selection.Interior.Pattern = 1 'xlSolid
objXL.Selection.Font.ColorIndex = 1
objXL.Selection.WrapText = True
objXL.Columns("A:T").Select
objXL.Columns.Font.Size = 8
objXL.Selection.HorizontalAlignment = 1 'xlCenter
objXL.Columns("C:C").Select
objXL.Selection.NumberFormat = "#,###0"
objXL.Columns("D:D").Select
objXL.Selection.NumberFormat = "m/d/yy h:mm AM/PM"
'*** Set Column Titles ***
Dim arrA(3)
arrA(0)= "File Path"
arrA(1) = "File Name"
arrA(2) = "Size(bytes)"
arrA(3) = "Modified Date/Time"
AddLineToXLS(arrA)
End Function
Function AddLineToXLS(r)' Writes a line to the spreadsheet recieves an array as input
objXL.Cells(intRow, 1).Value = r(0)
objXL.Cells(intRow, 2).Value = r(1)
objXL.Cells(intRow, 3).Value = r(2)
objXL.Cells(intRow, 4).Value = r(3)
' MsgBox r(3)
'objXL.Cells(intRow, 5).Value = r(4)
'objXL.Cells(intRow, 6).Value = r(5)
' objXL.Cells(intRow, 4).Value = r(3)
intRow = intRow + 1
objXL.Cells(1, 1).Select
End Function

vba outlook: get emails and export to excel and save attachments

I have tried to put together a piece of vba code which does the following.
first it looks for all emails in my inbox folder for the account NewSuppliers#Hewden.co.uk where the subject contains certain key words.
Secondly it looks for all emails in my inbox folder CreditChecks#Hewden.co.uk where the subject contains certain keywords.
Then it exports certain data into excel row after row.
This works fine except with my emails which I export from the CreditChecks#Hewden.co.uk inbox, I want to export only the emails which contains a pdf attachment and save this attachment in a directory and place each seperate pdf document in a folder with the same name as the pdf file.
I've tested my save attachment and export emails scripts separate and they work fine but when I put them together I get an error saying
method or object not found
Set objAttachments = Outlook.Attachments
Can someone please help me get my code to do what I need it to do? Thanks in advance
Here is my code:
'On the next line edit the path to the spreadsheet you want to export to
Const WORKBOOK_PATH = "X:\New_Supplier_Set_Ups_&_Audits\NewSupplierSet-Up.xls"
'On the next line edit the name of the sheet you want to export to
Const SHEET_NAME = "Validations"
Const SHEET_NAME2 = "BankSetup"
Const SHEET_NAME3 = "CreditChecks"
Const MACRO_NAME = "Export Messages to Excel (Rev 7)"
Private Sub Application_Startup()
Dim olkMsg As Object, _
olkMsg2 As Object, _
excApp As Object, _
excWkb As Object, _
excWks As Object, _
excWks2 As Object, _
excWks3 As Object, _
intRow As Integer, _
intRow2 As Integer, _
intRow3 As Integer, _
intExp As Integer, _
intVersion As Integer
intVersion = GetOutlookVersion()
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Open(WORKBOOK_PATH)
Set excWks = excWkb.Worksheets(SHEET_NAME)
Set excWks2 = excWkb.Worksheets(SHEET_NAME2)
Set excWks3 = excWkb.Worksheets(SHEET_NAME3)
intRow = excWks.UsedRange.Rows.Count + 1
intRow2 = excWks2.UsedRange.Rows.Count + 1
intRow3 = excWks3.UsedRange.Rows.Count + 1
'Write messages to spreadsheet
Dim ns As Outlook.NameSpace
Dim Items As Outlook.Items
Dim Items2 As Outlook.Items
Dim objAttachments As Outlook.Attachments
Dim objMsg As Outlook.MailItem 'Object
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderPath As String
Dim strDeletedFiles As String
Dim withParts As String
Dim withoutParts As String
' Get the MAPI Namespace
Set ns = Application.GetNamespace("MAPI")
' Get the Items for the Inbox in the specified account
Set Items = ns.Folders("New Suppliers").Folders("Inbox").Items
Set Items2 = ns.Folders("Credit Checks").Folders("Inbox").Items
Set objAttachments = Outlook.Attachments
' Start looping through the items
For Each olkMsg In Items
'Only export messages, not receipts or appointment requests, etc.
If olkMsg.class = olMail Then
If olkMsg.Subject Like "Accept: New Supplier Request*" Or olkMsg.Subject Like "Reject: New Supplier Request*" Then
'Add a row for each field in the message you want to export
excWks.Cells(intRow, 1) = olkMsg.ReceivedTime
Dim LResult As String
LResult = Replace(GetSMTPAddress(olkMsg, intVersion), ".", " ")
LResult = Left(LResult, InStrRev(LResult, "#") - 1)
excWks.Cells(intRow, 2) = LResult
excWks.Cells(intRow, 3) = olkMsg.VotingResponse
Dim s As String
s = olkMsg.Subject
Dim indexOfName As Integer
indexOfName = InStr(1, s, "Reference: ")
Dim finalString As String
finalString = Right(s, Len(s) - indexOfName - 10)
excWks.Cells(intRow, 4) = finalString
intRow = intRow + 1
End If
End If
If olkMsg.class = olMail Then
If olkMsg.Subject Like "Complete: Bank Details Set-Up for New Supplier*" Or olkMsg.Subject Like "Incomplete: Bank Details Set-Up for New Supplier*" Then
'Add a row for each field in the message you want to export
excWks2.Cells(intRow2, 1) = olkMsg.ReceivedTime
Dim LResult2 As String
LResult2 = Replace(GetSMTPAddress(olkMsg, intVersion), ".", " ")
LResult2 = Left(LResult2, InStrRev(LResult2, "#") - 1)
excWks2.Cells(intRow2, 2) = LResult2
excWks2.Cells(intRow2, 3) = olkMsg.VotingResponse
Dim s2 As String
s2 = olkMsg.Subject
Dim indexOfName2 As Integer
indexOfName2 = InStr(1, s2, "Reference: ")
Dim finalString2 As String
finalString2 = Right(s2, Len(s2) - indexOfName2 - 10)
excWks2.Cells(intRow2, 4) = finalString2
intRow2 = intRow2 + 1
End If
End If
Next
strFolderPath = "\\UKSH000-FILE06\Purchasing\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\"
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
For Each olkMsg2 In Items2
If olkMsg2.class = olMail Then
If olkMsg2.Subject Like "RE: New Supplier Credit*" Then
If lngCount > 0 Then
For i = lngCount To 1 Step -1
strFile = objAttachments.item(i).FileName
If Right(strFile, 3) = "pdf" Then
' Combine with the path to the Temp folder.
withParts = strFile
withoutParts = Replace(withParts, ".pdf", "")
strFile = strFolderPath & withoutParts & "\" & strFile
' Save the attachment as a file.
objAttachments.item(i).SaveAsFile strFile
'Add a row for each field in the message you want to export
excWks3.Cells(intRow3, 1) = olkMsg2.ReceivedTime
Dim LResult3 As String
LResult3 = Replace(GetSMTPAddress(olkMsg2, intVersion), ".", " ")
LResult3 = Left(LResult3, InStrRev(LResult3, "#") - 1)
excWks3.Cells(intRow3, 2) = LResult3
excWks3.Cells(intRow3, 3) = "Complete"
excWks3.Cells(intRow3, 4) = "File Attached"
Dim s3 As String
s3 = olkMsg2.Subject
Dim indexOfName3 As Integer
indexOfName3 = InStr(1, s3, "Reference: ")
Dim finalString3 As String
finalString3 = Right(s3, Len(s3) - indexOfName3 - 10)
excWks3.Cells(intRow3, 5) = finalString3
excWks3.Cells(intRow3, 6) = "File Path"
intRow3 = intRow3 + 1
End If
Next i
End If
End If
End If
Next
Set olkMsg = Nothing
Set olkMsg2 = Nothing
excWkb.Close True
Set excWks = Nothing
Set excWks2 = Nothing
Set excWks3 = Nothing
Set excWkb = Nothing
Set excApp = Nothing
On Error GoTo ErrHandle
ErrHandle:
Resume Next
End Sub
Private Function GetSMTPAddress(item As Outlook.MailItem, intOutlookVersion As Integer) As String
Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
On Error Resume Next
Select Case intOutlookVersion
Case Is < 14
If item.SenderEmailType = "EX" Then
GetSMTPAddress = SMTP2007(item)
Else
GetSMTPAddress = item.SenderEmailAddress
End If
Case Else
Set olkSnd = item.Sender
If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
Set olkEnt = olkSnd.GetExchangeUser
GetSMTPAddress = olkEnt.PrimarySmtpAddress
Else
GetSMTPAddress = item.SenderEmailAddress
End If
End Select
On Error GoTo 0
Set olkPrp = Nothing
Set olkSnd = Nothing
Set olkEnt = Nothing
End Function
Function GetOutlookVersion() As Integer
Dim arrVer As Variant
arrVer = Split(Outlook.Version, ".")
GetOutlookVersion = arrVer(0)
End Function
Function SMTP2007(olkMsg As Outlook.MailItem) As String
Dim olkPA As Outlook.PropertyAccessor
On Error Resume Next
Set olkPA = olkMsg.PropertyAccessor
SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
On Error GoTo 0
Set olkPA = Nothing
End Function
Set objAttachments = Outlook.Attachments is not the correct syntax.
Just remove the line as you have this later.
Set objAttachments = objMsg.Attachments

Exporting Data To Multiple Excel Sheets

I'm Using following code to export my listview to Excelsheet but the problem is i have multiple listviews which i have to export in different sheets in same excel file . . . . .
Dim flnameSaveAs As String = System.IO.Path.GetFileName(Main.spath1)
'Save Files name
Dim extension As String
extension = Path.GetExtension(Main.spath1)
Dim file As String = System.IO.Path.GetFileName(Main.spath1)
Dim FinenameA As String = System.IO.Path.GetDirectoryName(Main.spath1)
Dim savnames As String
savnames = file.Substring(0, Len(file) - Len(extension))
Dim ExportSheet As String
ExportSheet = deskPath + "\Cel_ID_TimeLine.txt"
Dim lvi As ListViewItem
Dim sb As New System.Text.StringBuilder
Dim sbhd As New System.Text.StringBuilder
Dim columns As Integer = lvCidTimeLine.Columns.Count
For ixhd As Integer = 0 To lvCidTimeLine.Columns.Count - 1
sbhd.Append(lvCidTimeLine.Columns(ixhd).Text)
sbhd.Append(vbTab)
Next
sb.Append(vbCrLf)
For Each lvi In lvCidTimeLine.Items
For ix As Integer = 0 To lvi.SubItems.Count - 1
sb.Append(lvi.SubItems(ix).Text)
If ix < lvi.SubItems.Count - 1 Then
sb.Append(vbTab)
Else
sb.Append(vbCrLf)
End If
Next
Next
Dim sw As New StreamWriter(ExportSheet)
sw.Write(sbhd.ToString)
sw.Write(sb.ToString)
sw.Close()
Dim oExcel As Excel.Application
' Create the spreadsheet
oExcel = CreateObject("Excel.Application")
oExcel.Workbooks.OpenText(ExportSheet, , , , -4142, , True)
oExcel.Cells.EntireColumn.AutoFit()
oExcel.ActiveWorkbook.SaveAs(savpath + "\" + savnames + ".xls", -4143)
oExcel.Quit()
oExcel = Nothing
So do you have any idea how to add another sheet and export another listview to it ??
Try This Code Instead
Try
Dim objExcel As New Excel.Application
Dim bkWorkBook As Excel.Workbook
Dim shWorkSheet As Excel.Worksheet
Dim shWorkSheet1 As Excel.Worksheet
Dim i As Integer
Dim j As Integer
objExcel = New Excel.Application
bkWorkBook = objExcel.Workbooks.Add
shWorkSheet = CType(bkWorkBook.ActiveSheet, Excel.Worksheet)
For i = 0 To lv1.Columns.Count - 1
shWorkSheet.Cells(1, i + 1) = lv1.Columns(i).Text
Next
For i = 0 To lv1.Items.Count - 1
For j = 0 To lv1.Items(i).SubItems.Count - 1
shWorkSheet.Cells(i + 2, j + 1) = lv1.Items(i).SubItems(j).Text
Next
Next
shWorkSheet1 = bkWorkBook.Worksheets.Add(, shWorkSheet, , )
For i = 0 To lv2.Columns.Count - 1
shWorkSheet1.Cells(1, i + 1) = lv2.Columns(i).Text
Next
For i = 0 To lv2.Items.Count - 1
For j = 0 To lv2.Items(i).SubItems.Count - 1
shWorkSheet1.Cells(i + 2, j + 1) = lv2.Items(i).SubItems(j).Text
Next
Next
objExcel.Visible = False
objExcel.Application.DisplayAlerts = False
objExcel.ActiveWorkbook.SaveAs(savpath + "\" + savnames + "_1" + ".xls", -4143)
objExcel.Quit()
objExcel = Nothing
Catch ex As Exception
MsgBox(ex.ToString)
End Try
Dim proc As System.Diagnostics.Process
For Each proc In System.Diagnostics.Process.GetProcessesByName("EXCEL")
proc.Kill()
Next
You need to ADD to the sheets collection. Interop Excel Sheets