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
Related
I have a bit of code that works fine in VBA (e.g., Excel) but fails in VBScript. VBScript does not throw any errors and reports that the code completes with exit code 0, i.e., no problems. If you have Outlook installed then you can probably past the code as is into an Excel VBA and it'll run (although whoever has the someone#gmail.com account will be on your calendar.) What am I missing??
Thanks!
Sub main()
SendCalendarAppt "strSubject", "strBody", "strLocation", "someone#gmail.com", Now()
End Sub
Sub SendCalendarAppt(strSubject, strBody, strLocation, strAttendees, datDateTime)
Dim objOL 'As Outlook.Application
Dim objAppt 'As Outlook.AppointmentItem
Const olAppointmentItem = 1
Const olMeeting = 1
Const olNonMeeting = 0
Set objOL = CreateObject("Outlook.Application")
Set objAppt = objOL.CreateItem(olAppointmentItem)
objAppt.Subject = strSubject
objAppt.Start = datDateTime
objAppt.End = datDateTime + 1
objAppt.Location = strLocation
objAppt.RequiredAttendees = strAttendees
objAppt.MeetingStatus = olMeeting
objAppt.Send
Set objAppt = Nothing
Set objOL = Nothing
End Sub
How do you search for the last empty cell in an excel sheet from a vsto outlook addin?
I have the following code (not compiling)
Imports Excel = Microsoft.Office.Interop.Excel
Dim ExcelApp As New Excel.Application
Dim ExcelWorkbook As Excel.Workbook
Dim ExcelWorkSheet As Excel.Worksheet= ExcelWorkbook.Worksheets(1)
Dim ExcelRange As Excel.Range = ExcelWorkSheet.Range("A1","A600")
Dim currentFind As Excel.Range = Nothing
Dim firstFind As Excel.Range = Nothing
currentFind = ExcelRange.Find("*", , Excel.XlFindLookIn.xlValues, Excel.XlLookAt.xlPart, Excel.XlSearchOrder.xlByRows, Excel.XlSearchDirection.xlNext, False)
While Not currentFind Is Nothing
' Keep track of the first range you find.
If firstFind Is Nothing Then
firstFind = currentFind
' If you didn't move to a new range, you are done.
ElseIf currentFind.Address = firstFind.Address Then
Exit While
End If
currentFind = ExcelRange.FindNext(currentFind)
End While
ExcelWorkbook.ActiveSheet.range(currentFind).Select()
I have updated it according to Scott Holtzman's comments but now I get an error message: HRESULT: 0x800A03EC
The code does not have the correct hierarchy according to the Object Model.
You cannot define a Range object without first defining a Worksheet object, which needs a Workbook object before it can be defined.
Try this:
Set ExcelApp = New Excel.Application
Dim ExcelWorkbook as Excel.Workbook
Set ExcelWorkbook = ExcelApp.Workbooks.Open("myPath") 'actually opens a workbook to work with
Dim ExcelWorksheet as Excel.Worksheet
Set ExcelWorksheet = ExcelWorkbook.Worksheets("mySheet")
Dim currentFind As Excel.Range = Nothing
Dim firstFind As Excel.Range = Nothing
Dim Fruits As Excel.Range = ExcelWorksheet.Range("A1", "A200")
Set currentFind = Fruits.Find("apples", , Excel.XlFindLookIn.xlValues, Excel.XlLookAt.xlPart, Excel.XlSearchOrder.xlByRows, Excel.XlSearchDirection.xlNext, False)
...
Set currentFind = Fruits.FindNext(currentFind)
SOLVED: I have the following code (now compiling!)
Imports Excel = Microsoft.Office.Interop.Excel
Dim ExcelApp As New Excel.Application
Dim ExcelWorkbook As Excel.Workbook
Dim ExcelWorkSheet As Excel.Worksheet= ExcelWorkbook.Worksheets(1)
Dim LastRow As Integer
LastRow = ExcelWorkSheet.Columns(1).Find("*", , , , Excel.XlSearchOrder.xlByColumns, Excel.XlSearchDirection.xlPrevious).Row
ExcelWorkSheet.Range("A" & LastRow).Select()
My error was in the actual property library choice. Beware to choose:
XlSearchOrder.xlByColumns, Excel.XlSearchDirection.xlPrevious
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.
Using VB6, is it possible to get a list of all available domains in active directory?
Thanks,
Alex
Add references for ActiveDS type library, and ADO to your project.
Sub GetDomains()
Dim objRootDSE As IADs
Dim objBase As IADs
Dim path As String
Dim rsDomains As ADODB.Recordset
Dim cnADS As ADODB.Connection
Dim cmdCommand As ADODB.Command
Set objRootDSE = GetObject("LDAP://rootDSE")
path = "LDAP://" & objRootDSE.Get("rootDomainNamingContext")
Set objBase = GetObject(path)
Set cnADS = New ADODB.Connection
cnADS.Provider = "ADsDSOObject"
cnADS.Open "ADSI"
Set cmdCommand = New ADODB.Command
cmdCommand.ActiveConnection = cnADS
cmdCommand.Properties("searchScope") = ADS_SCOPE_SUBTREE
cmdCommand.CommandText = "SELECT Name, distinguishedName FROM '" & objBase.ADsPath & "' WHERE objectCategory = 'domain'"
Set rsDomains = cmdCommand.Execute
Do While rsDomains.EOF = False
List1.AddItem (rsDomains!Name)
rsDomains.MoveNext
Loop
End Sub
I have only the one domain to test this against so I hope you'll need to let me know if it gets all the domains for you. Also please note, I didn't add error handling.
I'm working on an Outlook add-in that requires the Office specific FileDialog to interoperate with a Sharepoint site; the common file dialog doesn't have the interoperability. I know that both Word and Excel have a get_fileDialog method under Globals.ThisAddIn.Application.Application, but Outlook doesn't seem to. How do I launch an Outlook FileDialog? Is it even possible?
Microsoft Common Dialog
If you have COMDLG32.OCX ("Common Dialog ActiveX Control") installed, then you can use this - it's explained here, with an example. (Scroll down just past the screenshot entitled "FIGURE 2: Don't try to select more than one file in Word! ").
It appears that Outlook's Application object does not offer FileDialog. But a simple workaround, if you are willing to have an Excel reference, is:
Dim fd As FileDialog
Set fd = Excel.Application.FileDialog(msoFileDialogFolderPicker)
Dim folder As Variant
If fd.Show = -1 Then
For Each folder In fd.SelectedItems
Debug.Print "Folder:" & folder & "."
Next
End If
'Add a "Module". Then add the declarations like this to it.
Option Explicit
Private Declare Function GetOpenFileName _
Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Public Function MyOpenFiledialog() As String
Dim OFName As OPENFILENAME
OFName.lStructSize = Len(OFName)
'Set the parent window
OFName.hwndOwner = Application.hWnd
'Set the application's instance
OFName.hInstance = Application.hInstance
'Select a filter
OFName.lpstrFilter = "Text Files (*.txt)" + Chr$(0) + "*.txt" + Chr$(0) + "All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
'create a buffer for the file
OFName.lpstrFile = Space$(254)
'set the maximum length of a returned file
OFName.nMaxFile = 255
'Create a buffer for the file title
OFName.lpstrFileTitle = Space$(254)
'Set the maximum length of a returned file title
OFName.nMaxFileTitle = 255
'Set the initial directory
OFName.lpstrInitialDir = "C:\"
'Set the title
OFName.lpstrTitle = "Open File - VB Forums.com"
'No flags
OFName.flags = 0
'Show the 'Open File'-dialog
If GetOpenFileName(OFName) Then
MsgBox "File to Open: " + Trim$(OFName.lpstrFile)
MyOpenFiledialog = Trim$(OFName.lpstrFile)
Else
MsgBox "Cancel was pressed"
MyOpenFiledialog = vbNullString
End If
End Sub 'Usage:
Private Sub Command1_Click()
Text1.Text = MyOpenFiledialog
End Sub
Public Sub TestFileDialog()
Dim otherObject As Excel.Application
Dim fdFolder As office.FileDialog
Set otherObject = New Excel.Application
otherObject.Visible = False
Set fdFolder = otherObject.Application.FileDialog(msoFileDialogFolderPicker)
fdFolder.Show
Debug.Print fdFolder.SelectedItems(1)
otherObject.Quit
Set otherObject = Nothing
End Sub
Private Sub multiEML2MSG()
Const PR_ICON_INDEX = &H10800003
Dim objPost As Outlook.PostItem
Dim objSafePost As Redemption.SafePostItem
Dim objNS As Outlook.NameSpace
Dim objInbox As Outlook.MAPIFolder
Set objNS = Outlook.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objPost = objInbox.Items.Add(OlItemType.olPostItem)
Set objSafePost = New Redemption.SafePostItem
Dim xlObj As Excel.Application
Dim fd As Office.FileDialog
Set xlObj = New Excel.Application
Set fd = xlObj.Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Select your PST File"
.ButtonName = "Ok"
.Show
If fd.SelectedItems.Count <> 0 Then
xDirect$ = fd.SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7)
licznik = 1
Do While xFname$ <> ""
XPathEML = xDirect$ & xFname$
XPathMSG = Replace(XPathEML, ".eml", ".msg", , , vbTextCompare)
Debug.Print XPath, Replace(XPath, ".eml", ".msg", , , vbTextCompare)
objPost.Save
objSafePost.Item = objPost
objSafePost.Import XPathEML, Redemption.RedemptionSaveAsType.olRFC822
objSafePost.MessageClass = "IPM.Note"
objSafePost.Fields(PR_ICON_INDEX) = none
objSafePost.SaveAs XPathMSG, Outlook.OlSaveAsType.olMSG
xFname$ = Dir
licznik = licznik + 1
Loop
End If
End With
xlObj.Quit
Set xlObj = Nothing
Set objSafePost = Nothing
Set objPost = Nothing
Set objInbox = Nothing
Set objNS = Nothing
End Sub