Outlook attachment + Numeric Cell

[RagingBokky]

Hi all,

I am trying to create an email where attachment has a some generic folder path but with cell value changes the final folder location

example

"\\server\nextfolder\nextfolder" & finalfoldername

add all files in folder as attachment in email

but I want my finalfoldername to be a converted cell from alphanumeric to just numeric so that the final file path would be

Cell A3 = CO258963

"\\server\nextfolder\nextfolder" & 258963

so that it would be taking all files from \\server\nextfolder\nextfolder\258963

 Sub Email

Dim OutApp As Object    Dim OutMail As Object
    Dim strbody As String
    Dim StrPath As String
    Dim strFilename As String
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)


    StrPath = "\\server\folder\folder" & Val(Range("A3"))
    i = 0
    
    strbody = "[COLOR=#4D4D4D][FONT=Arial]Hi,"


    
    
        On Error Resume Next
    With OutMail
        .to = ""
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = strbody
        'You can add a file like this
        Do While Len(strFilename) > 0
        
        strFilename = Dir(StrPath & "*.*")
        .Attachments.Add StrPath & strFilename
        
            
        i = i + 1
        If i > 15 Then Exit Do
        
        Loop
        
        .Display   'or use .Send
    End With
    On Error GoTo 0


    Set OutMail = Nothing
    Set OutApp = Nothing




End Sub[/FONT][/COLOR]

 

[wideboydixon]

Not 100% clear on the possible formats for A3 contents but this might get you started:

Public Sub Email()

    Dim fso As Object
    Dim outlookApp As Object
    Dim mailItem As Object
    Dim mailBody As String
    Dim networkFolder As Object
    Dim folderFile As Object
    Dim attachmentCount As Long
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set outlookApp = CreateObject("Outlook.Application")
    Set mailItem = outlookApp.CreateItem(0)

    Set networkFolder = fso.GetFolder("\\server\folder\folder\" & Mid(Range("A3"), 3))
    
    mailBody = "Hi,"

    On Error Resume Next
    
    With mailItem
        .To = ""
        .Cc = ""
        .Bcc = ""
        .Subject = "This is the Subject line"
        .HTMLBody = mailBody
        attachmentCount = 0
        For Each folderFile In networkFolder.Files
            .Attachments.Add folderFile.Path
            attachmentCount = attachmentCount + 1
            If attachmentCount > 15 Then Exit For
        Next
        
        .Display   'or use .Send
    End With
    
    On Error GoTo 0

    Set mailItem = Nothing
    Set outlookApp = Nothing
    Set fso = Nothing

End Sub

WBD

 

[ZVI]

This converts cell's value from alphanumeric to just numeric:

Sub Email()
  '...
  StrPath = "\\server\folder\folder" & NumCode(Range("A3").Value)
  '...
 
End Sub
 
Function NumCode(Txt As String) As String
  Static RegEx As Object
  If RegEx Is Nothing Then
    Set RegEx = CreateObject("VBScript.RegExp")
    RegEx.Global = True
    RegEx.Pattern = "\D+"
  End If
  NumCode = RegEx.Replace(Txt, vbNullString)
End Function

 

[daverunt]

I found this function, which I use. You can modify the ascii characters in the Case line.

AlphaNumericOnly(Range("A3").Value)


Function AlphaNumericOnly(strSource As String) As String
    Dim i As Integer
    Dim strResult As String

    For i = 1 To Len(strSource)
        Select Case Asc(Mid(strSource, i, 1))
            Case 46, 48 To 57  '.' & 0-9
                strResult = strResult & Mid(strSource, i, 1)
        End Select
    Next
    AlphaNumericOnly = strResult
End Function

 

[RagingBokky]

Hi all,

sorry for the extremely late response just been busy at work to get back to looking at this. I find WBD solution doesn't work as fso.GetFolder appears to be an older function that no longer is supported with the outlook I am using (Outlook 2010), ZVI I tried your function and boy does it work wonders but...I can't seem to get the files to attach to outlook mail

I am not sure if I am missing something that is just not attaching the contents of folder into my outlook mail. I even thought it may not work as it could be stored on network storage and not local. even as simple as C:\[folder content of cell A3] would not work

 

[ZVI]

Two backslashes CHR(92) are missing in this code line (added are in red):

  strPath = "\\server\folder\folder\" & NumCode(Range("A3").Value) & "\"

This is your code fixed:

Sub Email()
 
  Dim OutApp As Object
  Dim OutMail As Object
  Dim strBody As String
  Dim strPath As String
  Dim strFilename As String
  Dim i As Long
 
  On Error Resume Next
  Set OutApp = GetObject(, ("Outlook.Application"))
  If Err Then Set OutApp = CreateObject("Outlook.Application")
  On Error GoTo 0
 
  Set OutMail = OutApp.CreateItem(0)
 
  strPath = "\\server\folder\folder\" & NumCode(Range("A3").Value) & "\"
  strBody = "Hi,"
 
  With OutMail
    .to = ""
    .CC = ""
    .BCC = ""
    .Subject = "This is the Subject line"
    .HTMLBody = strBody
    strFilename = Dir(strPath & "*.*")
    Do While Len(strFilename) > 0
      .Attachments.Add strPath & strFilename
      i = i + 1
      If i > 15 Then Exit Do
      strFilename = Dir
    Loop
    .Display 'or use .Send
  End With
 
  Set OutMail = Nothing
  Set OutApp = Nothing
 
End Sub
 
Function NumCode(Txt As String) As String
  Static RegEx As Object
  If RegEx Is Nothing Then
    Set RegEx = CreateObject("VBScript.RegExp")
    RegEx.Global = True
    RegEx.Pattern = "\D+"
  End If
  NumCode = RegEx.Replace(Txt, vbNullString)
End Function

 

[RagingBokky]

ZVI mate your an absolute legend

I had tried trying different folder path but did not realize I need 2 \ characters in place I only tried 1 after \folder which didn't work. I am only thinking that something like \\[network storage\\folder\folder\[Where files located]\ appears to be similar to Linux file structure but that could be me not understanding the file structure as I learn about it during standard C days.

Again thank you!!