Extract lines and print

[ekto]

Hi !

I need to do a Outlook VBA project. I have used about 8 hours of google and haven't got even started. Normally with Excel the thing would be done allready :banghead:


Here is an image of the Email(revome the () around dots):
www(.)robokara(.)fi/images/image.jpg

I have marked what text I would like to extract from the mail.

This text would be printed out from a label printer like this:
Kari Nurmi
Tapiolantie 21 B18
60150 SEINÄJOKI

I can set the label printer as a default printer for that PC, so I think that just a normal print command would do.

I have made a rule that regognices these mails and forwards them to right persons. The same rule also runs a patch that start our Disc Bublisher wich will make a DVD. The same rule should run the Script that prints the label.

Things I need help with:
How to make a VBA that finds nimi: from the Body-element and get's the rest of the line to an integer.

Could you guys help me?

[Charlize]

Sub Print_Label()
Dim MyPath As String, MyFile As String, Fileno As Long
Dim MyName As String, MyAdress As String, MyPlace As String
Dim TheResult As String
MyPath = "C:\"
Fileno = FreeFile
Open MyPath & "LabelAdress" & ".txt" For Output As #Fileno
'Mailmessage we are going to handle
Dim mymessage As Outlook.MailItem
'thebody = message, thesubject = subject, thedate = datevalue, strdate = stringdate
Dim thebody As String, thesubject As String, thedate As Date, strdate As String
'put mailmessage into mymessage. we use the active mailmessage in this example
Set mymessage = ActiveExplorer.Selection.Item(1)
'put body of message in thebody
thebody = mymessage.Body
'nimi:
'...
MyName = Mid(thebody, InStr(1, thebody, "nimi: ") + 6, _
InStr(InStr(1, thebody, "nimi: "), thebody, vbCrLf) - _
InStr(1, thebody, "nimi: ") - 6)
MyAdress = Mid(thebody, InStr(1, thebody, "osoite: ") + 8, _
InStr(InStr(1, thebody, "osoite: "), thebody, vbCrLf) - _
InStr(1, thebody, "osoite: ") - 8)
MyPlace = Mid(thebody, InStr(1, thebody, "postinro") + 9, _
InStr(InStr(1, thebody, "postinro"), thebody, vbCrLf) - _
InStr(1, thebody, "postinro") - 9)
MyPlace = MyPlace & " " & Mid(thebody, InStr(1, thebody, "kunta: ") + 7, _
InStr(InStr(1, thebody, "kunta: "), thebody, vbCrLf) - _
InStr(1, thebody, "kunta: ") - 7)
TheResult = MyName & vbCrLf & MyAdress & vbCrLf & Ucase(MyPlace)
Print #Fileno, TheResult
Close #Fileno
'You should alter the default options of notepad for printing
'You can change the margins to 10 mm, remove header and footer
'and take a bigger font to print.
'You need to do it with the file LabelAdress.txt when you open
'it manually in notepad. You can save your changes with this file.
Shell "NOTEPAD /P c:\LabelAdress.txt"
End SubCharlize

[ekto]

Thanks for the code!

What do I need to put here:
Sub Print Label (what to put here)
I need to put something there or else it will not show the VBA in the Rule dialog box?

Cheers!

[ekto]

I found this on the internet, but it didin't help:
Sub Print Label (MyMail As MailItem)

I can now select it from the Run Script dialog when making a rule, but it only process mail, wich is higlighted at outlook. Example a mail that has been last viewed. It does not process new mail.

Is it the MyMail As MailItem that is causing it?

[Charlize]

Here the modified script so it would run with any new message that arrives. Another possibility would be by using withevents in the thisoutlooksession. This option works without any rules. You define a folder to watch for every new mail (inbox in this case) and use select case or if structure to determine what to do with a new message.

We are using mymessage as variable instead of mymail.

The reason why it would only work on the selected mail is ... because it was designed like this (1st version at least). Now it should work if you define your rule.

Sub Print_Label(mymessage As Outlook.MailItem)
Dim MyPath As String, MyFile As String, Fileno As Long
Dim MyName As String, MyAdress As String, MyPlace As String
Dim TheResult As String
MyPath = "C:\"
Fileno = FreeFile
Open MyPath & "LabelAdress" & ".txt" For Output As #Fileno
'thebody = message from mail
Dim thebody As String
'put body of message in thebody
thebody = mymessage.Body
'nimi:
'...
MyName = Mid(thebody, InStr(1, thebody, "nimi: ") + 6, _
InStr(InStr(1, thebody, "nimi: "), thebody, vbCrLf) - _
InStr(1, thebody, "nimi: ") - 6)
MyAdress = Mid(thebody, InStr(1, thebody, "osoite: ") + 8, _
InStr(InStr(1, thebody, "osoite: "), thebody, vbCrLf) - _
InStr(1, thebody, "osoite: ") - 8)
MyPlace = Mid(thebody, InStr(1, thebody, "postinro") + 9, _
InStr(InStr(1, thebody, "postinro"), thebody, vbCrLf) - _
InStr(1, thebody, "postinro") - 9)
MyPlace = MyPlace & " " & Mid(thebody, InStr(1, thebody, "kunta: ") + 7, _
InStr(InStr(1, thebody, "kunta: "), thebody, vbCrLf) - _
InStr(1, thebody, "kunta: ") - 7)
TheResult = MyName & vbCrLf & MyAdress & vbCrLf & UCase(MyPlace)
Print #Fileno, TheResult
Close #Fileno
'You should alter the default options of notepad for printing
'You can change the margins to 10 mm, remove header and footer
'and take a bigger font to print.
'You need to do it with the file LabelAdress.txt when you open
'it manually in notepad. You can save your changes with this file.
Shell "NOTEPAD /P c:\LabelAdress.txt"
End Sub
Charlize

[ekto]

Thanks, this seems to work :beerchug:

One more thing I would like to ask:

Sometimes there is a Yritys: field on these forms.
How do I add it so, that it will be printed only when it appears on the code?

I tried to add it but I get an error, Invalid Procedure call or argument
Sub Print_Label(mymessage As Outlook.MailItem)
Dim MyPath As String, MyFile As String, Fileno As Long
Dim MyName As String, MyCompany As String, MyAdress As String, MyPlace As String
Dim TheResult As String
MyPath = "C:\0\"
Fileno = FreeFile
Open MyPath & "LabelAdress" & ".txt" For Output As #Fileno
'thebody = message from mail
Dim thebody As String
'put body of message in thebody
thebody = mymessage.Body
'nimi:
'...
MyName = Mid(thebody, InStr(1, thebody, "nimi: ") + 6, _
InStr(InStr(1, thebody, "nimi: "), thebody, vbCrLf) - _
InStr(1, thebody, "nimi: ") - 6)
MyCompany = Mid(thebody, InStr(1, thebody, "Yritys: ") + 8, _
InStr(InStr(1, thebody, "Yritys: "), thebody, vbCrLf) - _
InStr(1, thebody, "Yritys: ") - 8)
MyAdress = Mid(thebody, InStr(1, thebody, "osoite: ") + 8, _
InStr(InStr(1, thebody, "osoite: "), thebody, vbCrLf) - _
InStr(1, thebody, "osoite: ") - 8)
MyPlace = Mid(thebody, InStr(1, thebody, "postinro") + 10, _
InStr(InStr(1, thebody, "postinro"), thebody, vbCrLf) - _
InStr(1, thebody, "postinro") - 10)
MyPlace = MyPlace & " " & Mid(thebody, InStr(1, thebody, "kunta: ") + 7, _
InStr(InStr(1, thebody, "kunta: "), thebody, vbCrLf) - _
InStr(1, thebody, "kunta: ") - 7)
TheResult = MyName & vbCrLf & MyCompany & vbCrLf & MyAdress & vbCrLf & UCase(MyPlace)
Print #Fileno, TheResult
Close #Fileno
'You should alter the default options of notepad for printing
'You can change the margins to 10 mm, remove header and footer
'and take a bigger font to print.
'You need to do it with the file LabelAdress.txt when you open
'it manually in notepad. You can save your changes with this file.
'Shell "NOTEPAD /P c:\0\LabelAdress.txt"
End Sub


I changed the postinro to 10, so there will not be an empty space at the line.
The Shell command is a comment at this point, so I can test this with out using expensive labes.

[ekto]

It was because the Yritys was writen with capital Y. It works now since I change it to y.

Now it crashes, if there is no yritys, on the form. I need a statement?

[Charlize]

Sub Print_Label(mymessage As Outlook.MailItem)
Dim MyPath As String, MyFile As String, Fileno As Long
Dim MyName As String, MyAdress As String, MyPlace As String
Dim MyYritys As String
Dim TheResult As String
MyPath = "C:\"
Fileno = FreeFile
Open MyPath & "LabelAdress" & ".txt" For Output As #Fileno
'thebody = message from mail
Dim thebody As String
'put body of message in thebody
thebody = mymessage.Body
'nimi:
'...
MyName = Mid(thebody, InStr(1, thebody, "nimi: ") + 6, _
InStr(InStr(1, thebody, "nimi: "), thebody, vbCrLf) - _
InStr(1, thebody, "nimi: ") - 6)
MyAdress = Mid(thebody, InStr(1, thebody, "osoite: ") + 8, _
InStr(InStr(1, thebody, "osoite: "), thebody, vbCrLf) - _
InStr(1, thebody, "osoite: ") - 8)
MyPlace = Mid(thebody, InStr(1, thebody, "postinro") + 9, _
InStr(InStr(1, thebody, "postinro"), thebody, vbCrLf) - _
InStr(1, thebody, "postinro") - 9)
MyPlace = MyPlace & " " & Mid(thebody, InStr(1, thebody, "kunta: ") + 7, _
InStr(InStr(1, thebody, "kunta: "), thebody, vbCrLf) - _
InStr(1, thebody, "kunta: ") - 7)
'Yritys: yes or no
'Search for the place where the word Yritys: occures
'If found, it will return the position (number) where it starts
'If not found, it will skip the part that extracts the word
'after the searchstring (Yritys:)
If InStr(1, thebody, "Yritys:") <> 0 Then
MyYritys = Mid(thebody, InStr(1, thebody, "Yritys: ") + 8, _
InStr(InStr(1, thebody, "Yritys: "), thebody, vbCrLf) - _
InStr(1, thebody, "Yritys: ") - 8)
'Added Yritys in between street and city
TheResult = MyName & vbCrLf & MyAdress & vbCrLf & MyYritys & vbCrLf & UCase(MyPlace)
Else
'Address without Yritys
TheResult = MyName & vbCrLf & MyAdress & vbCrLf & UCase(MyPlace)
End If
Print #Fileno, TheResult
Close #Fileno
'You should alter the default options of notepad for printing
'You can change the margins to 10 mm, remove header and footer
'and take a bigger font to print.
'You need to do it with the file LabelAdress.txt when you open
'it manually in notepad. You can save your changes with this file.
Shell "NOTEPAD /P c:\LabelAdress.txt"
End Sub

[ekto]

It now runs regardless if Yritys has anything, but it wont print the Yritys.

So if there is nothing on it, or if there is, the label is the same.

Edit: I moved the Yritys to rigth place:
If InStr(1, thebody, "Yritys:") <> 0 Then
MyYritys = Mid(thebody, InStr(1, thebody, "Yritys: ") + 8, _
InStr(InStr(1, thebody, "Yritys: "), thebody, vbCrLf) - _
InStr(1, thebody, "Yritys: ") - 8)
'Added Yritys in between street and city
TheResult = MyName & vbCrLf & MyYritys & vbCrLf & MyAdress & vbCrLf & UCase(MyPlace)
Else
'Address without Yritys
TheResult = MyName & vbCrLf & MyAdress & vbCrLf & UCase(MyPlace)
End If

[Charlize]

Dear Ekto,

Watch the capital letters. You said yourself that it needed to search for yritys ... :bow:

Charlize

[ekto]

Yes, thanks! Now it works!

Do you know if there is different types of vbCrLf?
I think that the printer is not neceserly realyzing that. We had similar problem with one PHP system...

[Charlize]

vbcrlfis enter with a line feed I think. Instead of that, you could use chr$(13) for enter and if I'm not mistaken, chr$(10) for the linefeed. But I'm not an expert on that. If it works ... don't break it :).

Charlize

[ekto]

I got it working by installing newer version of the printer software. Thanks Charlize, you have been a real help.

One more quoestion,

Since Outlook is running on a PC wich is not used normally, I would like to add some error handling to the code. It would be nice, that if there is an error, it would just jump over that mail, and try the next.

I tried to use On error GoTo, but I didn't sucseed.