vbs写法例子

On Error Resume Next
EnableEmailToInviteCustomerToCommentHotel=1
EnableSMSToInviteCustomerToCommentHotel=1
Call readConfig()
call perror("读取配制节错误",true)
If EnableEmailToInviteCustomerToCommentHotel=0 And EnableSMSToInviteCustomerToCommentHotel=0 Then
call WriteLog(Now()&"因配制节禁止发送短信和邮件，所以程序结束运行")
WScript.Quit
End if
dim LogFilePath,LogFilename,ErrorLogFilePath,ErrorLogFilename,Opip
LogFilePath = "d:/autorun/InviteCustomerToCommentHotelAfterCheckout/"&Year(Now())&"/"&Month(Now())&"/"
LogFilename = "InviteCustomerToCommentHotelAfterCheckout_"&Year(Now())&Month(Now())&Day(Now())
ErrorLogFilePath = LogFilePath
ErrorLogFilename =  "InviteCustomerToCommentHotelAfterCheckout_"&Year(Now())&Month(Now())&Day(Now())
Opip=GetIP()
call WriteLog(Now()&"程序开始运行")
Dim getPromotionInfostrPoint,getPromotionInfostrNoPoint,SMSstr
getPromotionInfostrPoint=getPromotionInfo(true)
getPromotionInfostrNoPoint=getPromotionInfo(false)
 SMSstr="我们真诚邀请您上www.abc..com对$#HotelId#$进行点评。期待您的再次光临！"
set conn=createobject("adodb.connection")
conn.commandtimeout=900
conn.Open "filedsn=lohoomastersql.dsn"
call perror("数据库连接错误",true)
Dim sql
'搜出离店时间在５天前到昨天的已结帐订单，且在CommunicationEvent表中２天之内没有类别为7或8的相关记录，
sql="SELECT r.reser_no,r.hotel_id,r.card_no,r.arrive_date,leave_date,r.email,r.phone,r.reser_status,h.hotel_name,p.service_type,p.salemodeltype,p.proxy_id,p.agent_type,m.habits,m.rec_email FROM reserve r INNER JOIN member m ON r.card_no=m.card_no INNER JOIN proxy p ON m.proxy=p.proxy_id inner join hotel h on h.hotel_id=r.hotel_id WHERE leave_date BETWEEN dateadd(day,datediff(day,0,getdate())-5,0) and dateadd(day,datediff(day,0,getdate())-1,0) AND reser_status='C' AND p.service_type IN (0,1,3) AND NOT exists (SELECT RelationBookingId FROM CommunicationEvent WHERE StartDate BETWEEN dateadd(day,-2,getdate()) AND getdate() AND (CommunicationEventPurposeTypeId =7 or CommunicationEventPurposeTypeId =8) and RelationBookingId=r.reser_no)"
set rs=conn.execute (sql)
call perror(sql,true)
while not rs.eof
  '会员是否接受邮件或短信
  isEnjoinEmail=false
  isEnjoinSMS=false
  If rs("rec_email")=1 Or rs("rec_email")=3 then
   isEnjoinEmail=True
  End If
  If rs("rec_email")=0 Or rs("rec_email")=1 then
   isEnjoinSMS=True
  End If
  '会员是否享受积分
  isJoinPointTag=false
  if rs("agent_type") = 0 then
   if habits and 8 then
    isJoinPointTag =false
   else
    isJoinPointTag=true
   end if
  elseif agent_type = 1 then
   if habits and 1024 then
    isJoinPointTag=true
   else
    isJoinPointTag =false
   end if
  end if
  CommunicationEventPurposeTypeId=0
  If rs("salemodeltype")="2" then
   If rs("email")<>"" And isEnjoinEmail And EnableEmailToInviteCustomerToCommentHotel=1  Then
    call MailSend(rs("arrive_date"),rs("leave_date"),rs("hotel_name"),rs("hotel_id"),getPromotionInfostrPoint,isJoinPointTag,"abc@abc.com")
    call perror("",false)
    phone=""
    CommunicationEventPurposeTypeId=7
   ElseIf rs("phone")<>"" And isEnjoinSMS And  Hour(Now())<22 And  Hour(Now())>11 And EnableSMSToInviteCustomerToCommentHotel=1 Then
     smsSendStr=Replace(SMSstr,"$#HotelId#$",rs("hotel_name"))
     sqlSMSSend=" insert into SMS_send_queue(reser_no,phone,sms_msg,operator,op_date,op_ip,reser_status,forbid_startdate,forbid_enddate,proxy_id,languages,order_from) values('"&rs("reser_no")&"','"&rs("phone")&"','"&smsSendStr&"','CustomerCareSMS',getdate(),'"&Opip&"','"&rs("reser_status")&"','','','"&rs("proxy_id") &"','CN',23) "
    conn.execute sqlSMSSend
    call perror(sqlSMSSend,false)
    phone=rs("phone")
    CommunicationEventPurposeTypeId=8
   End If
   If CommunicationEventPurposeTypeId<>0 then
   sqlSMScommunicationEvent="insert communicationEvent(CommunicationEventPurposeTypeId,CommunicationTypeId, ContactMechanismTypeId,ContactMechanism,RoleTypeIdFrom,PartyIdFrom,RoleTypeIdTo,PartyIdTo,StatusType,RelationBookingTypeId,RelationBookingId,notes,StartDate,OperatorName,OpDate,OpIp) values ("&CommunicationEventPurposeTypeId&",2,2,'"&phone&"',1,'abc',4,'"&rs("card_no")&"',1,6,'"&rs("reser_no")&"','',getdate(),'CustomerCareSMS',getdate(),'"&Opip&"')"
   conn.execute sqlSMScommunicationEvent
   call perror(sqlSMScommunicationEvent,false)
   End if
  End if
 rs.movenext
 wscript.sleep(1000)
 If Hour(Now())=11 Then
  rs.close
  set rs=nothing
  conn.close:set conn=Nothing
  call WriteLog("超过11点，程序结束")
  WScript.Quit
 End if
wend
rs.close
set rs=nothing
conn.close:set conn=Nothing

 

'从配制节中读限是否要发送邮件，短信
sub readConfig()
 IniFileName = "d:/autorun/CallCenter/ServerIP.Ini"
 MIS_Config_IniFilePath = ReadIni(IniFileName,"MIS_Config_IniFilePath")
 MIS_Config_IniFileName = "member.ini"
 EnableEmailToInviteCustomerToCommentHotel=ReadIni(MIS_Config_IniFilePath & MIS_Config_IniFileName,"EnableEmailToInviteCustomerToCommentHotel")
 EnableSMSToInviteCustomerToCommentHotel=ReadIni(MIS_Config_IniFilePath & MIS_Config_IniFileName,"EnableSMSToInviteCustomerToCommentHotel")
End sub
Function isJoinPoint(cardno)
 
End function

'发送邮件
sub MailSend(arrviedate,leavedate,hotelName,HotelId,promotionHTML,isJoinPoint,MailTo)
 arriveDateYear=Year(arrviedate)
 arriveDateMonth=month(arrviedate)
 arriveDateDay=day(arrviedate)
 leaveDateYear=Year(leavedate)
 leaveDateMonth=Month(leaveDateMonth)
 leaveDateDay=Day(leaveDateDay)
 If EnableEmailToInviteCustomerToCommentHotel=1 Then
  set WshShell = WScript.CreateObject ("WScript.Shell")
  
  tempath= WshShell.CurrentDirectory&"/"
  If isJoinPoint then
  tempath=tempath&"HotelCommenthtmlHavePointHtml.html"
  Else
  tempath=tempath&"HotelCommenthtmlNoPointHtml.html"
  End if
  MailBody=ReadText(tempath)
  MailBody=Replace(MailBody,"$#arriveDateYear#$",arriveDateYear)
  MailBody=Replace(MailBody,"$#arriveDateMonth#$",arriveDateMonth)
  MailBody=Replace(MailBody,"$#arriveDateDay#$",arriveDateDay)
  MailBody=Replace(MailBody,"$#leaveDateYear#$",leaveDateYear)
  MailBody=Replace(MailBody,"$#leaveDateMonth#$",leaveDateMonth)
  MailBody=Replace(MailBody,"$#leaveDateDay#$",leaveDateDay)
  MailBody=Replace(MailBody,"$#HotelName#$",HotelName)
  MailBody=Replace(MailBody,"$#HotelId#$",HotelId)
  MailBody=Replace(MailBody,"$#promotionHTML#$",promotionHTML)
  call SendCommentMail(MailTo,MailBody)
 End if
End sub
 

Function getPromotionInfo(isJoinPoint)
 If isJoinPoint then
  PromotionInfoUrl="http://www.abc.com/promotion/web/edm/customer_care/EnjoyPoints.html"
 Else
  PromotionInfoUrl="http://www.abc.com/promotion/web/edm/customer_care/NoPoints.html"
 End if
 Dim   serverXMLHTTP  
 Set   serverXMLHTTP=CreateObject("MSXML2.XMLHTTP")
 serverXMLHTTP.open   "GET",PromotionInfoUrl,false  
 serverXMLHTTP.send
 getPromotionInfo=BytesToBstr(serverXMLHTTP.responseBody, "GB2312")
End Function
'获取基本配制文件
Function getMIS_Config_IniFilePath()
 IniFileName = "d:/autorun/CallCenter/ServerIP.Ini"
 getMIS_Config_IniFilePath = ReadIni(IniFileName,"MIS_Config_IniFilePath")
End function
'建立文件夹
Function checkFolderExits(filePath)
  dim folderList,Folder_j,tempFolder,FileObject
  folderList=split(filePath,"/")
  tempFolder=folderList(0)
  For Folder_j = LBound(folderList) To UBound(folderList)
        if Folder_j>0 then
            tempFolder=tempFolder&"/"&folderList(Folder_j)
            Set FileObject=CreateObject("Scripting.FileSystemObject")
            if not FileObject.folderexists(tempFolder) then '如果该目录不存在        
                FileObject.createfolder(tempFolder) '创建一个文件夹                
           end if
        end if
  next
End function
sub perror(str,isQuit)
 dim t_str
 If Err.Number <> 0 Then
  If Err.Number >= 400 Then
   t_str=t_str&"Server returned error:" & Err.Number & Err.Description&chr(13)&chr(10)&str
  Else
   t_str=t_str&"Component/WinInet error:" & Err.Description&chr(13)&chr(10)&str
  End If
  call writeerrorlog(now()&" "&t_str)
  Call SendErrorMail(t_str)
  If isQuit Then
   If conn.state=1 then
   conn.close:Set conn=nothing
   End if
   WScript.Quit
  Else
   Err.clear
  End if
 End If
end Sub
Sub WriteErrorLog(T_Str)
 Dim fso, f
 Set fso = CreateObject("Scripting.FileSystemObject")
 If Not fso.FolderExists(ErrorLogFilePath) Then Set f = fso.CreateFolder(ErrorLogFilePath)
 Set f = fso.opentextfile(ErrorLogFilePath & "/" & ErrorLogFilename & DatePart("yyyy", Date) & "-" & DatePart("m", Date) & "-" & DatePart("d", Date) & ".txt", 8, True)
 f.writeline (T_Str)
 f.Close
 Set f = Nothing
 Set fso = Nothing
End Sub
Sub WriteLog(T_Str)
 checkFolderExits(LogFilePath)
 Dim fso, f
 Set fso = CreateObject("Scripting.FileSystemObject")
 If Not fso.FolderExists(LogFilePath) Then Set f = fso.CreateFolder(LogFilePath)
 Set f = fso.opentextfile(LogFilePath & "/" & LogFilename & DatePart("yyyy", Date) & "-" & DatePart("m", Date) & "-" & DatePart("d", Date) & ".txt", 8, True)
 f.writeline (T_Str)
 f.Close
 Set f = Nothing
 Set fso = Nothing
End Sub
Function ReadText(path)
 dim fso, f,str
 set fso = CreateObject("Scripting.FileSystemObject")
 set f = fso.OpenTextFile(path, 1, false)
 str=f.ReadAll()
 f.Close()
 set f = nothing
 set fso = Nothing
 readText=str
End function

'读取IniFileName中Item的值
Function ReadIni(IniFileName,item)
 Dim fso, f, LineStr, T_Item, T_Value
 T_Value = ""
 Set fso = CreateObject("Scripting.FileSystemObject")
 If fso.fileexists(IniFileName) Then
  Set f = fso.opentextfile(IniFileName, 1, True)
  Do While f.AtEndOfStream <> True
   LineStr = f.readline
   If InStr(UCase(LineStr), UCase(item)&"=") > 0 Then
    T_Item = Left(LineStr, InStr(LineStr, "=") - 1)
    T_Value = Right(LineStr, Len(LineStr) - InStr(LineStr, "="))
    Exit Do
   End If
  Loop
  f.Close
  Set f = Nothing
 End If
 Set fso = Nothing
 ReadIni=T_Value
End Function
Function GetIP
    ComputerName="."
    Dim objWMIService,colItems,objItem,objAddress
    Set objWMIService = GetObject("winmgmts://" & ComputerName & "/root/cimv2")
    Set colItems = objWMIService.ExecQuery("Select * From Win32_NetworkAdapterConfiguration Where IPEnabled = True")
    For Each objItem in colItems
        For Each objAddress in objItem.IPAddress
            If objAddress <> "" then
                 GetIP = objAddress
                Exit Function
            End If
        Next
    Next
End Function
'手机号码是否正确
function MobileRight(SMS_Mobile)
 dim flag
 flag=false
 if len(SMS_Mobile)=11 and left(SMS_Mobile,3)>="100" and left(SMS_Mobile,3)<"200" then
  flag=true
 end if
 if left(SMS_Mobile,4)>="0100" and left(SMS_Mobile,4)<"0200" then
  flag=true
 end if
 MobileRight=flag
end Function
Sub SendCommentMail(MailTo,MailBody)
 Dim  MailFrom,Subject,OtherOption
 Dim IniFileName, MIS_Config_IniFilePath, MIS_Config_IniFileName
 IniFileName = "d:/autorun/CallCenter/ServerIP.Ini"
 MIS_Config_IniFilePath = ReadIni(IniFileName,"MIS_Config_IniFilePath")
 MIS_Config_IniFileName = "VBS_Email.Ini"
 MailFrom = GetSQLListNum(ReadIni(MIS_Config_IniFilePath & MIS_Config_IniFileName,"Error_MailFrom"))
 set WshShell = WScript.CreateObject ("WScript.Shell")
 Subject = "艺龙网邀您参加酒店服务评价"
 OtherOption = "Type=Html"
 If Not StrNull(MailTo) And Not StrNull(MailFrom) Then
  Call SendJMail(MailTo,MailFrom,Subject,MailBody,OtherOption)
 End If
End Sub
'流转成字符
Function BytesToBstr(strBody,CodeBase)
 dim objStream
 set objStream = CreateObject("Adodb.Stream")
 objStream.Type = 1
 objStream.Mode =3
 objStream.Open
 objStream.Write strBody
 objStream.Position = 0
 objStream.Type = 2
 objStream.Charset = CodeBase
 BytesToBstr = objStream.ReadText
 objStream.Close
 set objStream = nothing
End Function

'程序错误结束发通知邮件---------------此下为需要发邮件专用，需全部复制
Sub SendErrorMail(errorstr)
 Dim MailTo, MailFrom, Subject, MailBody, OtherOption
 Dim IniFileName, MIS_Config_IniFilePath, MIS_Config_IniFileName
 
 IniFileName = "d:/autorun/CallCenter/ServerIP.Ini"
 MIS_Config_IniFilePath = ReadIni(IniFileName,"MIS_Config_IniFilePath")
 MIS_Config_IniFileName = "VBS_Email.Ini"
 MailTo = GetSQLListNum(ReadIni(MIS_Config_IniFilePath & MIS_Config_IniFileName,"Error_MailTo"))
 MailFrom = GetSQLListNum(ReadIni(MIS_Config_IniFilePath & MIS_Config_IniFileName,"Error_MailFrom"))
 set WshShell = WScript.CreateObject ("WScript.Shell")
 Subject = WshShell.CurrentDirectory & "InviteCustomerToCommentHotelAfterCheckout.vbs运行失败"
 MailBody = "客户关怀入住后酒店点评发生错误" & Now&errorstr
 OtherOption = "Type=Html"
 If Not StrNull(MailTo) And Not StrNull(MailFrom) Then
  Call SendJMail(MailTo,MailFrom,Subject,MailBody,OtherOption)
 End If
End Sub
Sub SendJMail(MailTo,MailFrom,Subject,MailBody,OtherOption)
 Dim i
 Dim Max
 Dim DefaultMailServer,IniFileName
 Dim MailType
 Dim str_server,msg,MailArray,BodyFrom,Attachment,blnReturnReceipt
 
 OtherOption = FormatOption(OtherOption)
 MailTo = Replace(MailTo,",",";")
 
 Do While InStr(OtherOption,";;") > 0
  OtherOption = Replace(OtherOption,";;",";")
 Loop
 
 '设置默认的发信Mail服务器(包括连接服务器的用户名及密码)
 '格式:UserName1:Password1@Server1;UserName2:Password2@Server2
 IniFileName = "d:/autorun/CallCenter/ServerIP.Ini"
 DefaultMailServer=ReadIni(IniFileName,"MailServer")
 Set Msg = CreateObject("JMail.Message")
 Msg.From = MailFrom
 Msg.Subject = Subject

 '设置收信人地址
 MailArray = Split(MailTo,";")
 Max = UBound(MailArray)

 If Max < 0 Then
  Exit Sub
 End If

 For i = 0 To Max
  Msg.AddRecipient MailArray(i)
 Next
 
 '设置邮件内容的文本来源，没有设置则为空
 '例子：SendMail(Mailto,MailFrom,Subject,MailBody,"BodyFrom=welcome.txt")
 BodyFrom = GetParameterValue(OtherOption,"BodyFrom")

 If BodyFrom <> "" Then
  Msg.AppendBodyFromFile(BodyFrom)
 End If

 '设置邮件使用文本方式还是HTML，默认为Text方式
 '例子：SendMail(Mailto,MailFrom,Subject,MailBody,"Type=Html")
 MailType = LCase(GetParameterValue(OtherOption,"Type"))

 If MailType = "html" Then
  Msg.AppendHtml(MailBody)
 Else
  Msg.AppendText(MailBody)
 End If

 '添加附件，例子：SendMail(Mailto,MailFrom,Subject,MailBody,"Attachment=button.gif,c:/autoexec.bat,welcome.txt")
 Attachment = GetParameterValue(OtherOption,"Attachment")
 If Attachment <> "" Then
  AttachmentArray = Split(Attachment,",")
  Max = UBound(AttachmentArray)
  For i = 0 To max
   Msg.AddAttachment AttachmentArray(i),True
  Next
 End If

 '设置邮件是否要求回执,默认为false
 '例子：SendMail(Mailto,MailFrom,Subject,MailBody,"ReturnReceipt=true")
 blnReturnReceipt = GetParameterValue(OtherOption,"ReturnReceipt")
 If Trim(blnReturnReceipt)="true" Then
  Msg.ReturnReceipt=True
 End If

 '设置编码格式为gb2312
 Msg.Charset="gb2312"
 Msg.Send(DefaultMailServer)
 Set Msg = Nothing
End Sub
'去掉通过ReadIni取得的字符串的前后，
Function GetSQLListNum(TStr)
 Dim Team_TM
 Team_TM=TStr
 If Not strnull(Team_TM) Then
  Team_TM=Replace(Team_TM,",,",",")
  If Right(Team_TM,1)="," Then Team_TM=Left(Team_TM,Len(Team_TM)-1)
  If Left(Team_TM,1)="," Then Team_TM=Right(Team_TM,Len(Team_TM)-1)
 End If
 GetSQLListNum=Team_TM
End Function

'字符串变量是否为空
Function StrNull(TStr)
 If IsNull(TStr) Or IsEmpty(TStr) Then
  StrNull=True
 ElseIf CStr(TStr)="" Then
  StrNull=True
 Else
  StrNull=False
 End If
End Function

Function FormatOption(Str)
 Str = ";" & Str & ";"
 Do While InStr(Str,";;") > 0
  Str = Replace(Str,";;",";")
 Loop
 If Len(Str) >= 2 Then
  Str = Mid(Str,2,Len(Str) - 2)
 Else
  Str = ""
 End If
 FormatOption = Str
End Function

'测试服务器和正式上的 DefaultMailServer 不同。设为空可以从本机发送。
Function GetParameterValue(TotalParameter,Parameter)
 Dim i
 Dim StartBit
 Dim EndBit
 Dim ParameterValue
 TotalParameter = ";" & TotalParameter & ";"
 i = InStr(TotalParameter,";" & Parameter & "=")
 If i > 0 Then
  StartBit = InStr(i,TotalParameter,"=")
  If StartBit > 0 Then
   Startbit = Startbit + 1
   Endbit = InStr(StartBit,TotalParameter,";")
   ParameterValue = Mid(TotalParameter,StartBit,Endbit - StartBit)
  End If
 End If
 GetParameterValue = Trim(ParameterValue)
End Function
'程序错误结束发通知邮件---------------此上为需要发邮件专用，需全部复制