Macro VBA to get selected text in Outlook 2003 - vba

I am trying to use this code snippet to get the selected text in outlook 2003
Sub SelectedTextDispaly()
On Error Resume Next
Err.Clear
Dim oText As TextRange
''# Get an object reference to the selected text range.
Set oText = ActiveWindow.Selection.TextRange
''# Check to see whether error occurred when getting text object
''# reference.
If Err.Number <> 0 Then
MsgBox "Invalid Selection. Please highlight some text " _
& "or select a text frame and run the macro again.", _
vbExclamation
End
End If
''# Display the selected text in a message box.
If oText.Text = "" Then
MsgBox "No Text Selected.", vbInformation
Else
MsgBox oText.Text, vbInformation
End If
End Sub
When running this macro I get the error
---------------------------
Microsoft Visual Basic
---------------------------
Compile error:
User-defined type not defined
Do I need to add any references to fix this up?

#Kusleika, I tried the option you had suggested and still the same errors came up.
Thanks for the help
May be I had not phrased my question in the proper way
Some more googling revealed that its not possible to get the selected text of a mail in preview pane. http://www.eggheadcafe.com/forumarchives/outlookprogram_VisualBasica/Aug2005/post23481044.asp
So I had to adjust the requirement so that I can do an action from an mail item window.
The following code helped me (had to make some changes to suit my needs)
Sub Blue_Code_Highlight()
Dim msg As Outlook.MailItem
Dim insp As Outlook.Inspector
Set insp = Application.ActiveInspector
If insp.CurrentItem.Class = olMail Then
Set msg = insp.CurrentItem
If insp.EditorType = olEditorHTML Then
Set hed = msg.GetInspector.HTMLEditor
Set rng = hed.Selection.createRange
rng.pasteHTML "<font style='color: blue; font-family:Times New Roman; font-size: 10pt;'>" & rng.Text & "</font><br/>"
End If
End If
Set insp = Nothing
Set rng = Nothing
Set hed = Nothing
Set msg = Nothing
End Sub
Source:http://www.outlookcode.com/threads.aspx?forumid=4&messageid=26992
#Kusleika thanks for the help, can I close this thread. Pls let me know.

Just in case someone is using the word editor instead of html, you can also insert this part:
If insp.EditorType = olEditorWord Then
Set hed = msg.GetInspector.WordEditor
Set word = hed.Application
Set rng = word.Selection
rng.Font.Name = "Times New Roman"
rng.Font.Size = 10
rng.Font.Color = wdColorBlack
End If
to get similar when word is the editor. i tried to paste this into a comment on the accepted answer, but it destroyed the formatting and was pretty useless, so posting as an answer.

Dim oText As Range
TextRange is a property of the TextFrame object. It returns a Range object. There is no TextRange object.

Related

Access prints my word document but the document does not close afterwards and does not show up in the task manager

I have an access database which prints a label as a word document. The word document is filled using the information from my access database and then closed. This works on my personal laptop and prints every time. When I transfer this to my work laptop it works the first time and then fails as the document has remained open. The document does not show up in the processes in task manager, my laptop is using office 365 and my work laptop is at office 2016 is this a version issue? Code below. If this is completely wrong could you please suggest the fix
Dim appWord As Word.Application
Dim doc As Word.Document
Dim thepath As String
thepath = CurrentProject.Path
'Avoid error 429, when Word isn't open.
On Error Resume Next
Err.Clear
'Set appWord object variable to running instance of Word.
Set appWord = GetObject(, "Word.Application")
If Err.Number <> 0 Then
'If Word isn't open, create a new instance of Word.
Set appWord = New Word.Application
End If
Set doc = appWord.Documents.Open(thepath & "\label.docx", , False)
'ActiveDocument.Tables(1).Cell(1, 1).va Me.PartNumber
'
'ActiveDocument.FormFields(fldPartNumber). = Me!PartNumber
If Selection.FormFields.Count >= 1 Then
MsgBox Selection.FormFields(1).Name
End If
ActiveDocument.FormFields("Text1").Result = Me.PartNumber
ActiveDocument.FormFields("Text2").Result = Me.SerialNumber
'MsgBox (ActiveDocument.FormFields("Text1").Result)
ActiveDocument.FormFields("Text10").Result = Me.BatchNumber
ActiveDocument.FormFields("Text7").Result = Me.Qty
ActiveDocument.FormFields("Text6").Result = Me.Lifex
ActiveDocument.FormFields("Text3").Result = Me.Station
ActiveDocument.FormFields("Text4").Result = Me.Store
ActiveDocument.FormFields("Text5").Result = Me.Bin
ActiveDocument.FormFields("Text11").Result = Me.Description
'.FormFields("fldCountry").Result = Me.Country
' FormFields("fldPhone").Result = Me.Phone
'.FormFields("fldFax").Result = Me.Fax
activedocuments.FormFields.Visible = True
'ActiveDocument.FormFields.Activate
appWord.DisplayAlerts = False
doc.PrintOut Background = True
appWord.DisplayAlerts = True
'CreateObject("Shell.Application").Namespace(0).ParseName("C:\Boeing Ireland Serviceable Label editable form.docx").InvokeVerb ("Print")
Set doc = Nothing
doc.Close
appWord.Quit (True)
Set appWord = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Number & ": " & Err.Description
'
End Sub
I think that the problem is the order that you are doing things at the end of the code. You should be closing/quitting objects before setting them to nothing. In addition, I would recommend that you have a single exit section that cleans up objects, regardless of whether there is an error or not. Something like:
Sub sFoo
On Error GoTo E_Handle
' Word automation code here
sExit:
On Error Resume Next
doc.Close
Set doc=Nothing
appWord.Quit (True)
Set appWord=Nothing
Exit Sub
E_Handle:
MsgBox Err.Description
Resume sExit
End Sub
Regards,
Ok, the answer here was a known issue in Microsoft Office automation the document was left open due to failing to reference an object. Microsoft issue 189618 was the reference that i used to fix this.
{Cause
Visual Basic has established a reference to Word due to a line of code that calls a Word object, method, or property without qualifying it with a Word object variable. Visual Basic does not release this reference until you end the program. This errant reference interferes with automation code when the code is run more than once.
Resolution
Modify the code so that each call to a Word object, method, or property is qualified with the appropriate object variable.}
My original error catch was to use on error resume next which allowed the real issue Runtime error 426 to be bypassed. This was due to the line of code setting the doc reference as
`enter code here`Set doc = Documents.Open(thepath & "\label.docx",,False,,,,True)'
as it doesn't reference appword it leaves an instance open. Hence my second time round open document. The fix was simple.
Set doc= appword.Documents.Open(thepath & "\label".docx",,False,,,,True) The code now works, below is a fully corrected and cleaned up version of the script which includes Applecores suggestion that was so kindly provided.
Private Sub Command67_Click()
On Error GoTo E_Handle
Dim appwd As Word.Application
Dim doc As Word.Document
Dim thepath As String
thepath = CurrentProject.Path
Set appwd = CreateObject("Word.Application")
appwd.Visible = True
Set doc = appwd.Documents.Open(thepath & "\label.docx", , False, , , , True)
doc.FormFields("Text1").Result = Me.PartNumber
doc.FormFields("Text2").Result = Me.SerialNumber & nullstring
doc.FormFields("Text10").Result = Me.BatchNumber & nullstring
doc.FormFields("Text7").Result = Me.Qty
doc.FormFields("Text6").Result = Me.Lifex
doc.FormFields("Text3").Result = Me.Station
doc.FormFields("Text4").Result = Me.Store
doc.FormFields("Text5").Result = Me.Bin & nullstring
doc.FormFields("Text11").Result = Me.Description
appwd.DisplayAlerts = False
doc.PrintOut Background = True
appwd.DisplayAlerts = True
doc.Close SaveChanges:=wdDoNotSaveChanges
Set doc = Nothing
appwd.Quit
Set appwd = Nothing
Exit Sub
sExit:
On Error Resume Next
doc.Close
Set doc = Nothing
appwd.Quit
Set appwd = Nothing
Exit Sub
E_Handle:
MsgBox Err.Description
Resume sExit
End Sub

VBA Code crashes PPT Application - unclear reason

I have a problem with the following Code. What happens is that my PPT application crashes while running the code. It does not always happen and it happens in different parts of the code.
I tried the application.wait-method, but it did not work.
help is appreciated since I am already working on this for days -.-. Thanks in advance.
Option Explicit
Public myfilename As String
Sub filepicker()
Dim i As Variant
MsgBox ("In the following dialog please choose the current file")
Dim myfilenamepicker As FileDialog
Set myfilenamepicker = Application.FileDialog(msoFileDialogFilePicker)
myfilenamepicker.InitialFileName = "C:\Users\Michael\Desktop\Test PPT"
myfilenamepicker.Show
If myfilenamepicker.SelectedItems.Count <> 0 Then
myfilename = myfilenamepicker.SelectedItems(1)
End If
End Sub
Sub Saveas_PPT_and_PDF()
Dim PP As PowerPoint.Presentation
Dim sh As Variant
Dim company, strPOTX, strPfad, pptVorlage, newpath, newpathpdf As String
Dim Cell As Range
Dim pptApp As Object
Call filepicker
Application.ScreenUpdating = False
' set the dropdown from which the company Is Selected
Set DropDown.ws_company = Tabelle2
' the company is the value selected in the dropdown, stored in "C2"
company = DropDown.ws_company.Range("C2").Value
On Error Resume Next
Set pptApp = GetObject(, "PowerPoint.Application")
On Error Resume Next
If pptApp Is Nothing Then
Set pptApp = CreateObject("PowerPoint.Application")
End If
On Error GoTo 0
'loop through the companies in the dropdown menu
For Each Cell In DropDown.ws_company.Range(DropDown.ws_company.Cells(5, 3), _
DropDown.ws_company.Cells(Rows.Count, 3).End(xlUp)).SpecialCells(xlCellTypeVisible)
DropDown.ws_company.Range("C2") = Cell
pptVorlage = myfilename
Debug.Print (myfilename)
Set PP = pptApp.Presentations.Open(pptVorlage)
newpath = Replace(myfilename, "AXO", "" & Cell & " AXO")
PP.UpdateLinks
PP.SaveAs newpath
newpathpdf = Replace(newpath, "pptx", "pdf")
Debug.Print (newpathpdf)
PP.ExportAsFixedFormat "" & newpathpdf & "", ppFixedFormatTypePDF, ppFixedFormatIntentPrint
pptApp.Presentations(newpath).Close
Set PP = Nothing
Next
' this part below closes PPT application if there are no other presentation
' object open. If there is at least 1, it leaves it open
If IsAppRunning("PowerPoint.Application") Then
If pptApp.Windows.Count = 0 Then
pptApp.Quit
End If
End If
Set pptApp = Nothing
Set PP = Nothing
End Sub
Function IsAppRunning(ByVal sAppName) As Boolean
Dim oApp As Object
On Error Resume Next
Set oApp = GetObject(, sAppName)
If Not oApp Is Nothing Then
Set oApp = Nothing
IsAppRunning = True
End If
End Function
I don't see anything obviously wrong but I can give you a strategy for debugging.
You will want to test all major manipulations seperately. You will want to run each test in the debugger and have screenupdating on so you can see what happens:
test the filepicker
test GetObject/CreateObject - do you really need it? You already have PowrPoint open it seems;
test your loop with a single hardcoded value. What happens with the focus when opening a presentation?
try without UpdateLinks; try without SaveAs and try without Export (i.e. just open a presentation and close it again).
check if the presentation really closes, otherwise you might end up with lots of open presentations.
test closing the application
test reading from a dropdown box
test the IsAppRunning function. Note that it sets On Error Resume Next but does not reset it. Note it does not set IsAppRunning = False anywhere.
try relevant parts of the above in a loop with and without debugging to see what happens and see if it crashes - there could be a timing problem in the Office application, e.g. trying to manipulate a presentation while it is not yet fully loaded.
Minimising your code can help isolate the area that causes the problem. I hope this helps.

Make outlook 2003 macro work when word is the editor?

What I have, is a similar piece of code & i made it work with the outlook editor (hard enough) and I am trying to get it to now work with Word acting as the outlook editor. (Users are used to word mail) I tried: To move the code directly into word under this document and it did nothing. To follow code i saw on: creating an objword objdoc and then pairing it with the outlook class type of deal, with no luck. Here is a sample of code:
Sub SetCategory()
Dim olMessage As Outlook.MailItem
Set olMessage = Application.ActiveInspector.CurrentItem
If olMessage.SenderName = donations Then
olMessage.Categories = "donations"
ElseIf olMessage.SenderName = "Donations" Then
olMessage.Categories = "donations"
End If
With olMessage
.Send
End With
End Sub
When using "word mail" you are not using Outlook. This describes how to invoke Outlook from Word. Once Outlook is open you can use Outlook VBA.
http://www.howto-outlook.com/howto/senddocasmail.htm
Untested, and you will have to remove the parts you do not need.
Sub SendDocAsMail()
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
On Error Resume Next
'Start Outlook if it isn't running
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0 ' <=== Important to see errors now if there are any
'Create a new message
Set oItem = oOutlookApp.CreateItem(olMailItem)
' --------------------------
'Set oItem = oOutlookApp.ActiveInspector.CurrentItem
If oItem.SenderName = donations Then
oItem.Categories = "donations"
ElseIf oItem.SenderName = "Donations" Then
oItem.Categories = "donations"
End If
' --------------------------
'Allow the user to write a short intro and put it at the top of the body
Dim msgIntro As String
msgIntro = InputBox("Write a short intro to put above your default " & _
"signature and current document." & vbCrLf & vbCrLf & _
"Press Cancel to create the mail without intro and " & _
"signature.", "Intro")
'Copy the open document
Selection.WholeStory
Selection.Copy
Selection.End = True
'Set the WordEditor
Dim objInsp As Outlook.Inspector
Dim wdEditor As Word.Document
Set objInsp = oItem.GetInspector
Set wdEditor = objInsp.WordEditor
'Write the intro if specified
Dim i As Integer
If msgIntro = IsNothing Then
i = 1
'Comment the next line to leave your default signature below the document
wdEditor.Content.Delete
Else
'Write the intro above the signature
wdEditor.Characters(1).InsertBefore (msgIntro)
i = wdEditor.Characters.Count
wdEditor.Characters(i).InlineShapes.AddHorizontalLineStandard
wdEditor.Characters(i + 1).InsertParagraph
i = i + 2
End If
'Place the current document under the intro and signature
wdEditor.Characters(i).PasteAndFormat (wdFormatOriginalFormatting)
'Display the message
oItem.Display
'Clean up
Set oItem = Nothing
Set oOutlookApp = Nothing
Set objInsp = Nothing
Set wdEditor = Nothing
End Sub
Edit: Added, based on comment. This is a step that beginners trip on.
"Since this macro also uses Outlook functionality to create the mail we must add the reference to the project. To do this choose Tools-> References… and select Microsoft Outlook 12.0 Object Library (or 14.0 when using Outlook 2010). After this press OK."
Latest Outlook versions use Word as an email editor by default. There is no need to check out the editor type. The WordEditor property of the Inspector class returns the Microsoft Word Document Object Model of the message being displayed. You can read more about that in the Chapter 17: Working with Item Bodies .
Also you may find the How to automate Outlook and Word by using Visual C# .NET to create a pre-populated e-mail message that can be edited article helpful.

How to take control of a running Word application from another Word

I would like to grab a running word application and insert some text.
The VBA/Macro code is run from another separate Microsoft application such as Word or Excel. Is this possible?
It is quite easy. You need just this simple code to put inside any Excel, PP, Outlook Module. To catch Word from Word... you don't need it, you are just in.
Sub catch_word()
Dim WRD As Object
On Error Resume Next
Set WRD = GetObject(, "Word.Application")
If WRD Is Nothing Then
MsgBox "Word Application is not open"
Else
'add new document and add text into it
Dim DOC
Set DOC = WRD.documents.Add
DOC.Content.Text = "First text into document"
End If
End Sub
Edit If you know the name of the document which is already opened you could go this simply way to catch it and put some text into it:
Sub catch_word_document()
Dim WRD As Object
On Error Resume Next
Set WRD = GetObject("Document1")
If WRD Is Nothing Then
MsgBox "Word Application is not open"
Else
'add text into it
WRD.Content.Text = "First text into document"
End If
End Sub
Thanks KazJaw.
How ever, I want to add text to the opened Word document and not add another.
Based on your code
Sub catch_word()
Dim WRD As Object
Dim WRD_WINDOWS As Object
Dim strTemp As String
On Error Resume Next
Set WRD = GetObject(, "Word.Application")
If WRD Is Nothing Then
MsgBox "Word Application is not open"
Else
Set WRD_WINDOWS = WRD.Windows
For Each win In WRD_WINDOWS
If (win.Document.FullName = "Document1") Then
win.Document.Range(Start:=125, End:=134).Text = "Some Text"
strTemp = win.Document.Range(Start:=5, End:=10).Text
End If
Next
End If

MS Outlook macro to strikeout selected text

The task is to apply strikeout to current font in selected text area.
The difficulty is that Outlook doesn't support recording macros on the fly - it wants code to be written by hand.
For example, the following simple code:
Selection.Font.Strikethrough = True
works for Word, but gives an error for Outlook:
Run-time error '424':
Object required
This assumes that you also have Word installed on your box. If so, you can access most of the Word OM from the Outlook VBE without referencing Word by using the ActiveInspector.WordEditor object.
Sub StrikeThroughinMailItem()
Dim objOL As Application
Dim objDoc As Object
Dim objSel As Object
Set objOL = Application
Set objDoc = objOL.ActiveInspector.WordEditor
Set objSel = objDoc.Windows(1).Selection
objSel.Font.Strikethrough = True
End Sub
Here are a few notes on messing around with the open message, there are no checks, it just assumes that you have an open mail item. If you would like to say a little more about what you want to do, and in what version, I may be able to help a little more.
Dim ActiveMessage As MailItem
Dim strHTML As String
Set ActiveMessage = ActiveInspector.CurrentItem
Debug.Print ActiveMessage.Body
Debug.Print ActiveMessage.HTMLBody
strHTML = Replace(ActiveMessage.Body, "This sentence is bold", _
"<STRONG>This sentence is bold</STRONG>")
ActiveMessage.HTMLBody = strHTML
Debug.Print ActiveMessage.HTMLBody
You need to access the Inspector's HTMLEditor or WordEditor. Check the help file for sample code. If you are using WordEditor then you can record macro in Word and incorporate the resultant code into the Outlook macro by using the WordEditor.
Public Sub DoIt()
'must set word as mail editor
'must set reference to word object library
Dim oInspector As Outlook.Inspector
Dim oDoc As Word.Document
Dim oItem As Outlook.MailItem
Set oItem = Outlook.Application.CreateItem(olMailItem)
oItem.BodyFormat = olFormatRichText 'must set, unless default is rich text
Set oInspector = oItem.GetInspector
oInspector.Display 'must display in order for selection to work
Set oDoc = oInspector.WordEditor
'better to use word document instead of selection
'this sample uses selection because word's macro recording using the selection object
Dim oSelection As Word.Selection
Set oSelection = oDoc.Application.Selection
oSelection.TypeText Text:="The task is to apply strikethroughout."
oSelection.MoveLeft Unit:=wdCharacter, Count:=4
oSelection.MoveLeft Unit:=wdCharacter, Count:=7, Extend:=wdExtend
oSelection.Font.Strikethrough = True
End Sub
Jumping off from Todd Main's excellent example above.
I slightly modified the code to work in the inline reply pane as we couldn't find a simple way to add strikethrough to the QAT or ribbon.
I also added an if block to toggle the strikethrough if it was already set.
Sub StrikeThroughinInlineReply()
Dim objOL As Application
Dim objDoc As Object
Dim objSel As Object
Set objOL = Application
Set objDoc = objOL.ActiveExplorer.ActiveInlineResponseWordEditor
Set objSel = objDoc.Windows(1).Selection
If objSel.Font.Strikethrough = False Then
objSel.Font.Strikethrough = True
Else
objSel.Font.Strikethrough = False
End If
End Sub