QTP中：使用VBS调用Excel截图功能

因为需要将测试截图存储于Execl中，但是网上找到的代码都是只能截一张图的，如果截多张会导致所有图都在第一排。而QTP自带的那个截图软件事实上只能得到一张图片，还得自己想办法将图导入到Excel。

搜寻几个小时无果之后，决定自己写一个，虽然有些麻烦，总算是搞出来了。下列代码给用得到的朋友做个参考：

注意：因为用到了capturebitmap这个方法，还有获得一些参数，此段代码只可以在QTP中使用。

''''''''''''''Capture Screenshot'''''''''
Dim oExcel,ExcelBook
Dim IntCaptureCount,LngTotalRowinExcel,j
Dim strScreenshotName,strTestDir,strPicPath
Dim intSaveScreenInLine,i
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

strScreenshotName=Environment("TestName")
strTestDir=Environment("TestDir")
strScreenshotName=strScreenshotName&"_ScreenShot.xls"

IntCaptureCount=1
intSaveScreenInLine=1

Public Function CaptureScreen()

Set objYuanZiFan=Browser("YuanZiFan.com") ''此处填写需要截图的对象名
LngTotalRowinExcel=IntCaptureCount*46
objYuanZiFan.CaptureBitmap '截图操作

strTestDir&"Screen"&IntCaptureCount&".PNG",True  ' 将截图存储于当前目录
strPicPath=strTestDir&"Screen"&IntCaptureCount&".PNG"    '

If IntCaptureCount=1 Then
Set oExcel = CreateObject("Excel.Application")
oExcel.Visible=True
Set ExcelBook=oExcel.Workbooks.Add
End If

For j=LngTotalRowinExcel to LngTotalRowinExcel step 46
oExcel.ActiveSheet.Range("A"&j).select
i=j-45
With     oExcel.ActiveSheet.Pictures.Insert(strPicPath)
'                    .ShapeRange.LockAspectRatio=msoFalse
'                .Placement=xlMoveAndSize
.ShapeRange.Left=oExcel.ActiveSheet.Range("A"&i).Left
.ShapeRange.Top=oExcel.ActiveSheet.Range("A"&(i+1)).top
.ShapeRange.Height=oExcel.ActiveSheet.Range("A"&i&":A"&(i+43)).height
.ShapeRange.Width=oExcel.ActiveSheet.Range("A"&i&":P"&i).width
End With
Next
intSaveScreenInLine=IntCaptureCount*46
IntCaptureCount=IntCaptureCount+1

'ExcelBook.SaveAs strTestDir & strScreenshotName & strScreenshotName

End Function