[vba] 셀범위를 html형식으로 변환하여 이메일보내기

 

셀범위를HtML로.xlsm

0.03MB

출처는 아래에.

Option Explicit

Sub SendEmailWithrRange()
Const olMailItem = 0
Dim rngToSend As Range, r As Range
Dim FileName As String, FileName2 As String
Dim strHtml As String

Set rngToSend = Selection
strHtml = RangeToHTML(rngToSend)
With Sheets("address")
    For Each r In .Range("a1", .Cells(Rows.Count, "a").End(xlUp))
    
        With CreateObject("Outlook.Application").CreateItem(olMailItem)
             .To = r.Value
            .Subject = "Html이메일 테스트"
            .htmlbody = strHtml
            .Save
            .Send
        End With
    Next
End With
End Sub

Function Tag(sValue As String, sTag As String, Optional sAttr As String = "", Optional bIndent As Boolean = False) As String
   
    Dim sReturn As String
   
    If Len(sAttr) > 0 Then
        sAttr = Space(1) & sAttr
    End If
   
    If bIndent Then
        sValue = vbTab & Replace(sValue, vbNewLine, vbNewLine & vbTab)
        sReturn = "<" & sTag & sAttr & ">" & vbNewLine & sValue & vbNewLine & "</" & sTag & ">"
    Else
        sReturn = "<" & sTag & sAttr & ">" & sValue & "</" & sTag & ">"
    End If
   
    Tag = sReturn
   
End Function
Public Function RangeToHTML(ByRef rRng As Range) As String
    
    Dim rRow As Range, rCell As Range
    Dim sTable As String, sTd As String, sHead As String
    Dim aCells() As String, aRows() As String, aAttr() As String, aHead(1 To 2) As String
    Dim lCellCnt As Long, lRowCnt As Long
    Dim lFontSize As Long
    
    '1. Get the font size of the last cell
    lFontSize = rRng.Cells(rRng.Cells.Count).Font.Size
    ReDim aRows(1 To rRng.Rows.Count)
    
    '2 create the style in the header
    aHead(1) = "td {font-family:" & rRng.Cells(1).Font.Name & "; font-size: " & lFontSize & "pt}"
    aHead(2) = ".bb {border-bottom: 1px solid black}"
    sHead = Tag(Tag(Join(aHead, vbNewLine), "style", , True), "head", , True)
    
    '3. Load up a 'cells' array and a 'rows' array FOR joining.
    For Each rRow In rRng.Rows
        lRowCnt = lRowCnt + 1: lCellCnt = 0
        ReDim aCells(1 To rRng.Columns.Count)
        For Each rCell In rRow.Cells
            lCellCnt = lCellCnt + 1
            
            '4. Deal with empty cells and multi-line cells
            If IsEmpty(rCell.Value) Then
                sTd = "&nbsp;"
            Else
                sTd = Replace(rCell.Text, Chr$(10), "<br />")
            End If
            
            '5. Bold and italic
            If rCell.Font.Bold Then sTd = Tag(sTd, "strong")
            If rCell.Font.Italic Then sTd = Tag(sTd, "em")
            
            '6. Font size
            If rCell.Font.Size <> lFontSize Then
                sTd = Tag(sTd, "div", "style=font-size:" & rCell.Font.Size & "pt")
            End If
            
            '7. Setting the cell alignment
            ReDim aAttr(1 To 3)
            aAttr(1) = AlignmentAttr(rCell)
            
            '8. Span rows and columns for merged  cells
            If rCell.MergeArea.Address <> rCell.Address Then
                aAttr(2) = "COLSPAN=""" & rCell.MergeArea.Columns.Count & """ ROWSPAN=""" & rCell.MergeArea.Rows.Count & """"
            End If
            
            '9. Bottom border
            If rCell.Borders(xlEdgeBottom).LineStyle <> xlLineStyleNone Then
                aAttr(3) = "class=""bb"""
            End If
            
            '10. Make string
            If rCell.MergeArea.Cells(1).Address = rCell.Address Then
                aCells(lCellCnt) = Tag(sTd, "td", Join(aAttr, Space(1)))
            End If
        Next rCell
        aRows(lRowCnt) = Tag(Join(aCells, vbNewLine), "tr", , True)
    Next rRow
    
    sTable = Tag(Join(aRows, vbNewLine), "table", "cellpadding=""2px""", True)
    
    RangeToHTML = Tag(sHead & vbNewLine & sTable, "html", , True)
    
End Function


Public Function AlignmentAttr(ByRef rCell As Range) As String
    
    Dim sReturn As String
    
    Select Case True
        Case rCell.HorizontalAlignment = xlLeft, (rCell.HorizontalAlignment = 1 And Not IsNumeric(rCell.Value))
            sReturn = "align=""left"""
        Case rCell.HorizontalAlignment = xlRight, (rCell.HorizontalAlignment = 1 And IsNumeric(rCell.Value))
            sReturn = "align=""right"""
        Case rCell.HorizontalAlignment = xlCenter
            sReturn = "align=""center"""
    End Select
    
    AlignmentAttr = sReturn
    
End Function

 

 

http://dailydoseofexcel.com/archives/2015/02/13/converting-an-excel-range-to-html-the-hard-way/?fbclid=IwAR1J72hSZ72zEQe3pHhnlXY1D3a1CRqJgd_iDzZs2HGhUViYMFQlLDe6EWY

 

Converting an Excel Range to HTML the Hard Way – Daily Dose of Excel