toolFunction


  CDOSendMail2



  
REM ******************************************************
REM メール送信2
REM ******************************************************
Function CDOSendMail2( _
svname, _
mailto, _
mailfrom, _
subj, _
body, _
files, _
cc, _
bcc, _
htmlbody _
)

	if not IsObject( Cdo ) then
		Call GetObj( "Cdo", "CDO.Message" )
	end if

	Dim aAuth,aUser,aFile

	if instr( mailfrom, vbTab ) > 0 then
		aAuth = Split( mailfrom, vbTab )
		aUser = Split( aAuth(1), ":" )
		Cdo.Configuration.Fields.Item _
		 ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
		Cdo.Configuration.Fields.Item _
		 ("http://schemas.microsoft.com/cdo/configuration/sendusername") = aUser(0)
		Cdo.Configuration.Fields.Item _ 
		 ("http://schemas.microsoft.com/cdo/configuration/sendpassword") = aUser(1)

		mailfrom = aAuth(0)
	end if

	Cdo.From = mailfrom
	Cdo.To = mailto
	Cdo.Subject	= subj
	Cdo.Textbody = body

	if cc <> "" then
		Cdo.Cc = cc
	end if
	if bcc <> "" then
		Cdo.Bcc = bcc
	end if
	if htmlbody <> "" then
		Cdo.Htmlbody = htmlbody
	end if

	Dim sv

	sv = Split(svname,":")

	Cdo.Configuration.Fields.Item _
	 ("http://schemas.microsoft.com/cdo/configuration/sendusing") = _
		2

	on error resume next
	Cdo.Configuration.Fields.Item _
	 ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = _
		sv(0)
	Cdo.Configuration.Fields.Item _
	 ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = _
		sv(1)
	on error goto 0

	Dim I

	if files <> "" then
		if instr( files, vbTab ) > 0 then
			aFile = Split( files, vbTab )
			For I = 0 to Ubound( aFile )
				Cdo.AddAttachment( aFile(I) )
			Next
		else
			Cdo.AddAttachment( files )
		end if
	end if

	Cdo.Configuration.Fields.Update

	on error resume next
	Cdo.Send
	if Err.Number <> 0 then
		CDOSendMail = Err.Description
	else
		CDOSendMail = ""
	end if
	on error goto 0

End Function
  










  infoboard   管理者用   
このエントリーをはてなブックマークに追加





フリーフォントWEBサービス
SQLの窓WEBサービス

SQLの窓フリーソフト

素材

一般WEBツールリンク

SQLの窓

フリーソフト

JSライブラリ