We want to upgrade our VB6 code to use Outlook 2010, but we're getting the following error:
Active x cannot create object
This is our current code:
Public Sub SendEmail()
Set emailOutlookApp = CreateObject("Outlook.Application.12")
Set emailNameSpace = emailOutlookApp.GetNamespace("MAPI")
Set emailFolder = emailNameSpace.GetDefaultFolder(olFolderInbox)
Set emailItem = emailOutlookApp.CreateItem(olMailItem)
Set EmailRecipient = emailItem.Recipients
EmailRecipient.Add (EmailAddress)
EmailRecipient.Add (EmailAddress2)
emailItem.Importance = olImportanceHigh
emailItem.Subject = "My Subject"
emailItem.Body = "The Body"
'-----Send the Email-----'
emailItem.Save
emailItem.Send
'-----Clear out the memory space held by variables-----'
Set emailNameSpace = Nothing
Set emailFolder = Nothing
Set emailItem = Nothing
Set emailOutlookApp = Nothing
Exit Sub
I'm not sure if "Outlook.Application.12" is correct. But I can't find a definitive answer for this.
For Outlook 2010, this is definitly corect Outlook.Application.14.
But, I don't know what about office 2007.
I think it's Outlook.Application.12 and for lower versions it is simply "Outlook.Application".
Here's the code I switched to for 2010:
Private Sub EmailBlahbutton_Click()
Dim mOutlookApp As Object
Dim OutMail As Object
Dim Intro As String
On Error GoTo ErrorHandler
Set mOutlookApp = GetObject("", "Outlook.application")
Set OutMail = mOutlookApp.CreateItem(0)
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'These are the ranges being emailed.
ActiveSheet.Range(blahblahblah).Select
'Intro is the first line of the email
Intro = "BLAHBLAHBLHA"
'Set the To and Subject lines. Send the message.
With OutMail
.To = "blahblah#blah.com"
.Subject = "More BLAH here"
.HTMLBody = Intro & RangetoHTML(Selection)
.Send
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
ActiveSheet.Range("A1").Select
ActiveWindow.ScrollColumn = ActiveCell.Column
ActiveWindow.ScrollRow = ActiveCell.Row
Set OutMail = Nothing
Set mOutlookApp = Nothing
Exit Sub
ErrorHandler:
Set mOutlookApp = CreateObject("Outlook.application")
Resume Next
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Why do you explicitly specify the version? Why not simply
Set emailOutlookApp = CreateObject("Outlook.Application")
Try "Outlook.Application.14". Not sure if this is related though: 2007 to 2010 upgrade issue
I realize it's not the exact issue, but it may lead you down the right path.
Related
I'm writing a process that needs to loop through all Excel files in a folder and save each one as a pipe delimited value.
I've done a lot of hunting on how to do this and most of them say to change the delimiter value in Region settings. This isn't an option for me as this will be implemented on a customer's system and I cannot change these settings.
I've got some code to work as a vba macro in each file, and I have a vbs script that loops through the files in a folder and converts them to tab delimited files, both of these were found from this site and adapted to do what I need.
This is the code i have so far:
WorkingDir = "C:\Test\Temp"
savedir="C:\Test\Temp\"
Dim fso, myFolder, fileColl, aFile, FileName, SaveName
Dim objExcel, objWorkbook
Dim lastColumn
Dim lastRow
Dim strString
Dim i
Dim j
Dim outputFile
Dim objectSheet
Dim objectCells
Set fso = CreateObject("Scripting.FilesystemObject")
Set myFolder = fso.GetFolder(WorkingDir)
Set fileColl = myFolder.Files
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
objExcel.DisplayAlerts = False
For Each aFile In fileColl
name= Left(aFile.Name,Len(aFile.Name)-Len(Extension))
Set objWorkbook = objExcel.Workbooks.Open(aFile)
Set objectSheet = objExcel.ActiveWorkbook.Worksheets(1)
Set objectCells = objectSheet.Cells
lastColumn = objectSheet.UsedRange.Column - 1 + objectSheet.UsedRange.Columns.Count
lastRow = objectSheet.UsedRange.Rows(objectSheet.UsedRange.Rows.Count).Row
SaveName = savedir & name & ".txt"
Set outputFile = CreateObject("Scripting.FileSystemObject").OpenTextFile(SaveName, 2, true)
For i = 1 To lastRow
objectSheet.Cells(i, 1).Select '<-- this is the line currently causing problems
strString = ""
For j = 1 To lastColumn
If j <> lastColumn Then
strString = strString & objectCells(i, j).Value & "|"
Else
strString = strString & objectCells(i, j).Value
End If
Next
outputFile.WriteLine(strString)
Next
objFileToWrite.Close
Set objFileToWrite = Nothing
Next
Set objWorkbook = Nothing
Set objExcel = Nothing
Set myFolder = Nothing
Set fileColl = Nothing
Set fso = Nothing
I don't really use vb that often, so I'm basically changing a line until it stops throwing errors then moving on to the next one.
I just cannot get this over the commented line. It is currently giving me the error "Select method of Range class failed" with code 800A03EC. Searching this has given me no real results...
The file pretty much has to be pipe delimited as the file contains a lot of the common delimiters (commas, tabs etc.).
Any help to get this to work is greatly appreciated. This is my first post here so apologies if I've given too much or too little info, just let me know and I'll update as required
Update
Have managed to get it working, my working code in answer below. If anyone has suggestions on how to make this faster it'd be appreciated :)
I managed to crack it, I had to activate the sheet I wanted before I could use it and also call the sheet by name instead of using "1". Working code is below in case it helps anyone else in the future. I know it's ugly and could probably be done better but it works :)
WorkingDir = "C:\Test\Temp"
savedir="C:\Test\Temp\"
Extension = ".xls"
neededextension= ".txt"
Dim fso, myFolder, fileColl, aFile, FileName, SaveName
Dim objExcel, objWorkbook
Dim lastColumn
Dim lastRow
Dim strString
Dim i
Dim j
Dim outputFile
Dim objectSheet
Dim objectCells
Set fso = CreateObject("Scripting.FilesystemObject")
Set myFolder = fso.GetFolder(WorkingDir)
Set fileColl = myFolder.Files
Set objExcel = CreateObject("Excel.Application")
objExcel.EnableEvents = false
objExcel.Visible = False
objExcel.DisplayAlerts = False
For Each aFile In fileColl
ext = Right(aFile.Name,Len(Extension))
name= Left(aFile.Name,Len(aFile.Name)-Len(Extension))
Set objWorkbook = objExcel.Workbooks.Open(aFile)
Set objectSheet = objExcel.ActiveWorkbook.Worksheets("MICE BOB")
Set objectCells = objectSheet.Cells
lastColumn = objectSheet.UsedRange.Column - 1 + objectSheet.UsedRange.Columns.Count
lastRow = objectSheet.UsedRange.Rows(objectSheet.UsedRange.Rows.Count).Row
SaveName = savedir & name & ".txt"
Set outputFile = CreateObject("Scripting.FileSystemObject").OpenTextFile(SaveName, 2, true)
For i = 1 To lastRow
objectSheet.Activate
objectSheet.Cells(i, 1).Select
strString = ""
For j = 1 To lastColumn
If j <> lastColumn Then
strString = strString & objectCells(i, j).Value & "|" ' Use ^ instead of pipe.
Else
strString = strString & objectCells(i, j).Value
End If
Next
outputFile.WriteLine(strString)
Next
objFileToWrite.Close
Set objFileToWrite = Nothing
Next
Set objWorkbook = Nothing
Set objExcel = Nothing
Set myFolder = Nothing
Set fileColl = Nothing
Set fso = Nothing
The only issue I have now is that the conversion takes a very long time. Does anyone have a suggestion on how to speed this up, or does the nature of this just mean it's going to be slow?
We have switched over to office 365 / outlook.
we have a legacy application in VB6 the was working fine with the previous version of outlook. but now we are having issues with an automated email with in VB6, that sends daily reports. Can someone tell me what is the equivalent of the following code is and what reference i need to point to?`
Dim mstrEmailTo As String 'email to addresses
Dim mstrEmailCC As String 'email cc addresses
mstrEmailTo = Text1.Text
mstrEmailCC = "TestEmail"
Dim oApp As Outlook.Application
Dim oCB As Office.CommandBar
Dim oCBTools As Office.CommandBarPopup
Dim oCBSelect As Office.CommandBarButton
Dim oInsp As Outlook.Inspector
Dim oCont As Outlook.MailItem
Set oApp = New Outlook.Application
Dim oInspLeft As Integer
Dim oContTo As String
Dim oContCC As String
Set oCont = oApp.CreateItem(olMailItem)
If mstrEmailTo <> "" Then
'objRecipients.AddMultiple mstrEmailTo, CdoTo
oCont.To = mstrEmailTo
End If
If mstrEmailCC <> "" Then
'objRecipients.AddMultiple mstrEmailCC, CdoCc
oCont.CC = mstrEmailCC
End If
'Set objNewMsg.Recipients = mobjSession.AddressBook(objRecipients, "Select recipients for the Daily report ...", , True, 2)
Set oInsp = oCont.GetInspector
oInsp.Display vbModeless
oInsp.WindowState = olNormalWindow
oInspLeft = oInsp.Left
oInsp.Left = -10000 'Set the Inspector off screen.
'Set to 250 to return it to viewable location
Set oCB = oInsp.CommandBars("Menu Bar")
Set oCBTools = oCB.Controls("&Tools")
Set oCBSelect = oCBTools.Controls("Address &Book...")
oCBSelect.Execute
oContTo = oCont.To
oContCC = oCont.CC
oCont.Close olDiscard
oInsp.Left = oInspLeft
Set oCont = Nothing
Set oCBSelect = Nothing
Set oCBTools = Nothing
Set oCB = Nothing
Set oApp = Nothing`
You don't need to simulate a button click to show an address book. You need to use SelectNamesDialog object for that - see https://learn.microsoft.com/en-us/office/vba/api/outlook.selectnamesdialog
I am trying to open automatically an excel document on a Mac OS X, but it doesn't work. My code is:
Sub Button81_Click()
Dim objWord
Dim objDoc
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open("/Users/ricardo/Miniman/miniman_uti.docx")
objWord.Visible = True
End Sub
Will the path be wrong? For this path "/Users/ricardo/Miniman/miniman_uti.docx" it opens excel files. Why not word files?
Can someone please help me?
Does this work for you?
sub Test()
dim objdoc as object
with CreateObject("word.application")
set objdoc = .documents.open("path")
end with
end sub
Code to safely open a word doc from a file.
Handles the case where you already have word open.
Dim w As Object
' If word is already open get ahold of the running instance
' Otherwise create a new instance
On Error Resume Next
Set w = GetObject(, "Word.Application")
If w Is Nothing Then Set w = CreateObject("Word.Application")
On Error GoTo 0
' Close all open files and shutdown Word
' Loop through any open documents and close them
Do Until w.Documents.Count = 0
w.Documents(1).Close
Loop
w.Quit False
Set w = Nothing
' Now that all instances of word are closed, open the template
Dim wdApp As Object
Dim wdDoc As Object
Set wdApp = CreateObject("Word.application")
wdApp.Visible = True
wdApp.DisplayAlerts = False
Set wdDoc = wdApp.Documents.Open(Filename:="MYPATH")
I have cut down the script to be as simple as possible. The issue is inserting an image in a table for Outlook 2013. This script works with older versions.
1 table, 1 row, 2 columns and using the AddPicture in a cell kills the script!
objTable.Cell(1, 1).Range.Text = objSelection.InlineShapes.AddPicture(strLogo)
Full script below. Any work arounds would be appreciated.
'-------------
On Error Resume Next
Set objSysInfo = CreateObject("ADSystemInfo")
strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUser)
strName = objUser.FullName
strMail = objuser.mail
strLogo = "c:\1.jpg"
Set objWord = CreateObject("Word.Application")
objWord.Visible = False
Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection
Set objRange = objDoc.Range()
Set objEmailOptions = objWord.EmailOptions
Set objSignatureObject = objEmailOptions.EmailSignature
Set objSignatureEntries = objSignatureObject.EmailSignatureEntries
objDoc.Tables.Add objRange, 1, 2
Set objTable = objDoc.Tables(1)
objTable.Cell(1, 1).Range.Text = objSelection.InlineShapes.AddPicture(strLogo)
objTable.Cell(1, 2).select
objSelection.TypeParagraph()
objSelection.TypeText strName
objSelection.Font.Bold = false
objSelection.TypeParagraph()
objSelection.TypeText strMail
objSignatureEntries.Add "Signature", objRange
objSignatureObject.NewMessageSignature = "Signature"
objSignatureObject.ReplyMessageSignature = "Signature"
objDoc.Saved = True
objWord.Quit
'----------------
Your error is obvious:
objTable.Cell(1, 1).Range.Text = objSelection.InlineShapes.AddPicture(strLogo)
this cannot work because you try to assign to .Text something that is not a string. Moreover: This has never worked, you just never noticed.
.AddPicture() already does all you want, just select the right spot in the document before:
objTable.Cell(1, 1).Select
objSelection.InlineShapes.AddPicture(strLogo)
Apart from this your script violates a few basic rules.
Always use Option Explicit. No exceptions, no "but", no arguments with "quick" or "only".
Never use On Error Resume Next as a global setting.
Write functions/subs to wrap up steps that can fail. On Error Resume Next has function scope, you can switch it on in a function to guard a line that can throw an error and it will be reset when the function ends.
If you can't/don't want to create an extra function, use On Error Goto 0 to end the effect of On Error Resume Next as soon as possible, but not before you've checked the Err variable to handle the error yourself.
Write functions/subs to structure your code.
A matter of preference, but I like to use With blocks.
Another matter of preference, but Hungarian notation makes no sense. By convention I use PascalCase for objects and camelCase for primitive values (strings, numbers, dates), along with speaking variable names.
Here's an improved version:
Option Explicit
Dim User, logo
Set User = GetCurrentUser
logo = "C:\1.jpg"
If Not User Is Nothing Then
CreateEmailSignature User, logo
Else
WScript.Echo "Could not retrieve user from AD."
End If
'------------------------------------------------------------------------------
Function GetCurrentUser()
Set GetCurrentUser = Nothing
On Error Resume Next
Set GetCurrentUser = GetObject("LDAP://" & CreateObject("ADSystemInfo").UserName)
End Function
'------------------------------------------------------------------------------
Sub CreateEmailSignature(ADUser, logoPath)
Dim Doc, Table
With CreateObject("Word.Application")
Set Doc = .Documents.Add
Set Table = Doc.Tables.Add(Doc.Range, 1, 2)
Table.Cell(1, 1).Select
InsertPictureFromFile .Selection, logoPath
Table.Cell(1, 2).Select
.Selection.TypeParagraph
.Selection.TypeText ADUser.FullName
.Selection.Font.Bold = False
.Selection.TypeParagraph
.Selection.TypeText ADUser.Mail
With .EmailOptions.EmailSignature
.EmailSignatureEntries.Add "Signature", Doc.Range
.NewMessageSignature = "Signature"
.ReplyMessageSignature = "Signature"
End With
Doc.Close False
.Quit False
End With
End Sub
'------------------------------------------------------------------------------
Sub InsertPictureFromFile(Selection, picturePath)
On Error Resume Next
Selection.InlineShapes.AddPicture picturePath
End Sub
'------------------------------------------------------------------------------
I found out that it is a 64 bit Office issue.
I have reinstalled on multiple pc's using 32 bit Office 2013 and everything works as it should.
I have a problem - instances of Excel and Word behave differently in the same procedure. Have a look at the code. The idea there is to have a procedure that handles resaving files in excel and word in various format combinations.
The problem is that I notice that word and excel behave differently - the appWord and appExcel have different type names. At some point appWord is changed from Application to Object, which then makes it impossible to close it. I don't understand the differences in the behaviour, since the code applied to them is identical.
Option Explicit
Dim fso
Dim appWord
Dim appExcel
Set fso = CreateObject("Scripting.FileSystemObject")
startWord
ResaveFiles appWord.Documents, "docx", 12, 0
appWord.quit
startExcel
ResaveFiles appExcel.Workbooks, "xlsx", 51, 56
appExcel.quit
MsgBox "All done."
Sub ResaveFiles(appType, srcExtName, srcExtNum, tmpExtNum)
Dim objFile
Dim objOpenFile
Dim strDirectory
For Each objFile in fso.GetFolder(".").Files
If lcase(fso.GetExtensionName(objFile)) = srcExtName Then
If typeName(appType) = "Documents" Then StartWord
If typeName(appType) = "Workbooks" Then StartExcel
Set objOpenFile = appType.Open(objFile.path)
strDirectory = fso.BuildPath(objOpenFile.path, fso.GetBaseName(objOpenFile.name) & "._temp")
objOpenFile.SaveAs strDirectory, tmpExtNum
objOpenFile.Close
msgBox typename(appType) & objFile
msgBox typename(appWord) 'First typename test
msgBox Typename(appExcel)
If typeName(appType) = "Documents" Then appWord.Quit
If typeName(appType) = "Workbooks" Then appExcel.Quit
set objOpenFile = appType.Open(strDirectory)
objOpenFile.SaveAs objFile.path, srcExtNum
objOpenFile.Close
fso.DeleteFile(strDirectory)
msgBox typename(appWord) 'Second typename test
msgBox Typename(appExcel)
End If
Next
End Sub
'Start Word
Sub StartWord
Set appWord = CreateObject("Word.Application")
appWord.visible = false
appWord.DisplayAlerts = false
End Sub
'Start Excel
Sub StartExcel
Set appExcel = CreateObject("Excel.Application")
appExcel.visible = false
appExcel.DisplayAlerts = false
End Sub
I have tested it in the following way (with two typename tests) - when there are word files available, first appWord is Application and appExcel is empty, then it changes to Object and appExcel stays Empty (in this case we get an error when the subprocedure ends at AppWord.Quit). When there are no word files, and the script is processing Excels, first appWord is Object and appExcel is Application, then appWord is still Object and appExcel is still Application - in this case there are no errors when the subprocedure ends, on the appExcel.Quit.
Maybe i'm wrong, just my opinion:
If typeName(appType) = "Documents" Then appWord.Quit
If typeName(appType) = "Workbooks" Then appExcel.Quit
set objOpenFile = appType.Open(strDirectory)
appType is a reference to what appWord.Documents or appExcel.Workbooks are referencing before entering your ResaveFiles Sub, where you instantiate a new copy of 'Excel.Application' or 'Word.Application', and in each of the cases, you instruct the application TO QUIT. The question is not why in the case of word you got an error. From my point of view YOU SHOULD got an error. The question is why, if instructed to quit, excel keeps open and maintaining references to handle your code.
EDIT - And not tried. Just adapted from OP code. Adapt as needed
Option Explicit
ResaveFiles "Word.Application", "docx", 12, 0
ResaveFiles "Excel.Application", "xlsx", 51, 56
MsgBox "All done."
Sub ResaveFiles(progID, srcExtName, srcExtNum, tmpExtNum )
Dim app, doc
Dim fso, objFile, objOpenFile, strDirectory
Set fso = CreateObject("Scripting.FileSystemObject")
For Each objFile in fso.GetFolder( "." ).Files
If LCase(fso.GetExtensionName( objFile.Name )) = srcExtName Then
' Get references
Set app = GetNewAppInstance( progID )
Set doc = GetDocumentHandler( app )
' Save temp
Set objOpenFile = doc.Open( objFile.Path )
strDirectory = fso.BuildPath( objOpenFile.path, fso.GetBaseName(objOpenFile.name) & "._temp" )
objOpenFile.SaveAs strDirectory, tmpExtNum
objOpenFile.Close
' Release objects
Set objOpenFile = nothing
Set doc = nothing
app.Quit
Set app = nothing
' Get references again
Set app = GetNewAppInstance( progID )
Set doc = GetDocumentHandler( app )
' Resave file
Set objOpenFile = doc.Open( strDirectory )
objOpenFile.SaveAs objFile.path, srcExtNum
objOpenFile.Close
' Release objects
Set objOpenFile = nothing
Set doc = nothing
app.Quit
Set app = nothing
' Clean
fso.DeleteFile(strDirectory)
End If
Next
End Sub
Function GetNewAppInstance( ByVal progID )
Set GetNewAppInstance = CreateObject( progID )
With GetNewAppInstance
.Visible = False
.DisplayAlerts = False
End With
End Function
Function GetDocumentHandler( app )
Dim name
name = app.Name
If InStr(name,"Excel") > 0 Then
Set GetDocumentHandler = app.Workbooks
ElseIf InStr(name,"Word") > 0 Then
Set GetDocumentHandler = app.Documents
Else
Set GetDocumentHandler = app
End If
End Function