Extracting Email Addresses From Shapes in Excel with VBA

[winwell]

I am pasting hundreds of items from an external app into an excel sheet. Each item includes an 'envelope' shape which contains the ussers email address (mailto:user.name@address.com).

This is the only way you can extract email addresses from this other app. (its an internal app not off the shelf)

I am using this code to extract the email address into a email list ready to paste into Outlook:

Option Explicit
Dim MyFile As String
Dim lastRow As Variant
Dim shp As Shape
Dim reciprng As Range
Dim fnum, recip As Variant
Dim mailrecip, Finished As String
Sub Go()
Application.ScreenUpdating = False
    Columns("F:K").Select
    Selection.Delete Shift:=xlToLeft
For Each shp In ActiveSheet.Shapes
    On Error Resume Next
    shp.BottomRightCell.Offset(0, 1).Value = shp.Hyperlink.Address
    On Error GoTo 0
Next shp
DeleteShapes
FormatEmails
Application.ScreenUpdating = True
CreateFile
End Sub
 
Sub DeleteShapes()
' I use this to delete the mail icons/shapes and clear the sheet
For Each shp In ActiveSheet.Shapes
    On Error Resume Next
    shp.Delete
    On Error GoTo 0
Next shp
' now delete the 5 blank columns before the addresses
Columns("A:E").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
End Sub
 
Sub FormatEmails()
Cells.Replace What:="mailto:", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
 
End Sub
 
Sub CreateFile()
MyFile = "C:\" & "MyMailingList.txt"
' you can call the file what ever you want
 With ThisWorkbook.Sheets("members")
    lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
      Set reciprng = .Range(.Cells(1, 1), .Cells(lastRow, 1))
        For Each recip In reciprng
          mailrecip = mailrecip & recip.Text & ";"
        Next recip
    mailrecip = Left(mailrecip, Len(mailrecip) - 1)
fnum = FreeFile()
Open MyFile For Append As fnum
Print #fnum, mailrecip;
Close #fnum
End With
Finished = MsgBox("A mailing list has been produced at " & MyFile & Chr(10) & Chr(10) _
                     & "Would you like to open this file now?", vbYesNo + vbQuestion, "Mailing List")
If Finished = vbYes Then Shell "notepad " & MyFile, vbNormalFocus
 
End Sub

This is the problem:

In the internal application, the email addresses under the shapes are stored like this:
billo'Hara@domain.com - this would be Bill O'Harra

Note how it stores an apostrophe (')

When I paste these accross to excel, they come like this:

billo& - 39;Hara@domain.com so the # is being replaced with " - "

When I run my macro, any email address containing an apostrophe is output like this:

bill.&o

the rest of the address is lost.

I've tried find/replace o the excel sheet before i run the macro, but it fails to find the text under the shapes.

When I paste the data into the members sheet, it is in the following format. (Just in case you want to try something out yourself)

10 columns A to K

Cols A to D are shapes, column E contains the shapes that I get the emails from. Cols F to K I don't need. The macro deltes F - K, extracts hyperlinks from the shapes, deletes the shapes, then deletes cols A to D I don't need, leaving me wiht a list of emails address in Col A

Can anyone see a way to fix the apostrophe problem? Is there a way to replace the "& - 39;" with "'" or "'" so the correct hyperlink is extracted from the shape?

Thanks

 

[pbornemeier]

Try pasting the data to an intermediate program such as Word, or Notepad, then copying from that file. You may also be able to do a successful search and replace in Word, which has more options than the Excel S&R.

 

[winwell]

thanks for the idea, but it didn't work.

Neither Work, nor excel can 'see' the underlying mailto text in order to replace it and the pictures are not proper shapes so are not available in the VB area to perform any operations on

 

[pbornemeier]

I can store an email address with an apostrophe in a shape, and then extract it with no problem. Is it possible that the codepage for the machine that generates the shapes can be changed so the program produce the ' instead of &#39 ?

http://en.wikipedia.org/wiki/Code_page

http://www.computing.net/answers/windows-2000/changing-code-page/65441.html

 

[winwell]

Thanks Phil, I wish it was possible, but unfortunately we have absolutley no control over it at all.

Its based on Documentum, so coding changes are is possible, but even minor changes would have to be done by our IT partners which would incur a cost - so no chance

 

[pbornemeier]

The modification to the code page is done at the OS level - depending on what OS the Documentum program is running on. It may not work.

If you type chcp at a command line prompt, you can see what your default code page is. What is the documentum system's OS default code page? Most of the common ones should render the &#39 as an apostrophe.

Googling for "apostrophe shows as 39" shows a lot of programs with similar problems.

Here is info for Win7:
http://www.sisulizer.com/localization/support/codepages-w7.shtml

 

[winwell]

My local machine is running code page 850, on Windows XP

However, the 3rd party app runs on a server.

I've tried changing the code page on my PC to a few others via chcp but it didn't make any difference as the apostrophe's still copy over as & - 39; rather than '

Thanks