QTP 错误截图、处理以及发送

 

1、截取错误图片信息函数

'pathway 截图所要存放的位置
Public Function QTP_Capture (pathway)
  Dim datestamp
  Dim filename
  Datestamp = Now ()
'Test_name脚本的名称
  filename = Environment ("TestName")&"_"&datestamp&".jpg"
'文件命名不可包含字符 ：
  filename = Replace (filename,":","")
  filename = pathway + "\" + ""&filename
  Desktop.CaptureBitmap filename
End Function

 2、图片处理函数

　2.1图片中添加文字

'Filename:图片文件名字
'Strng:在图片中所要添加的文字
Function JPG_TypeString (filename, strng)
Set Jpeg=CreateObject("Persits.Jpeg")
Jpeg.Open filename
'字体的颜色、字体、是否加粗
Jpeg.Canvas.Font.Color=vbblack
Jpeg.Canvas.Font.Family="楷体_GB2312"
Jpeg.Canvas.Font.Bold=True
'在图片的(100, Jpeg.OriginalHeight/2)的坐标位置添加文字strng
Jpeg.Canvas.print 100, Jpeg.OriginalHeight/2, strng
Jpeg.Save filename
Jpeg.Close
Set Jpeg=nothing
End Function

 　2.2在图片中画椭圆

'filename 图片的路径
'leftlen、toplen 左边的x , y
'rightlen、buttonlen 右边的x , y
Function JPG_DrawEllipse (filename, leftlen, toplen, rightlen, buttonlen)
        Set Jpeg=CreateObject ("Persits.Jpeg")
        Jpeg.Open filename
        Jpeg.Canvas.Pen.Color=vbred
      Jpeg.Canvas.Pen.Width=2
      Jpeg.Canvas.Brush.Solid=False
'画椭圆
      Jpeg.Canvas.Ellipseleftlen,toplen,rightlen,buttonlen
      Jpeg.Save filename
      Jpeg.Close
      Set Jpeg=nothing
End Function

 

　2.3在图片需要标示的地方画椭圆，然后画直线，注明信息

    

Function JPG_DrawEllipseAndString(filename,strng,leftlen,toplen,rightlen,buttonlen)
      Set Jpeg=CreateObject("Persits.Jpeg")
      Jpeg.Open filename
        Jpeg.Canvas.Pen.Color=vbblack
        Jpeg.Canvas.Pen.Width=2
'是否加粗
        Jpeg.Canvas.Brush.Solid=False
'画椭圆
        Jpeg.Canvas.Ellipse leftlen,toplen,rightlen,buttonlen         If  leftlen>Jpeg.OriginalWidth/2Then
        tmpleft=leftlen
        tmtop=toplen+(buttonlen-toplen)/2
           If leftlen >100  Then
                    tmpright=leftlen-100
              Else
               tmpright=leftlen/2
           End If
           If toplen+(buttonlen-toplen)/2>100 Then
              tmpbuttom=toplen+(buttonlen-toplen)/2-100
           Else
                  tmpbuttom=toplen+(buttonlen-toplen)/2-100
      End If
      Else
       tmpleft=rightlen
       tmptop=toplen+(buttonlen-toplen)/2
       If rightlen+100+Len(strng)*2>Jpeg.OriginalWidth Then
         tmpright=Jpeg.OriginalWidth-Len(strng)*2
       Else
       tmpright=rightlen+100
       End If
       If toplen+(buttonlen-toplen)/2+100>Jpeg.OriginalHeight Then
           tmpbuttom=Jpeg.OriginalHeight+100
         Else
         tmpbuttom=toplen+(buttonlen-toplen)/2+100
         End If
       End If
 
     Jpeg.Canvas.Line tmpleft,tmptop,tmpright,tmpbuttom
     Jpeg.Canvas.Font.Family="楷体_GB2312"
    Jpeg.Canvas.Font.Bold=True
    Jpeg.Canvas.Font.Color=vbblack
 
    lenght=0
    lens=0
    startLen=1
    strLen1=CInt(Jpeg.Canvas.GetTextExtent("b"))
 
    strLen=CInt(Jpeg.Canvas.GetTextExtent(strng))
 
    JSize=Jpeg.Canvas.Font.Size
    If tmpright+strLen>Jpeg.OriginalWidth Then
      Do
          startLen=startLen+lenght
        tmpbuttom=tmpbuttom+lens
        Jpeg.Canvas.Print tmpright,tmpbuttom,Mid(strng,startLen,CInt((Jpeg.OriginalWidth-tmpright)/strLen1)-2)
        lens=JSize
        lenght=CInt((Jpeg.OriginalWidth-tmpright)/strLen1)-2
        Loop Until startLen>=Len(strng)
        Else
        Jpeg.Canvas.Print tmpright,tmpbuttom,strng
       
    End If
          Jpeg.Save filename
        Gl_ErrBitmapName=filename
        Jpeg.Close
       Set Jpeg=Nothing
       End Function

 3、发送邮件函数

Public Function SendByOutLook(emailAddress,subject,body)
Function
'You_Account：你的邮件账号
'You_Password:你的邮件密码
'Send_Email:  接受邮件的账号
'Send_Topic:  邮件主题
'Send_Body:   邮件内容
'Send_Attachment:邮件附件
Send_mail(You_Account,You_Password,Send_Email,Send_Topic,Send_Body,Send_Attachment)
'帐号和服务器分离
You_ID=Split(You_Account, "@", -1, vbTextCompare)
'这个是必须要的，不过可以放心的事，不会通过微软发送邮件
MS_Space = "http://schemas.microsoft.com/cdo/configuration/"
Set Email = CreateObject("CDO.Message")
Email.From = You_Account
'接收邮件的账号
Email.To = Send_Email
'邮件主题
Email.Subject = Send_Topic
'邮件内容
Email.Textbody = Send_Body
'邮件附件
If Send_Attachment <> "" Then
Email.AddAttachment Send_Attachment
End If
With Email.Configuration.Fields
'发信端口
.Item (MS_Space&"sendusing") = 2
'SMTP服务器地址
.Item(MS_Space&"smtpserver") = "smtp."&You_ID(1)
'SMTP服务器端口
.Item(MS_Space&"smtpserverport") = 25
'cdobasec
.Item(MS_Space&"smtpauthenticate") = 1
'你的邮件账号
.Item(MS_Space&"sendusername") = You_ID(0)
'你的邮件密码
.Item(MS_Space&"sendpassword") = You_Password
.Update
End With
'发送邮件
Email.Send
Set Email=Nothing
Send_Mail=True
'如果没有任何错误信息，则表示发送成功,否则发送失败
If Err Then
Err.Clear
Send_Mail=False
End If
End Function