Can anyone spot an obvious reason as to why my save function isn't saving the fields in my form? It saves the document, but the fields are empty when I open it up. The following code is what I'm using:
Public Sub co_loopNamesAndSaveDocs()
'Dim variables
Dim s As New NotesSession
Dim thisDatabase As NotesDatabase
Set thisDatabase = s.CurrentDatabase
Dim ws As New NotesUIWorkspace
Dim uidoc As NotesUIDocument
Set uidoc = ws.CurrentDocument
Dim currentDoc As NotesDocument
Set currentDoc = uidoc.Document
Dim newDoc As NotesDocument
Dim PersonNameField As NotesItem
Set PersonNameField = currentDoc.GetFirstItem("PersonName")
'Loop through values in PersonNameField and create a new document for each value found
Forall pName In PersonNameField.Values
Set newDoc = New NotesDocument (thisDatabase)
newDoc.Form="newLocationForm"
newDoc.StartDate = currentDoc.StartDate(0)
newDoc.EndDate = currentDoc.EndDate(0)
newDoc.Duration = currentDoc.Duration(0)
newDoc.StartTime = currentDoc.StartTime(0)
newDoc.EndTime = currentDoc.EndTime(0)
newDoc.Comments = currentDoc.Comments(0)
newDoc.Status = currentDoc.Status(0)
newDoc.LocationCode = currentDoc.LocationCode(0)
newDoc.PersonName = pName
Call newDoc.Save (True, False, False)
End Forall
End Sub
Thanks in advance.
Since I don't see an obvious error in the coding, I'd say that the fields in newDoc are blank because the fields in currentDoc are blank. And since currentDoc was set to uidoc.Document, that probably means that you have a synch problem between front-end and back-end documents. I.e., the values exist in your uidoc, but have not yet been saved to the back-end prior to calling this code. If I'm right, try calling uidoc.save() before assigning currentDoc. If you don't want to save to the back-end, then instead of using the back-end as your data source you should be using uidoc.fieldGetText("PersonName") and parsing out the values.
Related
I have a VB .NET web application running on a server with multiple requests and performance requirements.
I have a function that retrieves some data from a DB and has to generate an excel report to show to the system users.
I somehow did it, but my solution has not the performance I'd like it to have: basically what my code does is:
The server accepts the request of report generating
The server fills an excel file
The server saves locally the xls file
The server attaches the file to the html response and the user downloads it
The server deletes the file (when? I need to handle borderline cases too)
The code snippet is like:
Public Sub ExportaDataTableToExcel(ByVal dt As System.Data.DataTable, ByVal Page As System.Web.UI.Page, ByVal ReportName As String)
Dim oExcel As Excel.Application
Dim oBook As Excel.Workbook
Dim oSheet As Excel.Worksheet
Dim colIndex As Integer
Dim rowIndex As Integer
oExcel = New Excel.Application
oBook = oExcel.Workbooks.Add(Type.Missing)
oSheet = oBook.Worksheets(1)
'Export the Columns to excel file
For Each dc In dt.Columns
colIndex = colIndex + 1
oSheet.Cells(1, colIndex) = dc.ColumnName
Next
oBook.SaveAs("C:\file.xls")
oSheet = Nothing
oBook.Close()
Page.Response.AddHeader("content-disposition", "attachment;filename=" & ReportName & ".xls")
Page.Response.Charset = String.Empty
Page.Response.ContentType = "vnd.application/ms-excel"
Page.Response.TransmitFile("C:\file.xls")
Page.Response.Flush()
Page.Response.End()
oExcel.Quit()
End Sub
As you can see the server generates the xls file locally in C:\file.xls, then trasmittes the file in the response page.
What I'd like to do, and I really don't know if it's possible as I did not found any example on this, is generating the xls file on the fly without saving it locally (maybe returning as a Stream of bytes or something like this) and then assembling this as xls file in the response page, without saving the file locally.
I tried using both Page and System.IO.StringWriter with no luck, maybe I'm doing something wrong.
The following code acts abnormally, asking me to save modifies on the file (on the server side), and downloading an xls file that has parts of the html of the page, generating errors about missing css files and displaying part of the page. So, with this approach I'm almost at zero. Here it is the code:
Public Sub ExportaDataTableToExcel(ByVal dt As System.Data.DataTable, ByVal Page As System.Web.UI.Page, ByVal ReportName As String)
Dim oExcel As Excel.Application
Dim oBook As Excel.Workbook
Dim oSheet As Excel.Worksheet
Dim colIndex As Integer
Dim rowIndex As Integer
oExcel = New Excel.Application
oBook = oExcel.Workbooks.Add(Type.Missing)
oSheet = oBook.Worksheets(1)
'Export the Columns to excel file
For Each dc In dt.Columns
colIndex = colIndex + 1
oSheet.Cells(1, colIndex) = dc.ColumnName
Next
oSheet = Nothing
oBook.Close()
Dim stringWrite As System.IO.StringWriter = New System.IO.StringWriter
Dim htmlWrite As System.Web.UI.Html32TextWriter = New System.Web.UI.Html32TextWriter(stringWrite)
Page.Response.Clear()
Page.Response.AddHeader("content-disposition", "attachment;filename=" & ReportName & ".xls")
Page.Response.Charset = String.Empty
Page.Response.ContentType = "vnd.application/ms-excel"
Page.Response.WriteFile(stringWrite.ToString)
Page.Response.Flush()
Page.Response.End()
oExcel.Quit()
End Sub
I know I can help with at least one of those problems you are having, Lateralus. Ive taken a snippet from our live server here to show you.
Edit: This one transmits a CSV file and we had the problem initially with the HTML showing up in the file. We opted to not use excel in this particular instance but, the problems are likely one in the same.
I believe that you need to add an additional header to your page response in order to remove the HTML that you are getting in the file.
Here is an example. As a warning, I'm not entirely sure how secure this method is. We use this within our network so it didn't need to be as locked down.
Dim LiveFileStream As FileStream = New FileStream("C:\inetpub\wwwroot\" &_
"Website\CSVFile.csv", FileMode.Open, FileAccess.Read)
Dim fileBuffer(CInt(LiveFileStream.Length)) As Byte
LiveFileStream.Read(fileBuffer, 0, CInt(LiveFileStream.Length))
LiveFileStream.Close()
Response.Clear()
Response.Charset = "utf-8"
Response.ContentType = "text/plain"
'I believe if you are to add the following header
'it will fix the problem with HTML showing in document
Response.AddHeader("Content-Length", fileBuffer.Length.ToString)
Response.AddHeader("Content-Disposition", "attachment; filename=CSVFile.csv")
Response.BinaryWrite(fileBuffer)
Response.End()
I am a non-coder/programmer trying to create an excel spreadsheet that utilizes some VBA automation to import some web-data based on certain cell values. I have managed to scrape together part of the process using Youtube and some other sites like this. However, I have hit a road block that I am hoping someone could help me with.
Here is the setup:
I am trying to import some Co2 data based on 2 parameters (pressure and temperature) that will reside in 2 separate cells in my excel sheet.
In my VBA code, I have managed to navigate to the first site (http://www.peacesoftware.de/einigewerte/co2_e.html), and then find the table elements, fill them in, and submit the form.
My problem is when IE navigates to the next page where the results are. I do not know how to import table elements from this new page. I assume I need to tell VBA to look at the new page, but it has a generic URL (http://www.peacesoftware.de/einigewerte/calc_co2.php5), so I am confused on what to reference.
I hope this is all the info needed to get a clear picture of my problem. Here is my current VBA code. The end part after "submit" is a wild guess on my part. Once VBA is looking at the right table/page, I will then import the enthalpy and entropy values to my excel spreadsheet.
Thanks in advance for your help!
' updates enthalpy, entropy data from peacesoftware site
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row = Range("tempA").Row And Target.Column = Range("tempA").Column Then
Dim IE As Object
Dim pressA As String
Dim tempA As String
Dim denseA As String
Dim enthA As String
Dim entroA As Style
tempA = Range("tempA")
pressA = Range("pressA")
Set IE = CreateObject("InternetExplorer.Application")
' setup internet explorer
IE.Visible = True
IE.navigate "http://www.peacesoftware.de/einigewerte/co2_e.html"
Do
DoEvents
Loop Until IE.readyState = READYSTATE_COMPLETE
' find pressure and temp entry form
IE.document.getElementsByName("druck")(0).Value = pressA
IE.document.getElementsByName("temperatur")(0).Value = tempA
IE.document.forms(0).submit
'Do
'DoEvents
'Loop Until IE.readyState = READYSTATE_COMPLETE
'update new energy data
'IE.navigate table_url ???
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
End Sub
***Update
I think I found a solution, so I can at least get it functional. (thanks to this post: excel vba form submit and parse data from result )
I needed to wait after submit and then search for the "td" element I needed. Since the actual value I needed was the next element after the element label, I used TDelement.nextElementSibling.innerText to grab it.
IE.document.forms(0).submit
' wait for new page to load
Do While IE.Busy: DoEvents: Loop
Set doc = IE.document
Dim sdd As String
Set TDelements = doc.getElementsByTagName("td")
r = 0
For Each TDelement In TDelements
If TDelement.innerText = "Density : " Then
Range("denseA") = TDelement.nextElementSibling.innerText
r = r + 1
End If
Next
Thanks again for the help.
The problem is that the form is sent by POST and not by GET.
That means that you cannot see/manipulate/send the parameters in the URL.
BUT you can use VBA to send a POST-Request directly to the result page.
The following code gets you the values you mentioned in the commenct-section of this response.
You have to change the postData-variable if you want another temperature or 'druck':
This Example-Code just gives you the result for the values 20 and 20.
Dim Density As String
Dim Entropy As String
Dim Enthalpy As String
Dim SoA As String
Dim Result As String
Dim myURL As String, postData As String
Dim winHttpReq As Object
Set winHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
myURL = "http://www.peacesoftware.de/einigewerte/calc_co2.php5"
postData = "lang=english&calc=standard&druck=20&druckunit=1&temperatur=20&tempunit=1"
winHttpReq.Open "POST", myURL, False
winHttpReq.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
winHttpReq.Send (postData)
Result = winHttpReq.responseText
Density = getValue("Density", Result, False)
Entropy = getValue("Entropy", Result, False)
Enthalpy = getValue("Enthalpy", Result, False)
SoA = getValue("state of aggregation", Result, True)
Additionally I created a helper-function which must also be implemented:
Public Function getValue(Property As String, Result As String, isBold As Boolean) As String
Dim posProp As Long
Dim posTD As Long
Dim posEndTD As Long
Dim startPosVal As Long
Dim endPosVal As Long
Dim valLength As Long
Dim Value As String
'find the position of the value on the page
posProp = InStr(1, Result, Property)
If posProp > 0 Then
posTD = InStr(posProp, Result, "<td>")
If isBold = True Then
posEndTD = InStr(posTD, Result, "</b></td>")
startPosVal = posTD + 7
Else
posEndTD = InStr(posTD, Result, "</td>")
startPosVal = posTD + 4
End If
endPosVal = posEndTD
valLength = endPosVal - startPosVal
Value = Mid(Result, startPosVal, valLength)
getValue = Value
End If
End Function
Hope this helps!
If you need any help just leave me a comment.
EDIT:
Ah i just read that you found a solution.
But I think this code is a bit cleaner and faster because it just send ONE http-request directly to the result-page.
I am trying to develop an Access database for keeping track of emails in Outlook. I was able to develop the following code by combining bits and pieces from many internet searches. The attached code finally works and took me more time than I want to admit to develop. I am new to VBA programming and am trying to grunt my way through the process. Anyway, out of frustration and dread that this project could end up taking way longer than I wanted it to, I thought I would finally ask for some help. The following are features, in order of priority, that I would eventually like to add to the below code:
High Priority:
(1) Need recursive VBA code to import emails located in all subfolders.
(2) Need VBA code to insert the Folder name where the email is located into Access Database. Folder Path is not necessary.
(3) Need VBA code to insert the file name of any user attached documents.
Low Priority (Access can be used to remove duplicates until issue is resolved):
(4) Want VBA code to append data with new emails when macro is run.
Nice future options:
(5) VBA code to allow me to pick a folder. Option would allow for future flexibility.
I am running Access and Outlook 2010 on Window 7 (64 Bit Computer). The following is my code so far:
Sub ImportContactsFromOutlook()
' This code is based in Microsoft Access.
' Set up DAO objects (uses existing "tblContacts" table)
Dim rst As DAO.Recordset
Set rst = CurrentDb.OpenRecordset("Email")
' Set up Outlook objects.
Dim ol As New Outlook.Application
Dim olns As Outlook.NameSpace
Dim cf As Outlook.MAPIFolder
Dim c As Outlook.MailItem
Dim objItems As Outlook.Items
Dim Prop As Outlook.UserProperty
Set olns = ol.GetNamespace("MAPI")
'--- (5) --- VBA code to allow me to pick a folder. Option would allow for future flexability.
Set cf = olns.GetDefaultFolder(olPublicFoldersAllPublicFolders)
'--- (1) --- Need recursive VBA code to import emails located in all subfolders.
Set objItems = cf.Items
iNumMessages = objItems.Count
If iNumMessages <> 0 Then
For i = 1 To iNumMessages
If TypeName(objItems(i)) = "MailItem" Then
Set c = objItems(i)
rst.AddNew
rst!EntryID = c.EntryID
rst!ConversationID = c.ConversationID
rst!Sender = c.Sender
rst!SenderName = c.SenderName
rst!SentOn = c.SentOn
rst!To = c.To
rst!CC = c.CC
rst!BCC = c.BCC
rst!Subject = c.Subject
rst!Attachments = c.Attachments.Count
'--- (3) --- Need VBA code to insert the file name of any user attached documents. ".Count" is used to avoid error and can be replaced.
rst!Body = c.Body
rst!HTMLBody = c.HTMLBody
rst!Importance = c.Importance
rst!Size = c.Size
rst!CreationTime = c.CreationTime
rst!ReceivedTime = c.ReceivedTime
rst!ExpiryTime = c.ExpiryTime
'--- (2) --- Need VBA code to insert the Folder name where the email is located into Access Database. Folder Path is not necessary.
rst.Update
End If
Next i
rst.Close
MsgBox "Finished."
Else
MsgBox "No e-mails to export."
End If
'--- (4) --- Want VBA code to append data with new emails when macro is run.
End Sub
Here are some helpful reference material I tried to use. Some of them have what looked like fancy tools. Because I am learning I either could not implement or did not understand some of them..
msdn.microsoft.com/en-us/library/ee861519(v=office.14).aspx
msdn.microsoft.com/en-us/library/office/ee861520(v=office.14).aspx
accessexperts.net/blog/2011/07/07/importing-outlook-emails-into-access/
add-in-express.com/creating-addins-blog/2011/08/15/how-to-get-list-of-attachments/
databasejournal.com/features/msaccess/article.php/3827996/Working-With-Outlook-from-Access.htm
stackoverflow.com/questions/7298591/copying-all-incoming-emails-in-outlook-inbox-and-personal-subfolders-to-excel-th
Any recommendations or direction is welcome. Thanks for the help. It is appreciated.
Here is my code as it stands now (see below). There are still a few problems when I run it. On the first time the code is run, since there are no records in the Access database table, I receive the following error:
Run-time error ‘3021’: No current record.
Is there an error check or way I can code around this? Also, after the Access database is populated, the following code only excludes those emails found in the primary folder, not the sub folder:
If ([rst]![EmailLocation] <> ofProp.Name) And ([rst]![EntryID] <> cMail.EntryID) Then
I am trying to figure out why. Last, I still need to know how pull a list of user attached documents into the access database. The following code pulls all attachments, including the embedded ones, and only returns the first attachment in the document:
Set cAtch = cMail.Attachments
cntAtch = cAtch.Count
If cntAtch > 0 Then
For j = cntAtch To 1 Step -1
strAtch = cAtch.Item(j).FileName
rst!Attachments = strAtch
Next
Else
rst!Attachments = "No Attachments"
End If
Again, any help would be appreciated. Thanks.
Sub ImportMailPropFromOutlook()
' Code for specifing top level folder and initializing routine.
' Set up Outlook objects.
Dim ol As New Outlook.Application
Dim olns As Outlook.NameSpace
Dim ofO As Outlook.MAPIFolder
Dim ofSubO As Outlook.MAPIFolder
Dim objItems As Outlook.Items
Set olns = ol.GetNamespace("MAPI")
Set ofO = olns.GetDefaultFolder(olFolderInbox) '--- Specifies top level folder for importing Oultook mail.
'Set of = olns.PickFolder '--- Allows user to select top level folder for importing Outlook mail.
'Set info and call GetMailProp code.
Set objItems = ofO.Items
GetMailProp objItems, ofO
'Set info and call ProcessSubFolders.
For Each ofSubO In of.Folders
Set objItems = ofSubO.Items
ProcessSubFolders objItems, ofSubO
Next
End Sub
Sub GetMailProp(objProp As Outlook.Items, ofProp As Outlook.MAPIFolder)
' Code for writeing Outlook mail properties to Access.
' Set up DAO objects (uses existing Access "Email" table).
Dim rst As DAO.Recordset
Set rst = CurrentDb.OpenRecordset("Email")
'Set Up Outlook objects.
Dim cMail As Outlook.MailItem
Dim cAtch As Outlook.Attachments
'Write Outlook mail properties to Access "Email" table.
iNumMessages = objProp.Count
If iNumMessages <> 0 Then
For i = 1 To iNumMessages
If TypeName(objProp(i)) = "MailItem" Then
Set cMail = objProp(i)
If ([rst]![EmailLocation] <> ofProp.Name) And ([rst]![EntryID] <> cMail.EntryID) Then
rst.AddNew
rst!EntryID = cMail.EntryID
rst!ConversationID = cMail.ConversationID
rst!Sender = cMail.Sender
rst!SenderName = cMail.SenderName
rst!SentOn = cMail.SentOn
rst!To = cMail.To
rst!CC = cMail.CC
rst!BCC = cMail.BCC
rst!Subject = cMail.Subject
Set cAtch = cMail.Attachments
cntAtch = cAtch.Count
If cntAtch > 0 Then
For j = cntAtch To 1 Step -1
strAtch = cAtch.Item(j).FileName
rst!Attachments = strAtch
Next
Else
rst!Attachments = "No Attachments"
End If
rst!Count = cMail.Attachments.Count
rst!Body = cMail.Body
rst!HTMLBody = cMail.HTMLBody
rst!Importance = cMail.Importance
rst!Size = cMail.Size
rst!CreationTime = cMail.CreationTime
rst!ReceivedTime = cMail.ReceivedTime
rst!ExpiryTime = cMail.ExpiryTime
rst!EmailLocation = ofProp.Name
rst.Update
End If
End If
Next i
End If
End Sub
Sub ProcessSubFolders(objItemsR As Outlook.Items, OfR As Outlook.MAPIFolder)
'Code for processing subfolders
' Set up Outlook objects.
Dim ofSubR As Outlook.MAPIFolder
'Set info and call GetMailProp code.
GetMailProp objItemsR, OfR
'Set info and call ProcessSubFolders. Recursive.
For Each ofSubR In OfR.Folders
Set objItemsR = ofSubR.Items
ProcessSubFolders objItemsR, ofSubR
Next
End Sub
I had an opportunity to work on the code some more. What I am trying to do is import emails located within all the sub-folders of my Outlook account into Access. The VBA code is in Access. I only need certain mail item properties. Mostly the ones you would need to replicate the print memo function in Outlook.
I added a few more that I thought I would need to help exclude duplicates located in the same folder. The are duplicate emails in different public sub-folders but I need to know that in my database record.
I still need a recursive sub or function to make sure I get all the sub-folders. I tried a For/Next loop but this only searches one level of sub-folders. I could defiantly use some help on this. This seems like the tough part.
My updated code is:
Sub ImportContactsFromOutlook()
' This code is based in Microsoft Access.
' Set up DAO objects (uses existing "Email" table)
Dim rst As DAO.Recordset
Set rst = CurrentDb.OpenRecordset("Email")
' Set up Outlook objects.
Dim ol As New Outlook.Application
Dim olns As Outlook.NameSpace
Dim cf As Outlook.MAPIFolder
Dim cMail As Outlook.MailItem
Dim cAtch As Outlook.Attachments
Dim objItems As Outlook.Items
Dim of As Outlook.Folder
Dim ofSub As Outlook.Folder
Set olns = ol.GetNamespace("MAPI")
'--- (5) ---
'Would eventually be nice to allow a user to select a folder. Folderpicker? Lowest priority.
Set of = olns.GetDefaultFolder(olFolderInbox)
'--- (1) ---
'Loop only searches one level down. I will need all subfolders. Most examples I saw call external Sub? Recursive?
For Each ofSub In of.Folders
Set objItems = ofSub.Items
iNumMessages = objItems.Count
If iNumMessages <> 0 Then
For i = 1 To iNumMessages
If TypeName(objItems(i)) = "MailItem" Then
Set cMail = objItems(i)
rst.AddNew
rst!EntryID = cMail.EntryID
rst!ConversationID = cMail.ConversationID
rst!Sender = cMail.Sender
rst!SenderName = cMail.SenderName
rst!SentOn = cMail.SentOn
rst!To = cMail.To
rst!CC = cMail.CC
rst!BCC = cMail.BCC
rst!Subject = cMail.Subject
'--- (3) ---
'Code only inserts first attachment. Code Also inserts embedded attachments.
'Need code to insert all user selected attachments (ex. PDF Document) and no embedded attachments.
Set cAtch = cMail.Attachments
cntAtch = cAtch.Count
If cntAtch > 0 Then
For j = cntAtch To 1 Step -1
strAtch = cAtch.Item(j).FileName
rst!Attachments = strAtch
Next
Else
rst!Attachments = "No Attachments"
End If
rst!Count = cMail.Attachments.Count
rst!Body = cMail.Body
rst!HTMLBody = cMail.HTMLBody
rst!Importance = cMail.Importance
rst!Size = cMail.Size
rst!CreationTime = cMail.CreationTime
rst!ReceivedTime = cMail.ReceivedTime
rst!ExpiryTime = cMail.ExpiryTime
'--- (2) ---
' Solved - Figured out how to call folder location into databse.
rst!EmailLocation = ofSub.Name
rst.Update
End If
Next i
End If
Next
'--- (4) ---
'Still need code to append Access database with only new records.
'Duplicate email can exist in differenc subfolders but not same subfolder.
End Sub
Any help would be appreciated.
I was able to find some examples on the web to resolve the exclude duplicate mail records and Run-time error '3021' with the following code:
' If code checks outlook mail for and excludes duplicate records based on table fields [EntryID] and [EmailLocation].
If Cnt = DCount("[EntryID] & [EmailLocation]", "Email", "[EntryID] = """ & cMail.EntryID & """ And [EmailLocation] = """ & ofProp.Name & """") = 0 Then
'Code used to insert individual outlook mail properties.
End If
Still need to resolve the issue with attachments. Any help would be appreciated. Thank you.
Check this example for selecting the Outlook contact, from code written by Helen Feddema.
"Exporting Calendar Items to Excel"
http://www.helenfeddema.com/Code%20Samples.htm
I am trying to write a VBA script which imports all of the Excel files in a folder into a table in Access 2003, first checking if they have been imported or not. That part is fine. The issue I run into is clearing out some of the formulas that don't get used on the spreadsheet which causes difficulty when Access tries to import the range. when running the code as-is, I get an error "User-defined type not defined".
I am using late binding since I am developing for a site that uses multiple versions of Office and therfore can't reference the same library using early binding. The problem code is below:
Private Sub Command2_Click()
'Declare Variables
Dim xlApp As Object
Dim xlBook As Object
Dim LSQL As String
Dim SkippedCounter As Integer
Dim ImportedCounter As Integer
Dim BUN As Long
Dim SubmitDate As Date
Dim LSQL2 As String
Dim LSQL3 As String
'Start counters for final notice
SkippedCounter = 0
ImportedCounter = 0
Dim myDir As String, fn As String
'Set directory for importing files
myDir = "U:\Five Star\Operations\restore\Surveys\My InnerView - 2010\Action plans\Action plans - input for DB\"
'Function for selecting files in folder
fn = Dir(myDir & "*.xls")
'Determine if there are files in side the folder
If fn = "" Then
MsgBox "Folder is Empty!"
Else
'Begin cycling through files in the folder
Do While fn <> ""
'Create new Excel Object
Set xlApp = CreateObject("Excel.Application")
'Make it appear on the screen while importing
xlApp.Visible = True
'Open the workbook at hand
Set xlBook = xlApp.Workbooks.Open(myDir & fn)
'Check to see if it has been imported already
If xlBook.Sheets("Action plan form").Range("A1").Value = "Imported" Then
'If it has been imported, add 1 to the counter, close the file and close the instance of Excel
SkippedCounter = SkippedCounter + 1
xlBook.Close
xlApp.Quit
Set xlBook = Nothing
Set xlApp = Nothing
Else
'Otherwise, unprotect the worksheet
xlBook.UnProtect Password:="2010"
Dim c As Range
'Unhide worksheet needed and clean it up
xlBook.Sheets("Action plan DB data").Visible = True
xlBook.Sheets("Action plan DB data").Range("B10:O10").ClearFormats
xlBook.Sheets("Action plan DB data").Range("N11:N84").ClearFormats
For Each c In xlBook.Sheets("Action plan DB data").Range("DB_import")
If c.Value = "" Or c.Value = 0 Then c.Clear
Next c
...
The rest of the code should run fine, it jsut has an issue with the declaration of "range" and looping through it. Thanks for your help!
Remove As Range from Dim c As Range and that will make c into an object. That way when it gets late-bound to a range you won't have any issues.
Right I'm trying to send an Email form an excel spreadsheet though lotus notes, it has an attachment and the body needs to be in HTML.
I've got some code that from all I've read should allow me to do this however it doesn't.
Without the HTML body the attachment will send, when I impliment a HTML body the Email still sends but the attachment dissapears, I've tried rearanging the order of the code cutting out bits that might not be needed but all is invain.
(You need to reference Lotus Domino Objects to run this code.
strEmail is the email addresses
strAttach is the string location of the attachment
strSubject is the subject text
strBody is the body text
)
Sub Send_Lotus_Email(strEmail, strAttach, strSubject, strBody)
Dim noSession As Object, noDatabase As Object, noDocument As Object
Dim obAttachment As Object, EmbedObject As Object
Const EMBED_ATTACHMENT As Long = 1454
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GETDATABASE("", "")
'If Lotus Notes is not open then open the mail-part of it.
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
'Create the e-mail and the attachment.
Set noDocument = noDatabase.CreateDocument
Set obAttachment = noDocument.CreateRichTextItem("strAttach")
Set EmbedObject = obAttachment.EmbedObject(EMBED_ATTACHMENT, "", strAttach)
'Add values to the created e-mail main properties.
With noDocument
.Form = "Memo"
.SendTo = strEmail
'.Body = strBody ' Where to send the body if HTML body isn't used.
.Subject = strSubject
.SaveMessageOnSend = True
End With
noSession.ConvertMIME = False
Set Body = noDocument.CreateMIMEEntity("Body") ' MIMEEntity to support HTML
Set stream = noSession.CreateStream
Call stream.WriteText(strBody) ' Write the body text to the stream
Call Body.SetContentFromText(stream, "text/html;charset=iso-8859-1", ENC_IDENTITY_8BIT)
noSession.ConvertMIME = True
'Send the e-mail.
With noDocument
.PostedDate = Now()
.Send 0, strEmail
End With
'Release objects from the memory.
Set EmbedObject = Nothing
Set obAttachment = Nothing
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
End Sub
If somone could point me in the right direction I'd be greatly appreciated.
Edit:
I've done a little more investigating and I've found an oddity, if i look at the sent folder the emails all have the paperclip icon of having an attachment even though when you go into the email even in the sent the HTML ones don't show an attachment.
I have managed to solve my own problem.
In teh same way you create a MIME entry and stream in the HTML you need to do the same with the attachment, you also need to put them both inside a MIME entry within the email itself to hold both the HTML and Attachment at the same level otherwise you end up with a situation of the email with the body and a child entry of the attachment which is within another attachment. (it's odd but true)
Thus this is my solution:
Sub Send_Lotus_Email(Addresses, Attach, strSubject, strBody)
'Declare Variables
Dim s As Object
Dim db As Object
Dim body As Object
Dim bodyChild As Object
Dim header As Object
Dim stream As Object
Dim host As String
Dim message As Object
' Notes variables
Set s = CreateObject("Notes.NotesSession")
Set db = s.CurrentDatabase
Set stream = s.CreateStream
' Turn off auto conversion to rtf
s.ConvertMIME = False
' Create message
Set message = db.CreateDocument
message.Form = "memo"
message.Subject = strSubject
message.SendTo = Addresses
message.SaveMessageOnSend = True
' Create the body to hold HTML and attachment
Set body = message.CreateMIMEEntity
'Child mime entity which is going to contain the HTML which we put in the stream
Set bodyChild = body.CreateChildEntity()
Call stream.WriteText(strBody)
Call bodyChild.SetContentFromText(stream, "text/html;charset=iso-8859-1", ENC_NONE)
Call stream.Close
Call stream.Truncate
' This will run though an array of attachment paths and add them to the email
For i = 0 To UBound(Attach)
strAttach = Attach(i)
If Len(strAttach) > 0 And Len(Dir(strAttach)) > 0 Then
' Get the attachment file name
pos = InStrRev(strAttach, "\")
Filename = Right(strAttach, Len(strAttach) - pos)
'A new child mime entity to hold a file attachment
Set bodyChild = body.CreateChildEntity()
Set header = bodyChild.CreateHeader("Content-Type")
Call header.SetHeaderVal("multipart/mixed")
Set header = bodyChild.CreateHeader("Content-Disposition")
Call header.SetHeaderVal("attachment; filename=" & Filename)
Set header = bodyChild.CreateHeader("Content-ID")
Call header.SetHeaderVal(Filename)
Set stream = s.CreateStream()
If Not stream.Open(strAttach, "binary") Then
MsgBox "Open failed"
End If
If stream.Bytes = 0 Then
MsgBox "File has no content"
End If
Call bodyChild.SetContentFromBytes(stream, "application/msexcel", ENC_IDENTITY_BINARY)' All my attachments are excel this would need changing depensding on your attachments.
End If
Next
'Send the email
Call message.Send(False)
s.ConvertMIME = True ' Restore conversion
End Sub
Here is my actual code. I'm not even using strong type.
Dim mobjNotesSession As Object ' Back-end session reference'
Dim bConvertMime As Boolean
Dim stream As Object
Dim mimeHtmlPart As Object
Const ENC_QUOTED_PRINTABLE = 1726
mobjNotesSession = CreateObject("Lotus.NotesSession")
mobjNotesSession.Initialize()
mobjNotesDatabase = mobjNotesSession.GetDatabase("HQ2", "tim4")
mobjNotesDocument = mobjNotesDatabase.CreateDocument
bConvertMime = mobjNotesSession.ConvertMime
mobjNotesSession.ConvertMime = False
stream = mobjNotesSession.CreateStream()
Call stream.WriteText(txtBody.Text)
mobjNotesBody = mobjNotesDocument.CreateMIMEEntity("Body")
mimeHtmlPart = mobjNotesBody.CreateChildEntity() 'This returns "Type Mismatch" error'
Call mimeHtmlPart.SetContentFromText(stream, "text/html; charset=""iso-8859-1""", ENC_QUOTED_PRINTABLE)
Call stream.Close()
mobjNotesSession.ConvertMime = bConvertMime
Call mobjNotesDocument.CloseMIMEEntities(True, "Body")
No sorry I didn't i was running this in VBA which isn't strong typed so i can get away with not knowing the actual variable type for the body identity. i 've not been able to test this but I belive you need to reset the declarations to
Dim bodyChild As NotesMIMEEntity
this is the one you have trouble with the ones bellow you may find cause problems as well
Dim s As New NotesSession
Dim db As NotesDatabase
Dim body As NotesMIMEEntity
Dim header As NotesMIMEHeader
Dim stream As NotesStream
Dim host As String
Dim message As NotesDocument
Hope this helps