¨Ï¥ÎCDO±H°e¶l¥ó

198188

'Coded by [email protected]
'Purpose: ¨Ï¥ÎCDO±H°e¶l¥ó
'Advantage: ¤£¥²³z¹LOutlook±H°e
'Requisition: Microsoft CDO(the Collaboration Data Objects) for Windows 2000 Library

Option Explicit

'«Å§i¼Ò²ÕÅܶq¤Î°Ñ¼Æ
Dim objCDO As CDO.Message
Public theRng As Range
Const myUserId = "yourID"       '½Ð­×§ï¦¨§Aªº±b¸¹
Const myPassword = "yourPSW"    '½Ð­×§ï¦¨§Aªº±b¸¹±K½X
Const mySMTPServer = "smtp.gmail.com"  '½Ð­×§ï¦¨§Aªº±H°e¶l¥ó¦øªA¾¹
Const mySMTPport = 465      '¶·­×§ï¦¨§Aªº°e¥ó¦øªA¾¹¨Ï¥ÎªºPORT, Gmail¨Ï¥Îªº¬O465

'¬yµ{±±¨î
Sub Main()
    Application.StatusBar = "Sending..."        'ª¬ºA°T®§Åã¥Ü
    Set objCDO = New CDO.Message        '³Ð«Ø·sªºª«¥ó
    ServerSetting           '¦øªA¾¹³]¸m
    Set theRng = ActiveSheet.UsedRange      '¨úªº§@¥Î¤u§@ªí¨Ï¥Î½d³ò
    fillNsend   '¶ñ¥R¶l¥ó¦UÄæ¦ì¸ê°T¨Ã±H°e
    Set objCDO = Nothing        'ÄÀ©ñª«¥ó
    Application.StatusBar = False   '«ì´_ª¬ºA°T®§
End Sub

'³]¸m¶l¥ó¦øªA¾¹°Ñ¼Æ
'³o¬O§Ú¥ÎGmail´ú¸Õ¦¨¥\ªº°Ñ¼Æ, ½Ð°Ñ¾\§AªºEmail Serverªº³]¸m»¡©ú¨ú±Ë
Sub ServerSetting()
    With objCDO
        With .Configuration.Fields
            .Item(cdoSendUsingMethod) = cdoSendUsingPort
            .Item(cdoSendUserName) = myUserId
            .Item(cdoSendPassword) = myPassword
            .Item(cdoSMTPServer) = mySMTPServer
            .Item(cdoSMTPAuthenticate) = True
            .Item(cdoSMTPServerPort) = mySMTPport
            .Item(cdoSMTPUseSSL) = True
            .Update
        End With
    End With
End Sub

'¶ñ¥RÄæ¦ì¸ê°T«á±H°e
Sub fillNsend()
    With objCDO
        .From = """crdotlin""<" & myUserId & "@" & VBA.Mid(mySMTPServer, 6) & ">"
        .To = ActiveSheet.Range("a2").Text
        .Subject = "Test Test"
        .HTMLBody = RangetoHTML(theRng)
        .Send
    End With
End Sub

'´ú¸Õ
Sub TestSendSheet()
Dim Sht As Worksheet
'¹M¾ú©Ò¦³¤u§@ªí
For Each Sht In ThisWorkbook.Worksheets
    Sht.Activate        '±Ò°Ê¬°§@¥Î¤u§@ªí
    '¦pªGA2Àx¦s®æ¦¡¶l¥ó¦ì§}, «h±N¦¹¤u§@ªí±H°e¨ì¸Ó«H½c
    If ActiveSheet.Range("a2").Value Like "*@*" Then Main
Next
End Sub