MS access VBA Field.Properties.Append method fails - vba

I have a form that creates a table. Everything works fine except for one point.
I want one field of the created table to appear as a combobox, so I have to change its DisplayControl property to acComboBox.
As far as I know, the property firstly has to exist. If not, then you have to create it and then append it to the collection.
The problem is that when it comes to append the property it throws a Run-time error '3219': Invalid operation..
Here is the code to this point:
Private Sub bInsert_Click()
Dim accApp As Access.Application
Dim DB As DAO.Database
Dim tbl As DAO.TableDef
Dim fld As DAO.Field
Dim indx As DAO.Index
Dim rst As DAO.Recordset
Dim i As Integer, iFields As Integer
Dim sForm As String, str As String
Dim frm As Access.Form
Dim sCtrl() As String
If Not Application.IsCompiled Then _
Application.RunCommand acCmdCompileAndSaveAllModules
'there is a subform for the fields:
Set rst = Me.subfFields.Form.Recordset
rst.MoveFirst
'completion check:
If IsNull(Me.tName) Then
MsgBox "Insert table name."
Exit Sub
ElseIf rst.AbsolutePosition = -1 Then
MsgBox "Insert at least one field."
Exit Sub
End If
'create a db that will use later:
If Dir(Me.tDB) = "" Then
Set accApp = New Access.Application
accApp.NewCurrentDatabase Me.tDB
accApp.Quit
Set accApp = Nothing
End If
'create Table:
Set DB = Application.CurrentDb
Set tbl = DB.CreateTableDef(Me.tName)
'ID as PK:
Set fld = tbl.CreateField("ID", dbLong)
fld.Attributes = dbAutoIncrField
tbl.Fields.Append fld
Set indx = tbl.CreateIndex("IDindex")
indx.Primary = True
Set fld = indx.CreateField("ID")
indx.Fields.Append fld
tbl.Indexes.Append indx
Set indx = Nothing
Set fld = Nothing
'add rest of the fields:
Do Until rst.EOF
i = Me.subfFields.Form!cType
If i = dbText Then
Set fld = tbl.CreateField(Me.subfFields.Form!tName, i, Nz(Me.subfFields.Form!tSize, 255))
Else
Set fld = tbl.CreateField(Me.subfFields.Form!tName, i)
End If
tbl.Fields.Append fld
If Me.subfFields.Form!cControl = 111 Then
SetDAOProperty fld, "DisplayControl", dbInteger, acComboBox
End If
rst.MoveNext
Loop
End Sub
Sub SetDAOProperty(WhichObject As Field, PropertyName As String, PropertyType As Integer, PropertyValue As Variant)
Dim prp As DAO.Property
On Error GoTo ErrorHandler
WhichObject.Properties(PropertyName) = PropertyValue
WhichObject.Properties.Refresh
Cleanup:
Set prp = Nothing
Exit Sub
ErrorHandler:
Select Case Err.Number
Case 3270 ' "Property not found"
Set prp = WhichObject.CreateProperty(PropertyName, PropertyType, PropertyValue)
'=====================================
'the next line throws the error:
'=====================================
WhichObject.Properties.Append prp
WhichObject.Properties.Refresh
Case Else
MsgBox Err.Number & ": " & Err.Description
End Select
Resume Cleanup
End Sub
Can someone explain what is the problem please? Seems like I'm missing something. Is there some kind of syntax error? My native language isn't English.

So as June7 suggested, appending firstly the table and then modifing the field's properties, worked fine.
Here is the final code in case someone needs it:
'create Table:
Set DB = Application.CurrentDb
Set tbl = DB.CreateTableDef(Me.tName)
'ID as PK:
Set fld = tbl.CreateField("ID", dbLong)
fld.Attributes = dbAutoIncrField
tbl.Fields.Append fld
Set indx = tbl.CreateIndex("IDindex")
indx.Primary = True
Set fld = indx.CreateField("ID")
indx.Fields.Append fld
tbl.Indexes.Append indx
Set indx = Nothing
Set fld = Nothing
'add rest of the fields:
Do Until rst.EOF
i = Me.subfFields.Form!cType
If i = dbText Then
Set fld = tbl.CreateField(Me.subfFields.Form!tName, i, Nz(Me.subfFields.Form!tSize, 255))
Else
Set fld = tbl.CreateField(Me.subfFields.Form!tName, i)
End If
tbl.Fields.Append fld
If Me.subfFields.Form!cControl = 111 Then
SetDAOProperty fld, "DisplayControl", dbInteger, acComboBox
End If
rst.MoveNext
Loop
'append table:
DB.TableDefs.Append tbl
'format comboboxes:
rst.MoveFirst
Do Until rst.EOF
If Me.subfFields.Form!cControl = 111 Then
Set fld = tbl.Fields(Me.subfFields.Form!tName)
SetDAOProperty fld, "DisplayControl", dbInteger, acComboBox
SetDAOProperty fld, "RowSourceType", dbText, "Value List"
SetDAOProperty fld, "RowSource", dbText, "Test1;Test2"
SetDAOProperty fld, "ColumnCount", dbInteger, 2
SetDAOProperty fld, "ColumnWidths", dbText, "0;1"
SetDAOProperty fld, "ListRows", dbInteger, 4
SetDAOProperty fld, "LimitToList", dbBoolean, -1
SetDAOProperty fld, "AllowValueListEdits", dbBoolean, 0
SetDAOProperty fld, "ShowOnlyRowSourceValues", dbBoolean, -1
End If
rst.MoveNext
Loop
This answer may be similar to this, but is not a duplicate. The goal is similar but the problem faced(error) is different.

Related

Copying records in Access VBA

I'm attempting to build a process where you click the EndofDay button which will then go into the subform look for any status of 10 (In Process) and then copy those records before auto completing them. The problem I'm having is getting my
DoCmd.DoMenuItem acFormBar, acEditMenu, 8, , acMenuVer70DoCmd.DoMenuItem acFormBar, acEditMenu, 8, , acMenuVer70 ... command set to work properly. I get an error message saying "The action or command "Copy" isn't available now".
The main form is "frmTasks" and the subform is called "Tasks" and the table that "Tasks" uses is called "tblTasks".
UPDATE:
I've found if I try to run my original code within the sub form Tasks by itself the code will copy without the "Copy is unavailable" message. If I try to call that code from the main form I get the copy is unavailable again. I'm not sure why it is saying the function copy is unavailable. Any clue as to why?
Private Sub EndofDay_Click()
If Me.Tasks.Form.Status = 10 Then
'Copy In Process Tasks
DoCmd.DoMenuItem acFormBar, acEditMenu, 8, , acMenuVer70
DoCmd.DoMenuItem acFormBar, acEditMenu, 2, , acMenuVer70
DoCmd.DoMenuItem acFormBar, acEditMenu, 5, , acMenuVer70
'Complete Old In process Tasks
Else
MsgBox ("Nothing Done")
'do nothing
End If
End Sub
Updated Code:
Private Sub EndofDay_Click()
Dim rstSource As DAO.Recordset
Dim rstInsert As DAO.Recordset
Dim fld As DAO.Field
Dim lngLoop As Long
Dim lngCount As Long
Set rstInsert = Me!Tasks.Form.RecordsetClone
Set rstSource = rstInsert.Clone
With rstSource
lngCount = .RecordCount
For lngLoop = 1 To lngCount
If Nz(!Status.Value, 0) <> 10 Then
' Ignore record.
Else
With rstInsert
.AddNew
For Each fld In rstSource.Fields
With fld
If .Attributes And dbAutoIncrField Then
' Skip Autonumber or GUID field.
ElseIf .Name = "Start Date" Then
' Skip read-only field.
ElseIf .Name = "Date Completed" Then
' Skip read-only field.
ElseIf .Name = "Owner" Then
' Skip read-only field.
ElseIf .Name = "Active" Then
' Skip read-only field.
ElseIf .Name = "Status" Then
' Insert default value.
rstInsert.Fields(.Name).Value = 0
Else
' Copy field content.
rstInsert.Fields(.Name).Value = .Value
End If
End With
Next
.Update
End With
.Edit
!Status.Value = 100
.Update
End If
.MoveNext
Next
rstInsert.Close
.Close
End With
Set rstInsert = Nothing
Set rstSource = Nothing
End Sub
Any help would be greatly appreciated.
Could be something like this in your Click event of the EndOfDay button on the main form:
Public Sub CopyRecords()
Dim rstSource As DAO.Recordset
Dim rstInsert As DAO.Recordset
Dim fld As DAO.Field
Dim lngLoop As Long
Dim lngCount As Long
Set rstInsert = Me!NameOfSubformControl.Form.RecordsetClone
Set rstSource = rstInsert.Clone
With rstSource
lngCount = .RecordCount
For lngLoop = 1 To lngCount
If Nz(!Status.Value, 0) <> 10 Then
' Ignore record.
Else
With rstInsert
.AddNew
For Each fld In rstSource.Fields
With fld
If .Attributes And dbAutoIncrField Then
' Skip Autonumber or GUID field.
ElseIf .Name = "SomeReadOnlyField" Then
' Skip read-only field.
ElseIf .Name = "Status" Then
' Insert default value.
rstInsert.Fields(.Name).Value = 0
Else
' Copy field content.
rstInsert.Fields(.Name).Value = .Value
End If
End With
Next
.Update
End With
.Edit
!Status.Value = 100
.Update
End If
.MoveNext
Next
rstInsert.Close
.Close
End With
Set rstInsert = Nothing
Set rstSource = Nothing
End Sub

Access change memo field from "plain text" to "rich text" using VBScript

i have a question about changing a memofield from "plain text" to "rich text" using VBScript, i found some solutions here and on the internet but all the solutions are for VBScript within access. I try to start an vbscript through Windows, but my script doesn't work. I'm kindly new to VBScripting so i hope you guys can help me. I used an example from the forum for my script:
How to convert a text field in an Access table to a rich text memo using VBA
My Script:
Dim db
Dim tdf
Dim fld1
Dim fld2
Set accessApp = GetObject("D:\test.mdb")
Set accessApp = CreateObject("Access.Application")
accessApp.OpenCurrentDataBase "D:\test.mdb", true
accessApp.visible = false
accessApp.UserControl = true
Set accessApp.db = CurrentDB
Set accessApp.tdf = db.TableDefs("Database")
Set accessApp.fld1 = tdf.Fields("Name_Memofield1")
Set accessApp.fld2 = tdf.Fields("Name_Memofield2")
Debug.Print "acTextFormatPlain: " & acTextFormatPlain & _
"; acTextFormatHTMLRichText: " & acTextFormatHTMLRichText
With fld1.Properties("TextFormat")
Debug.Print "TextFormat: " & .Value
If .Value = acTextFormatPlain Then
.Value = acTextFormatHTMLRichText
Debug.Print "TextFormat changed to: " & .Value
End If
End With
With fld2.Properties("TextFormat")
Debug.Print "TextFormat: " & .Value
If .Value = acTextFormatPlain Then
.Value = acTextFormatHTMLRichText
Debug.Print "TextFormat changed to: " & .Value
End If
End With
The error what occures tells me that the problem is in the "Set accessApp.db = CurrentDB" the error which occured is: "Object doesn't support this prperty or method accessApp.db" If i change "accessApp.db" to "db" an other error occures: "Object required: 'CurrentDB' "
Try something like the code below. It will need tidying.
Option Explicit
Dim accessApp
Dim db
Dim dbname
Dim tdf
Dim fld1
Dim fld2
Dim acTextFormatPlain
Dim acTextFormatHTMLRichText
Dim dbInteger
'acTextFormatPlain=0
'acTextFormatHTMLRichText=1
dbInteger=3
dbname="D:\Test.mdb"
Set accessApp = CreateObject("Access.Application")
accessApp.OpenCurrentDataBase(dbname)
set db=accessapp.CurrentDb
Set tdf = db.TableDefs("2emails")
'The property may not exist
SetFieldProperty tdf.Fields(1), "TextFormat", dbInteger, 0
With tdf.Fields(1).Properties("TextFormat")
If .Value = 0 Then
.Value = 1
msgbox "TextFormat changed to: " & .Value
End If
End With
Sub SetFieldProperty(ByVal fld , ByVal strPropertyName , ByVal iDataType , ByVal vValue )
Dim prp
Set prp = Nothing
On Error Resume Next
Set prp = fld.Properties(strPropertyName)
On Error GoTo 0
If prp Is Nothing Then
Set prp = fld.CreateProperty(strPropertyName, iDataType, vValue)
fld.Properties.Append prp
Else
prp.Value = vValue
End If
End Sub

Export Each Access Table To Individual Workbook

I have been using this syntax which will export every table in a database to ONE excel workbook, but now my needs are to export every table to it's own workbook. How could this be tweaked to export each table to it's own workbook?
Sub ExportToExcel()
Dim td As DAO.TableDef, db As DAO.Database
Dim out_file As String
out_file = "C:\fromaccess.xlsx"
Set db = CurrentDb()
For Each td in db.TableDefs
If Left(td.Name, 4) = "MSys" Then
'Do Nothing
Else
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, td.Name, out_file, True, Replace(td.Name, "dbo_","")
End If
Next
End Sub
EDIT
I tried the suggestion by #HA560 but get an error of
Run-time error '91':
Object variable or With block variable not set
This is updated code:
Sub ExportToExcel()
Dim td As DAO.TableDef, db As DAO.Database
Dim out_file As String
Dim xl As Excel.Application
out_file = "C:\fromaccess.xlsx"
Set db = CurrentDb()
For Each td in db.TableDefs
xl.Workbooks.Add
If Left(td.Name, 4) = "MSys" Then
'Do Nothing
Else
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, td.Name, out_file, True, Replace(td.Name, "dbo_","")
End If
Next
End Sub
Bit of a long one which includes a three procedures. After running you should have a list of table names and TRUE/FALSE in the immediate window saying whether the export was successful.
ExportAll - The main procedure.
CreateXL - this creates an instance of Excel. It uses late binding, so no need to set references.
QueryExportToXL - this is the code to export the table. I haven't used TransferSpreadsheet as I like more control.
You need to pass a worksheet reference to the function.
You can pass either a query name or a recordset to the function.
You can pass an alternative sheet name.
The default cell to paste into is A1, but you can change this.
By default it adjusts the column widths to fit.
You can pass a collection of heading names to use instead of the field names.
There's not much error handling in there - such as passing a different number of heading names than there are fields, giving illegal sheet names.
It needs work :)
Public Sub ExportAll()
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim rst As DAO.Recordset
Dim oXL As Object
Dim oWrkBk As Object
Set db = CurrentDb
'Create instance of Excel.
Set oXL = CreateXL
For Each tdf In db.TableDefs
If Left(tdf.Name, 4) <> "MSys" Then
'Create workbook with single sheet.
Set oWrkBk = oXL.WorkBooks.Add(-4167) 'xlWBATWorksheet
'Open the table recordset.
Set rst = tdf.OpenRecordset
'In the immediate window display table name and TRUE/FALSE if exported successfully.
Debug.Print tdf.Name & " - " & QueryExportToXL(oWrkBk.worksheets(1), , rst, tdf.Name)
'Save and close the workbook.
oWrkBk.SaveAs "<path to folder>" & tdf.Name
oWrkBk.Close
End If
Next tdf
End Sub
'----------------------------------------------------------------------------------
' Procedure : CreateXL
' Author : Darren Bartrup-Cook
' Date : 02/10/2014
' Purpose : Creates an instance of Excel and passes the reference back.
'-----------------------------------------------------------------------------------
Public Function CreateXL(Optional bVisible As Boolean = True) As Object
Dim oTmpXL As Object
'''''''''''''''''''''''''''''''''''''''''''''''''''''
'Defer error trapping in case Excel is not running. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
Set oTmpXL = GetObject(, "Excel.Application")
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'If an error occurs then create an instance of Excel. '
'Reinstate error handling. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Err.Number <> 0 Then
Err.Clear
On Error GoTo ERROR_HANDLER
Set oTmpXL = CreateObject("Excel.Application")
End If
oTmpXL.Visible = bVisible
Set CreateXL = oTmpXL
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure CreateXL."
Err.Clear
End Select
End Function
'----------------------------------------------------------------------------------
' Procedure : QueryExportToXL
' Author : Darren Bartrup-Cook
' Date : 26/08/2014
' Purpose : Exports a named query or recordset to Excel.
'-----------------------------------------------------------------------------------
Public Function QueryExportToXL(wrkSht As Object, Optional sQueryName As String, _
Optional rst As DAO.Recordset, _
Optional SheetName As String, _
Optional rStartCell As Object, _
Optional AutoFitCols As Boolean = True, _
Optional colHeadings As Collection) As Boolean
Dim db As DAO.Database
Dim prm As DAO.Parameter
Dim qdf As DAO.QueryDef
Dim fld As DAO.Field
Dim oXLCell As Object
Dim vHeading As Variant
On Error GoTo ERROR_HANDLER
If sQueryName <> "" And rst Is Nothing Then
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Open the query recordset. '
'Any parameters in the query need to be evaluated first. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set db = CurrentDb
Set qdf = db.QueryDefs(sQueryName)
For Each prm In qdf.Parameters
prm.Value = Eval(prm.Name)
Next prm
Set rst = qdf.OpenRecordset
End If
If rStartCell Is Nothing Then
Set rStartCell = wrkSht.cells(1, 1)
Else
If rStartCell.Parent.Name <> wrkSht.Name Then
Err.Raise 4000, , "Incorrect Start Cell parent."
End If
End If
If Not rst.BOF And Not rst.EOF Then
With wrkSht
Set oXLCell = rStartCell
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Paste the field names from the query into row 1 of the sheet. '
'Or the alternative field names provided in a collection. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If colHeadings Is Nothing Then
For Each fld In rst.Fields
oXLCell.Value = fld.Name
Set oXLCell = oXLCell.Offset(, 1)
Next fld
Else
For Each vHeading In colHeadings
oXLCell.Value = vHeading
Set oXLCell = oXLCell.Offset(, 1)
Next vHeading
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Paste the records from the query into row 2 of the sheet. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set oXLCell = rStartCell.Offset(1, 0)
oXLCell.copyfromrecordset rst
If AutoFitCols Then
.Columns.Autofit
End If
If SheetName <> "" Then
.Name = SheetName
End If
'''''''''''''''''''''''''''''''''''''''''''
'TO DO: Has recordset imported correctly? '
'''''''''''''''''''''''''''''''''''''''''''
QueryExportToXL = True
End With
Else
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'There are no records to export, so the export has failed. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
QueryExportToXL = False
End If
Set db = Nothing
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure QueryExportToXL."
Err.Clear
Resume
End Select
End Function
After for each use workbooks.add()method...out_file=activeworkbook.path

DAO RecordSet error 3251 when using FindFirst

I am getting "Run-time error '3251': Operation is not supported for this type of object." when I am trying to use the "FindFirst" on my DAO RecordSet. Can someone explain to me what I am doing wrong for this not to search for the record. The variable I am using is returning the correct value for the search.
Private Sub ctrSend_Click()
Dim intI As Integer
Dim lst As ListBox
Dim varItem As Variant
Dim rst As DAO.Recordset
Dim rst2 As DAO.Recordset
Dim qtySum As Variant
Dim qtyDiff As Variant
Dim rowMax As Variant
Dim rowUpdate As Variant
Set lst = Me![lstShipping]
Set rst = CurrentDb.OpenRecordset("ShipInv", dbOpenTable)
Set rst2 = CurrentDb.OpenRecordset("Storage", dbOpenTable)
qtySum = 0
rowMax = 0
With lst
If .ItemsSelected.count = 0 Then Exit Sub
For Each varItem In .ItemsSelected
qtySum = qtySum + .Column(3, varItem)
Next
If Me.[ctrQtyProd] = qtySum Then
MsgBox "Qty Selected EQUALS Qty Being Shipped.", vbOKOnly, "Confirmation Message"
ElseIf Me.[ctrQtyProd] > qtySum Then
MsgBox "Qty Selected LESS THAN Qty Being Shipped, please select more Inventory.", vbOKOnly, "Confirmation Message"
Else
qtyDiff = qtySum - Me.[ctrQtyProd]
rowMax = lst.Column(3, lst.ItemsSelected.count)
rowUpdate = rowMax - qtyDiff
rst2.FindFirst "[BIN] = '" & lst.Column(0, lst.ItemsSelected.count) & "'"
rst2![QtyProd] = lst.Column(3, lst.ItemsSelected.count)
rst2.Update
rst2.Close
MsgBox "Storage Successfully Updated.", vbOKOnly, "Confirmation Message"
End If
End With
With lst
For Each varItem In .ItemsSelected
rst.AddNew
rst!Order = Me.[ctrSOrder]
rst!EntDate = Date
rst!ShipDate = Me.[ctrSDate]
rst!BIN = .Column(0, varItem)
rst!SKU = .Column(1, varItem)
rst!Lot = .Column(2, varItem)
rst!QtyProd = rowUpdate
rst.Update
Next
End With
rst.Close
Set rst = Nothing
Set rst2 = Nothing
MsgBox "Shipping List Successfully Updated.", vbOKOnly, "Confirmation Message"
End Sub
Did you try opening the recordset as a dbOpenDynaset (default without the enum specified in the open statement) or dbOpenSnapshot instead? The documentation on the Microsoft MSDN site specifies it takes one of those two recordsets.
Locates the first record in a dynaset- or snapshot-type Recordset object that satisfies the specified criteria and makes that record the current record (Microsoft Access workspaces only).
Microsoft MSDN article on Recordset.FindFirst

Split the subject line to export into separate columns in Excel

I have code which exports the subject of emails from a folder I choose to an Excel workbook. I need the text after the first 'space' in the subject to be exported to another column (column C preferably). Below are a couple of examples of what the subject lines look like:
" 321-654321 APPROVED With more words to follow "
and
" APR#987-123456 CONTIGENT With More text to follow "
I want to have the number (or) everything before the first space in the subject in one column and everything after the number, first space, in a different column.
here is an example of the output I would like to have
Column A - Column B - Column C
XXX-XXXXX - DateOf Email - Status of the incident
Here is the code I'm currently using, I believe I found this macro on Stackoverflow. Also, Can't I skip having the user choose the folder and put what folder I want this macro to act on inside the code?
Sub ExportToExcel()
On Error GoTo ErrHandler
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.Namespace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
strSheet = "spreadhsheet.xlsx"
strPath = "C:\MyOutlookMacro\"
strSheet = strPath & strSheet
Debug.Print strSheet
'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
End If
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
'Copy field items in mail folder.
For Each itm In fld.Items
intColumnCounter = 1
Set msg = itm
intRowCounter = intRowCounter + 3
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Subject
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SentOn
Next itm
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub
ErrHandler: If Err.Number = 1004 Then
MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
Else
MsgBox Err.Number & "; Description: ", vbOKOnly, "Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub
-------------------------------
Sub ExportToExcel()
On Error GoTo ErrHandler
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
Dim Words As String
strSheet = "spreadhsheet.xlsx"
strPath = "C:\MyOutlookMacro\"
strSheet = strPath & strSheet
Debug.Print strSheet
'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
'Set fld = Set fld = myNamespace.GetDefaultFolder(olFolderInbox).Folders("SpreadsheetItems")
'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
End If
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
'Copy field items in mail folder.
For Each itm In fld.Items
intColumnCounter = 1
Set msg = itm
Words = Split(msg.Subject, " ")
intRowCounter = intRowCounter + 3
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = Words(0)
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SentOn
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = Words(2)
Next itm
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub
ErrHandler: If Err.Number = 1004 Then
MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
Else
MsgBox Err.Number & "; Description: ", vbOKOnly, "Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub
** I'm getting "Compile Error: Expected Array # rng.Value = Words(0) **
Re: Split the subject
Use Split
Dim Words() As String ' not Dim Words as String
For Each itm In fld.Items
intColumnCounter = 1
Set msg = itm
Words = Split(msg.Subject, " ")
intRowCounter = intRowCounter + 3
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = Words(0)
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SentOn
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = Words(2)
Next itm
Re: "... skip having the user choose the folder and put what folder I want ..."
If the Source folder is in the default Inbox then
Set fld = myNamespace.GetDefaultFolder(olFolderInbox).Folders.("Source")
Add as many .Folders("...") as necessary if the Source folder is deeper.
If the Source folder is not in the default Inbox then Get reference to additional Inbox