I have a Word document and I want to do following with it:
Select some part of it when I open a Word doc (let´s say from page 40 to 45).
Reverse text in selected area.
Get text reversed again as it was before opening, when I close document.
I have this code, that reverses the text:
Sub ReverseSelectedWords()
Dim i As Integer
Dim oWords As Words
Dim oWord As Range
Set oWords = Selection.Range.Words
For i = 1 To oWords.Count Step 1
Set oWord = oWords(i)
Do While oWord.Characters.Last.Text = " "
Call oWord.MoveEnd(WdUnits.wdCharacter, -1)
Loop
Debug.Print "'" & oWord.Text & "'"
oWord.Text = StrReverse(oWord.Text)
Next i
End Sub
For what you've described as being your goal, it would make far more sense to apply a password for opening to the document and provide only the intended reader(s) with that password. No code required.
Related
I can read code, and adjust code a bit.
I've got access to a company email (say invoice#rr.com).
I want code which looks through all new mail in the inbox of invoice#rr.com (best if this works even when Outlook is not open, but a manually clicked macro would make me happy) and reply to all (with attachment) when:
there is more then one attachment (exception is one .xml and one .pdf file)
the attachment is not .pdf, .xml or .icf
when there is no attachment at all
when the title has the word "reminder"
when the message has the word "reminder"
Besides that, the code needs to move the mail to a subfolder called "send back".
I've been reading forums and one of the problems is a picture in a signature also counts as an attachment.
First try after help from Tony:
Sub reply()
'still need to get rid of all the stuff i dont use below (up to the *) but still not sure about the code so I left it here for now
Dim olInspector As Outlook.Inspector
Dim olDocument As Outlook.DocumentItem
Dim olSelection As Outlook.Selection
Dim olReply As MailItem
Dim olAtt As Attachment
Dim olFileType As String
Dim AttachCount As Long
Dim AttachDtl() As String
Dim ExcelWkBk As Excel.Workbook
Dim FileName As String
Dim FolderTgt As MAPIFolder
Dim HtmlBody As String
Dim InterestingItem As Boolean
Dim InxAttach As Long
Dim InxItemCrnt As Long
Dim PathName As String
Dim ReceivedTime As Date
Dim RowCrnt As Long
Dim SenderEmailAddress As String
Dim SenderName As String
Dim Subject As String
Dim TextBody As String
Dim myDestFolder As Outlook.Folder
'*
Set myDestFolder = Session.Folders("Outlook Data File").Folders("replied")
Set Myselect = Outlook.ActiveExplorer.Selection '(i use this in my test to only process selected test mails)
'Set FolderTgt = Session.Folders("invoice#rr.com").Folders("Inbox") ***(this will replace the code above)
For InxItemCrnt = Myselect.Items.Count To 1 Step -1 '(myselect = foldertgt in live)
With Myselect.Items.Item(InxItemCrnt) '(myselect = foldertgt in live)
'still need a workaround for mail with (1 .PDF and 1 .ICF) or (1 .PDF and 1 .XML)
'those combinations are the only combinations when more then one attachment is allowed
'1st filter
If AttachCount = 0 Then 'no attachment = reply
Reply0
.move myDestFolder
Else
'2nd filter
If AttachCount > 1 Then 'more then one attachment = reply
Reply1
.move myDestFolder
Else
'3rd filter
If InStr(Subject, "Reminder") = 0 Then 'reminders need to go to a different mailbox
Reply2
.move myDestFolder
Else
'4th filter
Select Case olFileType
Case ".pdf, .icf, .xml"
If olFileType = LCase$(Right$(olAtt.FileName, 4)) Then
Exit Sub 'if attachment = pdf or ICF then this sub can exit
Else
Reply3 'all mails with incorrect files
.move myDestFolder
End Select
End If
End If
End If
End If
End With
'replies below
Reply0:
Set olReply = Item.Reply '// Reply if no attachment found
olReply.Body = "this is an automatic generated mail." & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & ".... insert text...." 'still need to insert some text
olReply.Send
Reply1:
Set olReply = Item.Reply '// Reply more then one attachment
olReply.Body = "this is an automatic generated mail." & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & ".... insert text...." 'still need to insert some text
olReply.Send
Reply2:
Set olReply = Item.Reply '// Reply reminders need to go to reminder#rr.com
olReply.Body = "this is an automatic generated mail." & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & ".... insert text...." 'still need to insert some text
olReply.Send
Reply3:
Set olReply = Item.Reply '// Reply not correct file
olReply.Body = "this is an automatic generated mail." & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & ".... insert text...." 'still need to insert some text
olReply.Send
Next
Set olInspector = Nothing
Set olDocument = Nothing
Set olSelection = Nothing
Set olAtt = Nothing
End Sub
2nd try after some more help from Tony: (note: I'm Dutch so some code has dutch words I'll explain them in English behind the code, it basicly is copy paste from his answer, all credits to Tony)
Sub reply()
Dim Fso As New FileSystemObject
Dim DiagFile As TextStream
Dim FldrInvInbox As MAPIFolder
Dim InxA As Long
Dim InxItemCrnt As Long
Dim NumIcfAttach As Long
Dim NumPdfAttach As Long
Dim NumXmlAttach As Long
Dim NumDocAttach As Long
Dim NumDoxAttach As Long
Dim PathDiag As String
Dim Pos As Long
Dim ProcessThisEmail As Boolean
Dim Subject As String
Dim ReminderInBody As Boolean
Dim ReminderInSubject As Boolean
Dim ReminderInBody1 As Boolean
Dim ReminderInSubject1 As Boolean
Set FldrInvInbox = Session.Folders("invoice#rr.com").Folders("Postvak IN") 'Postvak IN = Inbox)
PathDiag = "z:\VBA test" 'location for diagnostics report
Set DiagFile = Fso.CreateTextFile(PathDiag & "\Diag.txt", True, False)
For InxItemCrnt = FldrInvInbox.Items.Count To 1 Step -1
With FldrInvInbox.Items.Item(InxItemCrnt)
' It is unlikely an Inbox will contain anything but emails
' but it does no harm to check
If .Class = olMail Then
' Extract information that will identify if this email is to be processed
ProcessThisEmail = True ' Assume True until find otherwise
'Below i'm looking for reminder, payment reminder and other similiar text in subject, dutch words are betalingsherinnering and openstaande posten
If InStr(1, LCase(.Subject), "betalingsherinnering") = 0 Then
ReminderInSubject = False
Else
ReminderInSubject = True
ProcessThisEmail = False
End If
If InStr(1, LCase(.Subject), "openstaande posten") = 0 Then
ReminderInSubject1 = False
Else
ReminderInSubject1 = True
ProcessThisEmail = False
End If
'Below i'm looking for reminder, payment reminder and other similiar text in mail, dutch words are betalingsherinnering and openstaande posten
If InStr(1, LCase(.Body), "betalingsherinnering") = 0 Then
ReminderInBody = False
Else
ReminderInBody = True
ProcessThisEmail = False
End If
If InStr(1, LCase(.Body), "openstaande posten") = 0 Then
ReminderInBody1 = False
Else
ReminderInBody1 = True
ProcessThisEmail = False
End If
NumIcfAttach = 0
NumPdfAttach = 0
NumXmlAttach = 0
NumDocAttach = 0
For InxA = 1 To .Attachments.Count
Select Case LCase(Right$(.Attachments(InxA).FileName, "3"))
Case "txt"
NumIcfAttach = NumIcfAttach + 1 'code will be changed soon, need to look at ICF in the name of the attachment
Case "pdf"
NumPdfAttach = NumPdfAttach + 1
Case "doc"
NumDocAttach = NumDocAttach + 1
Case "xml"
NumXmlAttach = NumXmlAttach + 1
End Select
Next InxA
Else ' Not email
ProcessThisEmail = False
End If
End With
' Decide if email is to be processed
If ProcessThisEmail = True Then
If NumXmlAttach > 1 Then
ProcessThisEmail = False
Else
If NumDocAttach <> 0 Then
ProcessThisEmail = False
Else
If NumPdfAttach > 1 Then
ProcessThisEmail = False
Else
If NumIcfAttach > 1 Then
ProcessThisEmail = False
Else
If NumIcfAttach + NumPdfAttach = 2 Then
ProcessThisEmail = True
Else
If NumXmlAttach + NumPdfAttach = 2 Then
ProcessThisEmail = True
Else
If NumXmlAttach = 1 And NumIcfAttach = 0 And NumPdfAttach = 0 And NumDocAttach = 0 Then
ProcessThisEmail = True
Else
If NumPdfAttach = 1 And NumIcfAttach = 0 And NumXmlAttach = 0 And NumDocAttach = 0 Then
ProcessThisEmail = True
Else
If NumIcfAttach = 1 And NumXmlAttach = 0 And NumPdfAttach = 0 And NumDocAttach = 0 Then
ProcessThisEmail = True
Else
If NumXmlAttach + NumPdfAttach + NumIcfAttach = 0 Then
ProcessThisEmail = False
Else
If NumXmlAttach + NumIcfAttach = 2 Then
ProcessThisEmail = False
Else
If NumXmlAttach + NumPdfAttach + NumIcfAttach = 3 Then
ProcessThisEmail = False
Else
If NumIcfAttach + NumPdfAttach <> 2 Then
ProcessThisEmail = False
Else
If NumXmlAttach + NumPdfAttach <> 2 Then
ProcessThisEmail = False
Else
Procisthisemail = False
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
' Output diagnostic information
DiagFile.WriteLine "----- " & InxItemCrnt & " -----"
With FldrInvInbox.Items.Item(InxItemCrnt)
DiagFile.WriteLine "ReceivedTime=" & .ReceivedTime
DiagFile.WriteLine "Sender=" & .Sender
Subject = .Subject
For Pos = Len(Subject) To 1 Step -1
If AscW(Mid(Subject, Pos, 1)) < 1 Or _
AscW(Mid(Subject, Pos, 1)) > 255 Then
Subject = Replace(Subject, Mid(Subject, Pos, 1), "?")
End If
Next
DiagFile.WriteLine "Subject=" & Subject
DiagFile.WriteLine "Reminders: Subject 1=" & ReminderInSubject & _
" Subject 2=" & ReminderInSubject1 & _
" Body 1=" & ReminderInBody & _
" Body 2=" & ReminderInBody1
DiagFile.WriteLine "Attachment counts: ICF=" & NumIcfAttach & _
" PDF=" & NumPdfAttach & " XML=" & NumXmlAttach & _
" Doc=" & NumDocAttach
DiagFile.WriteLine "ProcessThisEmail=" & ProcessThisEmail
End With
' Process email if required
If ProcessThisEmail Then
End If
Next InxItemCrnt
DiagFile.Close
End Sub
My first reaction is: there is way too much untested code in your revised question. I plan to review your code but most of this answer is a tutorial explaining how I would have tackled your requirement.
None of us were born with the knowledge to write the macro you need. I started with Excel VBA which I believe was lucky since the training material for Excel VBA is much better than that for Outlook VBA. I visited a good library and borrowed several “Teach yourself to program Excel” books. I tried them all and then bought the one that was best for my learning style. I would recommend you invest a few days learning Excel VBA. I am confident that this investment will quickly repay itself. I did buy a highly recommended Outlook VBA but was not impressed. The transition from Excel to Outlook was not as easy as it could have been because I have never found a good explanation of the Outlook Object Model. Most of my knowledge is the result of much experimentation over many years. This background means I can usually look at some badly explained Outlook property and be able to deduce what they meant to say.
One of my advantages is that I have spent time studying development and testing theory. There is little in your code that is wrong but I believe a different approach would produce the desired result more quickly.
Another advantage which I would recommend to you is a folder on my system named “Resources” with sub-folders by topic. Every time I complete a development, I look through the code for ideas I might need again. I capture each idea in a file in the appropriate sub-folder with sample code, references to the source and notes on anything I found difficult. I don’t use VBA often enough to remember everything I have learnt. Being able to look for relevant files when starting a new development saves me a lot of time.
That’s enough general points. From your original question, I think you need the following for your requirement:
To read up or down the Inbox of invoice#rr.com.
To identify the number of attachments of an email and, if any, their extensions.
To check if the title of an email includes "remainder".
To check if body of an email includes "remainder".
To reply to selected emails
To move selected emails to folder “send back”
Your original specification of which emails were to be selected is not clear to me. Your added code is a little clearer but adds the complication that you appear to envisage different replies for different emails.
In your code, you do not read up or down the Inbox of invoice#rr.com. Instead you use Inspector to process selected emails. This would allow you to select an email with no attachments, say, and test how you code handles it. I do not think this is a good idea. For me, reading down the inbox and selecting the emails to be processed is the larger and more complicated block of code. I would want to write and test that code before writing the code to replying or moving emails. I would not want to reply to emails until I knew I had everything else correct. I would not want to move emails to a different folder until near the end of testing because I would not want to move them back for a retest.
The potential problem with my approach is the number of emails in the Inbox of invoice#rr.com. How do I test each email is correctly identified as needing a reply or not needing a reply? VBA comes with some diagnostic aids but one of my favourite technique is to write the envelope for my code but to output diagnostic text identifying the decisions made by the code without acting on those decisions. The code I have written shows what I mean by this.
To output diagnostic text, I can use something like Debug.Print "xxxx=" & xxxx where xxxx is a variable. This outputs to the Immediate Window which is often the most convenient technique. But you can only see the last 200 or so displays with Debug.Print and I suspect this will not be enough. Instead I will output to a text file. I do not do this often enough to remember the syntax so I have a file to remind me. File “Output to diagnostic file.txt” contains:
' Needs reference to Microsoft Scripting Runtime
Dim Fso As New FileSystemObject
Dim DiagFile As TextStream
Dim PathDiag As String
PathDiag = ThisWorkbook.Path
PathDiag = CreateObject("WScript.Shell").specialfolders("Desktop")
Set DiagFile = Fso.CreateTextFile(PathDiag & "\Diag.txt", True, False)
DiagFile.WriteLine ""
DiagFile.Close
I do not need the reminder about “Microsoft Scripting Runtime” for Outlook because I referenced it when I first installed Outlook. You will need to open the Outlook VBA Editor, click Tools and select References from the drop down menu. Scroll down the list of libraries and tick “Microsoft Scripting Runtime”. Without this reference, the compiler will not recognise “FileSystemObject” or “TextStream”. I use the first value for PathDiag if I am working with Excel. Here I will use the second value which will create the file on the desktop.
I have taken code from the answer I referenced in my comment. I renamed some of the variables and simplified the handling of attachments. I inserted code from file “Output to diagnostic file.txt”. I added code to extract the values needed for selecting emails. This code only involves simple (for me) statements that I remember how to use correctly. I added the code to output diagnostics to the text file. Here I hit a problem. Execution stopped on DiagFile.WriteLine “Subject=" & .Subject saying this an invalid call. It took me a while to identify the cause and add code to fix it. I will explain this latter. Here is my code:
Option Explicit
Sub ReplyToInvoiceEmails()
Dim Fso As New FileSystemObject
Dim DiagFile As TextStream
Dim FldrInvInbox As MAPIFolder
Dim InxA As Long
Dim InxItemCrnt As Long
Dim NumIcoAttach As Long
Dim NumPdfAttach As Long
Dim NumXmlAttach As Long
Dim PathDiag As String
Dim Pos As Long
Dim ProcessThisEmail As Boolean
Dim Subject As String
Dim ReminderInBody As Boolean
Dim ReminderInSubject As Boolean
Set FldrInvInbox = Session.Folders("tonydallimore23#gmail.com").Folders("Inbox")
PathDiag = CreateObject("WScript.Shell").specialfolders("Desktop")
Set DiagFile = Fso.CreateTextFile(PathDiag & "\Diag.txt", True, False)
For InxItemCrnt = FldrInvInbox.Items.Count To 1 Step -1
With FldrInvInbox.Items.Item(InxItemCrnt)
' It is unlikely an Inbox will contain anything but emails
' but it does no harm to check
If .Class = olMail Then
' Extract information that will identify if this email is to be processed
ProcessThisEmail = True ' Assume True until find otherwise
If InStr(1, LCase(.Subject), "reminder") = 0 Then
ReminderInSubject = False
Else
ReminderInSubject = True
End If
If InStr(1, LCase(.Body), "reminder") = 0 Then
ReminderInBody = False
Else
ReminderInBody = True
End If
NumIcoAttach = 0
NumPdfAttach = 0
NumXmlAttach = 0
For InxA = 1 To .Attachments.Count
Select Case LCase(Right$(.Attachments(InxA).Filename, "3"))
Case "ico"
NumIcoAttach = NumIcoAttach + 1
Case "pdf"
NumPdfAttach = NumPdfAttach + 1
Case "xml"
NumXmlAttach = NumXmlAttach + 1
End Select
Next InxA
Else ' Not email
ProcessThisEmail = False
End If
End With
' Decide if email is to be processed
If ProcessThisEmail Then
If ReminderInSubject Or ReminderInBody Then
ProcessThisEmail = False
ElseIf NumXmlAttach = 1 Then
ProcessThisEmail = False
End If
End If
' Output diagnostic information
DiagFile.WriteLine "----- " & InxItemCrnt & " -----"
With FldrInvInbox.Items.Item(InxItemCrnt)
DiagFile.WriteLine "ReceivedTime=" & .ReceivedTime
DiagFile.WriteLine "Sender=" & .Sender
Subject = .Subject
For Pos = Len(Subject) To 1 Step -1
If AscW(Mid(Subject, Pos, 1)) < 1 Or _
AscW(Mid(Subject, Pos, 1)) > 255 Then
Subject = Replace(Subject, Mid(Subject, Pos, 1), "?")
End If
Next
DiagFile.WriteLine "Subject=" & Subject
DiagFile.WriteLine "Reminders: Subject=" & ReminderInSubject & _
" Body=" & ReminderInBody
DiagFile.WriteLine "Attachment counts: ICO=" & NumIcoAttach & _
" PDF=" & NumPdfAttach & " XML=" & NumXmlAttach
DiagFile.WriteLine "ProcessThisEmail=" & ProcessThisEmail
End With
' Process email if required
If ProcessThisEmail Then
End If
Next InxItemCrnt
DiagFile.Close
End Sub
The first executable statement is Set FldrInvInbox = Session.Folders("tonydallimore23#gmail.com").Folders("Inbox"). You must replace "tonydallimore23#gmail.com" with "invoice#rr.com" or the real name for this store. Apart from this change, this code should run without problems on your system.
Next are the statements to prepare the diagnostic text file and then: For InxItemCrnt = FldrInvInbox.Items.Count To 1 Step -1.
FldrInvInbox.Items is a collection holding all the items in FldrInvInbox. A collection is like an array (if you know what an array is) except you can add items to the middle of a collection and delete items from the middle. FldrInvInbox.Items.Count is the number of items in FldrInvInbox.Items. I am accessing items in this collection by their position. If the code decides item 5 is to be moved to another folder, item 6 become item 5, item 7 becomes item 6 and so on. This would mess up the For-Loop. I am accessing this collection starting from the end. If I move item 1000 to a different folder then items 1 to 999, which I have yet to process, do not move so the For-Loop works properly.
The next block of code extracts properties to variables. I think I have extracted every property you need but you must check. The next block of code decides if an email is to be processed. I like to divide code into blocks like this because it is easier to write and easier to understand if you need to change it in a year’s time. I do not understand how you want to select emails and I am sure my selection code is wrong. You will have to correct this block of code or provide more information on the selection process so I can correct it.
Next is code to create the diagnostic output. On my system, the diagnostic output looks like:
----- 55 -----
ReceivedTime=09/08/2018 13:03:09
Sender=TechTarget Channel Media
Subject=Channel ecosystem sees major shift in partner types
Reminders: Subject=False Body=False
Attachment counts: ICO=0 PDF=0 XML=0
ProcessThisEmail=True
----- 54 -----
ReceivedTime=09/08/2018 11:48:10
Sender=TechTarget
Subject=Industrial control systems a specialised cyber target
Reminders: Subject=False Body=False
Attachment counts: ICO=0 PDF=0 XML=0
ProcessThisEmail=True
----- 53 -----
The first three lines of each email identify the email so you can locate it in the folder. The second three lines are the selection values which I know are wrong.
If I had missed some selection values, you will have to add them. You will have to correct my selection code. You want every “ProcessThisEmail=True/False” line to be correct before we move on to the reply code.
The problem I encountered with the diagnostic code was because of emojis. Execution stopped on the statement outputting the subject for some emails and it took me sometime to locate the cause. The diagnostic file is a simple ASCII text file and an emoji cannot be output to an ASCII text file. I thought of ignoring the problem since you were unlikely to have emojis in your subject. I decided to fix the problem because you have neither the experience to diagnose the problem nor to experience fix it if you did diagnose it. Have a look at my code and try to understand what I have done.
I need you to complete tmy code before we move on to the next section. I will add some text about the next section later but this section is much later than I promised so I will post what I have now.
This next paragraphs are to get you thinking about the email bodies you will create and the ones you have checked for “Reminder”.
An Outlook email can have three bodies: a text body, an Html body and a Rich Text Format (RTF) body. I have never received an email with a RTF body. I have seen a question about them but to my mind they are obsolete; perhaps they were useful before Html became so well known. I will ignore the theoretical existence of RTF bodies. An Outlook email can have a text body, an Html body or both. If there is an Html body, that is the body that is shown to the user. I rarely receive emails without an Html body. The Html bodies I receive vary enormously in both appearance and the Html used to create that appearance. Many are very complicated with style sheets and nested table so the result will look good on a laptop or a smartphone or whatever device the user views it on. I said, an Outlook email can have an Html body without a text body but I cannot find one in my archives for the last few years. I suspect they are being created by Outlook from the Html body by deleting all the Html tags and adding carriage-return-linefeeds to mark deleted paragraphs and table cells.
With an Outlook email, property Body is the text body and property HtmlBody is the Html body. In my code I only check the text body for “Reminder”. This seems sensible since the text body will be a lot smaller and I cannot find an email without a text body. If you want to be ultra-cautious, I will show you how to check the Html body if there is no text body or you might like to consider how to do this as a training exercise.
In your code you have:
olReply.Body = "this is an automatic generated mail." & vbCrLf & vbCrLf & _
vbCrLf & vbCrLf & vbCrLf & ".... insert text...."
You might find that the following gives a more attractive appearance since email packages tend to use a more attractive font when displaying Html bodies if none is specified:
olReply.Body = ""
olReply.HtmlBody = "<HTML><BODY>" & _
"<P>this is an automatic generated mail.</P>" & _
"<P>.... insert text....</P>" & _
"</BODY>" & "</HTML>"
This is very basic Html and is now depreciated but it shows an Html body could be created for little more effort than creating a text body. Html also allows formatting (bold, italic, font size, font colour and so on) which might be helpful.
MS Word 2010 has a bug in its ability to correctly maintain (of all things) the documents collection (link to earliest report found - social.msdn.microsoft.com).
As far as I can tell this bug only impacts Word 2010. Although the documents collection is not maintained, it turns out that the Application.Windows collection is. Hence, for Word 2010 the following code based on the original reporters investigation (see below) and this question on answers.microsoft.com seem to provide a good alternative to the buggy documents collection:
' PURPOSE:
' Return a document collection, work-around for Word 2010 bug
Public Function docCollection() As VBA.Collection
Dim indexOfAvailableAppWindows As Long
Dim resultDoc As VBA.Collection
Dim foundDoc As Word.Document
Set resultDoc = New Collection
For indexOfAvailableAppWindows = 1 To Application.Windows.Count
If Application.Windows(indexOfAvailableAppWindows).Document.Type = wdTypeDocument Then
Set foundDoc = Application.Windows(indexOfAvailableAppWindows).Document
resultDoc.Add foundDoc, foundDoc.FullName ' Can NOT use 'name' - fails to be unique
End If
Next indexOfAvailableAppWindows
Set docCollection = resultDoc
Set resultDoc = Nothing
End Function
However, and here's my question, the above code some times fails with error 457 This key is already associated with an element of this collection on line resultDoc.Add foundDoc, foundDoc.FullName. What circumstances could possibly lead to such a failure?
So far the code has only failed on 1 PC running Word 2016. I don't have access to the PC. I did discover that the original version used Document.Name as the key (which was not always unique, so this was changed to Document.Full name)
Assumptions:
Document.FullName will always be unique
Things I've ruled out:
use of Split Window
opening downloaded documents (protected window documents are not counted)
Code that can be used to demonstrate the issue in Word 2010 (adapted from the original report).
' Function Credit Bas258 (https://social.msdn.microsoft.com/profile/bas258)
Function test01() As Boolean
'Adapted to VBA from original: 03-11-2012 1.0 Visual Studio 2008 VB code
Dim oDoc As Word.Document
Dim oDoc0 As Word.Document
Dim oDoc1 As Word.Document
Dim oDoc2 As Word.Document
Dim oDoc3 As Word.Document
Dim oDoc4 As Word.Document
Dim n As Integer
Set WDapp = Application
With WDapp
Debug.Print (Format(Now(), "dd-MM-yyyy") & " MS Office " & .Application.Version)
Set oDoc0 = .Documents.Add: Debug.Print ("add " & oDoc0.Name)
Set oDoc1 = .Documents.Add: Debug.Print ("add " & oDoc1.Name)
Set oDoc2 = .Documents.Add: Debug.Print ("add " & oDoc2.Name)
Set oDoc3 = .Documents.Add: Debug.Print ("add " & oDoc3.Name)
Set oDoc4 = .Documents.Add: Debug.Print ("add " & oDoc4.Name)
For n = 1 To .Documents.Count
Debug.Print ("count " & n & " " & .Documents(n).Name)
Next n
Debug.Print ("close " & oDoc4.Name)
oDoc4.Close
Set oDoc4 = Nothing
Debug.Print ("close " & oDoc3.Name)
oDoc3.Close
Set oDoc3 = Nothing
For n = 1 To .Documents.Count
Debug.Print ("count " & n & " " & .Documents(n).Name)
Next n
n = 0
For Each oDoc In .Documents
n = n + 1
Debug.Print ("doc " & n & " " & oDoc.Name)
Next oDoc
n = 0
For Each oWin In .Windows
n = n + 1
Debug.Print ("win " & n & " " & oWin.Document.Name)
Next oWin
Debug.Print ("close " & oDoc2.Name)
oDoc2.Close
Set oDoc2 = Nothing
Debug.Print ("close " & oDoc1.Name)
oDoc1.Close
Set oDoc1 = Nothing
Debug.Print ("close " & oDoc0.Name)
oDoc0.Close
Set oDoc0 = Nothing
End With
Set WDapp = Nothing
End Function
This is NOT going to be the accepted answer. Although it does answer the broader question (what could cause this code to crash) it not address the specific crash that I am trying to isolate. Either way there appears to be another bug in MS Word which seemed to be worth capturing for the common good.
This time the bug is with the Windows Collection; and joy of joys, I've confirmed it for both Word 2010 and Word 2016 - both 64 bit apps.
Steps to reproduce the bug are as follows:
In windows explorer enable the Preview Pane
Select a word document FILE so that it is 'previewed'
Open the same document (without losing the 'preview view')
Run the code from the OP, it will crash on this line:
If Application.Windows(indexOfAvailableAppWindows).Document.Type = wdTypeDocument Then
It turns out that when a word file is being previewed the Application.Windows.Count property is incremented by the preview; however any attempt to get a property of that window results in Error 5097 - Word has encountered a problem.
So, an improvement to the original code would therefore be:
' PURPOSE:
' Returns a healthy document collection
' - work-around for Word 2010 bug
' - excludes hits from Windows Explorer Preview Pane
Public Function docCollection() As VBA.Collection
On Error GoTo docCollectionError
Dim indexOfAvailableAppWindows As Long
Dim resultDoc As VBA.Collection
Dim foundDoc As Word.Document
Set resultDoc = New Collection
' Use index instead of Each to avoid For Loop Not initialised error, preview pane
For indexOfAvailableAppWindows = 1 To Application.Windows.Count
If Application.Windows(indexOfAvailableAppWindows).Document.Type = wdTypeDocument Then
Set foundDoc = Application.Windows(indexOfAvailableAppWindows).Document
resultDoc.Add foundDoc, foundDoc.FullName ' Key must NOT be 'name' - fails to be unique see BUG: 1315
End If
lblSkipThisDoc:
Next indexOfAvailableAppWindows
Set docCollection = resultDoc
Set resultDoc = Nothing
Exit:
Exit Function
docCollectionError:
If Err.Number = 5097 Then ' An open document is also open in the Windows Explorer Preview Pane
Err.Clear
Resume lblSkipThisDoc ' - skip this window
End If
If Err.Number = 457 Then ' Key is already used, but HOW? Unknown cause of error
Err.Clear
Stop 'Resume lblSkipThisDoc ' Is it safe to skip this document, why is there a duplicate?
End If
End Function
There is a setting in MS Word that enables 1 document to be viewed in 2 windows. In Word 2010 it is under the View (Tab): Window > New Window
The new window is counted separately in Application.Windows.Count and returns the same document object, hence the key exists.
For indexOfAvailableAppWindows = 1 To Application.Windows.Count ' <<< New Windows is counted
If Application.Windows(indexOfAvailableAppWindows).Document.Type = wdTypeDocument Then
Set foundDoc = Application.Windows(indexOfAvailableAppWindows).Document
resultDoc.Add foundDoc, foundDoc.FullName ' <<< fails to add 2nd instance of document
End If
So... the solution would likely involve checking the caption of the document:
IMMEDIATE WINDOW:
?foundDoc.Windows(1).Caption
Document2:1
I am trying to pull text between two symbols:
S1 | STAR2449524 | XYZ Bank | 1 - Critical |Health Service Heartbeat Failure.
I need to extract | XYZ Bank |
Which is between 2'nd appearance of symbol and place it in my template where variable name is COMP1 |
Sub Reply_Test()
Dim origEmail As MailItem
Dim replyEmail As MailItem
Dim oRespond As Outlook.MailItem
Dim INC1 As String 'For Incident Number
Dim INo As Integer 'For Incident Number
Dim COMP1 As String 'For Company Name
Dim Com As Integer 'For Company Name
Dim ISSU1 As String ' For Issue
Dim Isu As Integer 'for Issue
Dim varSplit As Variant
'Dim msginfo As msg.Subject (Tried using not worked)
varSplit = Split("New incident |S1 | ICM1449524 | XYZ Bank | P1 - Critical |Health Service Heartbeat Failure.", "|")
'varSplit = Split(msginfo, "|") (Tried using not worked)
strSubject1 = varSplit(0)
strSubject2 = varSplit(1)
strSubject3 = varSplit(2)
strSubject4 = varSplit(3)
strSubject5 = varSplit(4)
Set origEmail = Application.ActiveWindow.Selection.Item(1)
Set replyEmail = Application.CreateItemFromTemplate("H:\Documents\test.oft")
replyEmail.To = origEmail.Reply.To
replyEmail.CC = "abc#xyz.com"
replyEmail.HTMLBody = replyEmail.HTMLBody & origEmail.Reply.HTMLBody
replyEmail.Subject = replyEmail.Subject & origEmail.Reply.Subject
replyEmail.Subject = " <P1> - " & strSubject2 & " " & "For" & " " & strSubject3
replyEmail.Display
End Sub
A an alternative to the macro suggested in my comment, you may find the one below more convenient. Add something like:
Debug.Print "=====Text====="
Debug.Print TidyTextForDspl(.Body)
Debug.Print "=====Html====="
Debug.Print TidyTextForDspl(.HTMLBody)
Debug.Print "=====End====="
to your existing macro.
Public Function TidyTextForDspl(ByVal Text As String) As String
' Tidy Text for dsplay by replacing white space with visible strings:
' Replace spaces by {s} or {n s}
' Replace line feed by {lf} or {n lf}
' Replace carriage return by {cr} or {n cr}
' Replace tab by {tb} or {n tb}
' Replace non-break space by {nbs} or {n nbs}
' Where n is a count if the character repeats
' 15Mar16 Coded
Dim InsStr As String
Dim InxWsChar As Long
Dim NumWsChar As Long
Dim PosWsChar As Long
Dim RetnVal As String
Dim WsCharCrnt As Variant
Dim WsCharValue As Variant
Dim WsCharDspl As Variant
WsCharValue = Array(" ", vbLf, vbCr, vbTab, Chr(160))
WsCharDspl = Array("s", "lf", "cr", "tb", "nbs")
RetnVal = Text
For InxWsChar = LBound(WsCharValue) To UBound(WsCharValue)
Do While True
PosWsChar = InStr(1, RetnVal, WsCharValue(InxWsChar))
If PosWsChar = 0 Then
Exit Do
End If
NumWsChar = 1
Do While Mid(RetnVal, PosWsChar + NumWsChar, 1) = WsCharValue(InxWsChar)
NumWsChar = NumWsChar + 1
Loop
If NumWsChar = 1 Then
InsStr = "{" & WsCharDspl(InxWsChar) & "}"
Else
InsStr = "{" & NumWsChar & WsCharDspl(InxWsChar) & "}"
End If
RetnVal = Mid(RetnVal, 1, PosWsChar - 1) & InsStr & Mid(RetnVal, PosWsChar + NumWsChar)
Loop
Next
TidyTextForDspl = RetnVal
End Function
New section in response to question in comment
InStr is not the most useful function for your requirement. I recommend Split.
Split splits a string on a delimiter and returns the parts as an zero-based, one-dimensioned array.
The documentation says Split always returns a zero-based array and I have always found that to be true. However, there are functions that are affected by the Option Base statement so I always use the LBound function to be absolutely clear which element I am accessing.
This little macro uses Split to split your example string. I have used Trim to remove any leading or trailing spaces.
Option Explicit
Sub Test()
Dim Inx As Long
Dim Parts() As String
Parts = Split("S1 | ICM21449524 | XYZ Bank | P1 - Critical |Health Service Heartbeat Failure", "|")
For Inx = LBound(Parts) To UBound(Parts)
Debug.Print Inx & " [" & Trim(Parts(Inx)) & "]"
Next
End Sub
Second new section
You are not answering my question. Perhaps you do not understand its significance so I will give some demonstration code for the two most likely answers.
If you want a macro to process some emails, there are different ways of specifying which emails are to be processed.
One approach is for the user to select all the emails to be processed before starting the macro. If you click LeftMouse on an email, it is selected. If you then press and hold Shift while clicking Up or Down, you can select a block of contiguous emails. If you hold Ctrl while clicking LeftMouse on emails, you can select non-contiguous emails.
Select some emails and then run this macro:
Public Sub DemoExplorer()
Dim Exp As Outlook.Explorer
Dim ItemCrnt As MailItem
Dim NumSelected As Long
Set Exp = Outlook.Application.ActiveExplorer
NumSelected = Exp.Selection.Count
If NumSelected = 0 Then
Debug.Print "No emails selected"
Else
For Each ItemCrnt In Exp.Selection
With ItemCrnt
Debug.Print "--------------------------"
Debug.Print "From: " & .SenderName
Debug.Print "Subject: " & .Subject
Debug.Print "Received: " & Format(.ReceivedTime, "dMMMyy h:mm:ss")
End With
Next
End If
End Sub
The above macro is one of my standard demonstration macros. It outputs a number of properties of each of the selected emails to the immediate window. You are only interested in Subject but I decided to leave the others for reference.
Another approach is for the user to move the emails to be processed to a special folder with a name such as “ToProcess”. The macro is coded to look at folder “ToProcess” and to process the emails within it. After the emails have been processed, they can be moved on to another folder with a name such as “Processed”. This is not an approach I favour so I have no code to demonstrate it. Instead I explain how to amend the next macro to match this approach.
My most used approach is to search down Inbox for new emails with specific characteristics. The macro processes these emails and then moves them to a “Processed” folder. This approach saves the user the bother of searching for the emails to be processed and moving them twice.
The code below expects to find a folder “Processed2” within the default Inbox. Either create folder “Processed2” within the default Inbox and run my code unchanged or amend my code so FolderDest2 references a folder of your choice. This code processes any email with a pipe, “|”, in the Subject. You will need to expand my code so only the required emails are processed.
Public Sub DemoSearch()
Dim FolderDest2 As MAPIFolder
Dim FolderDest1 As MAPIFolder
Dim FolderSrc1 As MAPIFolder
Dim FolderSrc2 As MAPIFolder
Dim InxItemCrnt As Long
Dim InxPart As Long
Dim NS As Outlook.NameSpace
Dim SubjectPart() As String
Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")
' This is the easiest way to reference the default Inbox.
' However, you must be careful if, like me, you have multiple email addresses
' each with their own Inbox. The default Inbox may not be where you think it is.
Set FolderSrc1 = NS.GetDefaultFolder(olFolderInbox)
' This references the Inbox in a specific PST or OST file.
' "tonydallimore23#gmail.com" is the user name that Outlook gave the OST file in
' which it stores emails sent to this account when I created the account. The user
' name is the name Output displays to the user. The file name on disk is different.
Set FolderSrc2 = NS.Folders("tonydallimore23#gmail.com").Folders("Inbox")
' I do not know where you want to save processed emails. I have created
' FolderDest1 to show how to access a folder at the same level as Inbox
' but my code uses FolderDest2 which is a sub-folder of Inbox.
' This gets a reference to folder "Processed1" which is at the same level
' as the default Inbox.
' I have started at FolderSrc1 (Inbox) gone up one level to its parent
' (outlook data file) and doen to another child ("Processed1")
Set FolderDest1 = FolderSrc1.Parent.Folders("Processed1")
' This gets a reference to folder "Processed2" which is a sub-folder of
' the default Inbox.
Set FolderDest2 = FolderSrc1.Folders("Processed2")
' This examines the emails in reverse order.
' If I process email number 5 and then move it to another folder,
' the number of all subsequence emails is decreased by 1. If I looked at the
' emails in ascending sequence, email 6 would be ignored because it would have
' been renumbered wehn I looked for it. By looking at the emails in reverse
' sequence, I ensure email 6 has bee processed before the removal of email 5
' changes its number.
' I do not know how you identify the emails you want to process. I process
' any email with a pipe , "|", in the Subject
For InxItemCrnt = FolderSrc1.Items.Count To 1 Step -1
With FolderSrc1.Items.Item(InxItemCrnt)
If .Class = olMail Then
' I am only interested in mail items.
If .Subject <> "" Then
' ONlt attept split if there is a Subject
SubjectPart = Split(.Subject, "|")
If LBound(SubjectPart) <> UBound(SubjectPart) Then
' There is at least one pipe, "|", within the subject
Debug.Print "====="
Debug.Print " Sender " & .SenderEmailAddress
Debug.Print " Received " & Format(.ReceivedTime, "ddmmmyy hh:mm:ss")
Debug.Print " Subject: "
For InxPart = LBound(SubjectPart) To UBound(SubjectPart)
Debug.Print " " & Trim(SubjectPart(InxPart))
Next InxPart
.Move FolderDest2
End If ' LBound(SubjectPart) <> UBound(SubjectPart)
End If ' .Subject <> ""
End If ' .Class = olMail
End With ' FolderSrc1.Items.Item(InxItemCrnt)
Next InxItemCrnt
End Sub
If you prefer my second approach, you will need to amend the above code slightly. .Move FolderDest2, near the bottom, must be deleted. The statement near the top to specify the source folder will require amendment. I recommend you retain the code to identify emails to be processed in case the case accidentally move an inappropriate email to the source folder.
I hope running these two macros will fully explain the significance of my question. I wanted to only provide the code for the email selection method you preferred. I have now provided the code for the two major approach. Select whichever best meets your requirements as the basis for your macro.
As a part of a database that i am developing i have a function that i developed in Access 2010 . on presenting it to my Superiors i was asked to enhance the presentation or Display. i am just hoping someone can Point me the right direction..
so basically i am inserting some values from one table to the other. but i first run Loops to determine which field names match and copy from the Import table only those fields which match for the target table. so far it works perfectly. no Problems. i am displaying the matching field names in a msg box. the code for this field Name comparision is as follows:
Private Sub Command50_Click()
Dim n As Long
Dim m As Long
Dim Ret_Type As Integer
Dim str As String
Dim stp As String
Dim mystr As String
Dim mysas As String
Dim rs As DAO.Recordset
Dim rs1 As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("MLE_Table")
Set rs1 = CurrentDb.OpenRecordset("tbl_Import")
With rs
For n = 0 To .Fields.Count - 1
str = CurrentDb().TableDefs("MLE_Table").Fields(n).Name
With rs1
For m = 0 To .Fields.Count - 1
stp = CurrentDb().TableDefs("tbl_Import").Fields(m).Name
Debug.Print stp
If str = stp Then
mystr = mystr & str & ", "
fnd = True
Exit For
End If
Next m
If Not fnd Then mysas = mysas & str & vbCrLf
fnd = False
End With
Next n
.Close
End With
Ret_Type = MsgBox("The Following Fields could not be found in your upload !!" & vbCrLf & mysas, vbOKOnly + vbExclamation, " MISSING DATA")
End Sub
now what my colleagues want is that this msg box is not sufficient.. they want a more detailed Display. maybe a form or a text file or something so that the user has a more clear Picture.
the Suggestion was to Show up all the fields of the target table and then Show the fields that matched as green or maybe a tick or checkmark.
i am sure this cannot be done in a msgbox. i know it sounds elegant and i am not sure it can be done. some colleagues say it can be.
can somebody Point me in the right direction or some Suggestion please. i am not experianced enough in Access, so this would be a learning experiance..
thanks in advance..
What I like to do when I want to show text or data that doesn't fit into a MsgBox (or isn't suitable), is to paste it to a new Notepad window:
Shell "notepad", vbNormalFocus
ClipBoard_SetData strText ' google this function
SendKeys "^V", True
Or if it's tabular data, I open Excel and write it to a new sheet.
Starting a separate application has the additional advantage that users can easily save the data, if necessary.
Let's say I have a requirements document in MS Word, and someone else reviews it an provides a list of issues found using the "Track Changes" feature.
Is there a way to extract "how many major/minor issues were found during the review?" using an automated script - for metrics purposes?
I see CodeCollaborator has some MS Word integration, but it doesn't seem to know how to look inside Word to extract the tracked changes data. It just launches the document.
I did once write a Word macro that extracts the comments to a separate document, you are welcome to try adapting this to your purposes, if you have trouble then reply here and I can give you a hand with making changes.
Public Sub PROCESS_COMMENTS()
Dim strReplaceText As String
Dim myPar As Paragraph
Dim strCurrentColumn As String
Dim i As Integer
Dim Com As Comment
Application.ScreenUpdating = False
' set the input and output docs.
Set inDoc = ActiveDocument
' check we have comments to process in the original document
If inDoc.Comments.Count < 1 Then
MsgBox "No comments in the document"
Exit Sub
End If
' comments exist so create new document
Set outDoc = Documents.Add
Set outRange = outDoc.Content
outDoc.Range.InsertAfter "List of Comments:"
outDoc.Paragraphs(outDoc.Paragraphs.Count).Style = outDoc.Styles("Heading 1")
outDoc.Range.InsertParagraphAfter
' cycle through comments, inserting them in the new document
' display the new document and refresh
outDoc.Activate
Application.ScreenRefresh
For Each Com In inDoc.Comments
outRange.InsertAfter "[" & Com.Author & " - " & Com.Initial & Com.Index & "] "
outDoc.Paragraphs(outDoc.Paragraphs.Count).Range.Font.Bold = True
outDoc.Range.InsertParagraphAfter
outRange.InsertAfter Com.Range.Text
outDoc.Paragraphs(outDoc.Paragraphs.Count).Range.Font.Bold = False
Set myRange = Com.Scope
outDoc.Range.InsertParagraphAfter
outDoc.Range.InsertParagraphAfter
Next
Application.ScreenUpdating = True
Set outDoc = ActiveDocument
End Sub