VBS脚本-收集来的

'获取当前时间
Public Function Get_Time()
 Dim currentTime
 currentTime = Time
 Get_Time = currentTime
End Function

'随机函数生成
'输入值：生成值范围 i～j
'返回值：随机数
Public Function Get_RandNum(fromNum,toNum)
 If (fromNum<0) Or (toNum<0) Then
  MsgBox "只接受大于零的输入"
 ElseIf fromNum>toNum then
  MsgBox "起始值必须小于结束值"
 Else
  Dim RunTime
  Randomize  
  RunTime = Int((10 * Rnd) + 1)
  Dim MyValue,i
  For i = 1 To RunTime
   Randomize 
   MyValue = Int(((toNum - fromNum + 1) * Rnd) + (fromNum))
  Next
    Get_randNum=MyValue
   End If
End Function

'值交换函数
Public Sub swap(byref a,byref b)
 Dim c
 c = a
 a = b
 b = c
End Sub

'是否是质数函数
'是质数返回true，否则返回false
Function IsPrimeNumber(num)
 Dim i,flag
 flag = true
 If num = 1 Then
  flag = False
 ElseIf num < 1 Then
  MsgBox "只能接受大于0的数"
  flag = False
 Else
  For i = 2 To (num - 1)
   If ((num Mod i) = 0) Then
    flag = False
    Exit For
   End If
  Next
 End If 
 IsPrimeNumber = flag
End Function

'读指定文本文件指定行内容
Function ReadLine(pathway, rowcount)
 Dim fso,myfile,i,flag
 flag = 1
 Set fso=CreateObject("scrīpting.FileSystemObject")
 If fso.FileExists(pathway) then
  Set myfile = fso.openTextFile(pathway,1,false)
 Else
  flag = 0
 End If
 
 For i=1 to rowcount-1
  If Not myfile.AtEndOfLine Then
   myfile.SkipLine
  End If
 Next
 
 If flag = 1 then
  If Not myfile.AtEndOfLine Then
   ReadLine = myfile.ReadLine
  Else
   ReadLine = "文本越界"
  End If
  myfile.close
 Else
  ReadLine = "文件不存在"
 End If
End Function

'随机生成字符串
Function MakeString(inputlength)
 Dim I,x,B,A
 If IsNumeric(inputlength) Then
 For I = 1 To inputlength
  A = Array("0","1","2","3","4","5","6","7","8","9","a","b","c","d","e","f","g","h","i","j","k","l","m","n","o","p","q","r","s","t","u","v","w","x","y","z")
  Randomize
  x=Get_RandNum(0,35)
  B = A(x)
  makestring =makestring +B
 Next
  MakeString = makestring
 else
  msgbox ("只接受数字输入")
 End If
End Function

'启动资源管理器
Sub ZYGLQ()
 Dim WshShell
 set WshShell = CreateObject("Wscrīpt.Shell")
 WshShell.SendKeys "^+{ESC}"
 Set WshShell = nothing
End Sub

'启动运行
Sub Run()
 Dim WshShell
 set WshShell = CreateObject("Wscrīpt.Shell")
 WshShell.SendKeys "^{ESC}R"
 Set WshShell = nothing
End Sub

'发送电子邮件
Function SendMail(SendTo, Subject, Body, Attachment)
 Dim ol,mail
    Set ōl=CreateObject("Outlook.Application")
    Set Mail=ol.CreateItem(0)
    Mail.to=SendTo
    Mail.Subject=Subject
    Mail.Body=Body
    If (Attachment <> "") Then
        Mail.Attachments.Add(Attachment)
    End If
    Mail.Send
    ol.Quit
    Set Mail = Nothing
    Set ōl = Nothing
End Function

'去掉字符串中的重复项
Function NoRepeat(Inp,Sp)
Dim aa,flag,words,length,i,j,k,sp1,sp2,cc
 aa = Inp
 Do
  flag = False
  words = Split(aa,Sp)
  length = UBound(words)
  For i = 0 To (length -1)
   sp1 = words(i)
   For j = (i+1) To length
    sp2 = words(j)
    If sp1 = sp2 Then
     flag = True
     aa = ""
     For k = 0 To (j-1)
      aa = aa & words(k) & sp
     Next
     For k = (j + 1) To length
      aa = aa & words(k) & sp
     Next
     
     cc = Len(aa)
     aa = Left(aa,(cc - 1))
    End If
   Next
   If flag = True Then
    Exit For
   End if
  Next
 Loop Until flag = false
 NoRepeat = aa
End Function

'求字符串长度（中文算2个西文字符）
Function GetLen(Str)
        Dim singleStr, i, iCount
        iCount = 0
        For i = 1 to len(Str)
                singleStr = mid(Str,i,1)
                If asc(singleStr) < 0 Then
                        iCount = iCount + 2
                Else
                        iCount = iCount + 1
                End If  
        Next
        GetLen = iCount
End Function

'运行指定程序
Sub RunApp(command)
 Dim WshShell
 set WshShell = CreateObject("Wscrīpt.Shell")
 WshShell.Exec command
End Sub

'求下一天是几号的函数
Function Nextday(ByVal inputday)
    Dim temp, num, OPYear, OPMonth, OPDay, ret, flag
    temp = Split(CStr(inputday), "-")
    num = UBound(temp) + 1
    ōPYear = temp(0)
    ōPMonth = temp(1)
    ōPDay = temp(2)
    flag = 0

    If ōPMonth = 1 Or ōPMonth = 3 Or ōPMonth = 5 Or ōPMonth = 7 Or ōPMonth = 8 Or ōPMonth = 10 Or ōPMonth = 12 Then
        If OPDay > 31 Or OPDay < 1 Then
            flag = 1
        End If
    ElseIf ōPMonth = 4 Or ōPMonth = 6 Or ōPMonth = 9 Or ōPMonth = 11 Then
        If OPDay > 30 Or OPDay < 1 Then
            flag = 1
        End If
    Else
        If ISLeapYear(OPYear) Then
            If OPDay > 29 Or OPDay < 1 Then
                flag = 1
            End If
        Else
            If OPDay > 28 Or OPDay < 1 Then
                flag = 1
            End If
        End If
    End If

    If flag = 1 Or num <> 3 Then
        MsgBox "输入参数不对劲", , "Nextday函数提示"
    Else
        If ōPMonth = 1 Or ōPMonth = 3 Or ōPMonth = 5 Or ōPMonth = 7 Or ōPMonth = 8 Or ōPMonth = 10 Or ōPMonth = 12 Then 'big month
            If ōPDay = 31 Then
                ōPDay = 1
                If ōPMonth = 12 Then
                    ōPMonth = 1
                    ōPYear = OPYear + 1
                Else
                    ōPMonth = OPMonth + 1
                    ōPYear = OPYear
                End If
            Else
                ōPDay = OPDay + 1
            End If
        ElseIf ōPMonth = 4 Or ōPMonth = 6 Or ōPMonth = 9 Or ōPMonth = 11 Then                                          'small month
            If ōPDay = 30 Then
                ōPDay = 1
                If ōPMonth = 12 Then
                    ōPMonth = 1
                    ōPYear = OPYear + 1
                Else
                    ōPMonth = OPMonth + 1
                    ōPYear = OPYear
                End If
            Else
                ōPDay = OPDay + 1
            End If
        Else                                                                                                           'February
            If ISLeapYear(OPYear) Then
                If ōPDay = 29 Then
                    ōPDay = 1
                    If ōPMonth = 12 Then
                        ōPMonth = 1
                        ōPYear = OPYear + 1
                    Else
                        ōPMonth = OPMonth + 1
                        ōPYear = OPYear
                    End If
                Else
                    ōPDay = OPDay + 1
                End If
            Else
                If ōPDay = 28 Then
                    ōPDay = 1
                    If ōPMonth = 12 Then
                        ōPMonth = 1
                        ōPYear = OPYear + 1
                    Else
                        ōPMonth = OPMonth + 1
                        ōPYear = OPYear
                    End If
                Else
                    ōPDay = OPDay + 1
                End If
            End If
        End If
        ret = OPYear & "-" & OPMonth & "-" & OPDay
        Nextday = ret
    End If
End Function

'是否闰年
Function ISLeapYear(ByVal inYear)
    If ((inYear Mod 4 = 0 And inYear Mod 100 <> 0) Or inYear Mod 400 = 0) Then
        ISLeapYear = True
    Else
        ISLeapYear = False
    End If
End Function

'计算两个日期之间相隔几天
Function Days(ByVal SourceData, ByVal DesData)
    Dim flag, temp1, temp2, OPYear1, OPYear2, OPMonth1, OPMonth2, OPDay1, OPDay2, i, tempDay
    temp1 = Split(SourceData, "-")
    temp2 = Split(DesData, "-")
    If ((UBound(temp1) + 1) <> 3) Or ((UBound(temp2) + 1) <> 3) Then
        MsgBox "输入参数不对劲", , "Days函数提示"
    End If
    OPYear1 = temp1(0)
    OPMonth1 = temp1(1)
    OPDay1 = temp1(2)
    OPYear2 = temp2(0)
    OPMonth2 = temp2(1)
    OPDay2 = temp2(2)
    If CInt(OPYear1) <> CInt(OPYear2) Then
        If CInt(OPYear1) > CInt(OPYear2) Then
            flag = "big"
        ElseIf CInt(OPYear1) < CInt(OPYear2) Then
            flag = "small"
        End If
    Else
        If CInt(OPMonth1) <> CInt(OPMonth2) Then
            If CInt(OPMonth1) > CInt(OPMonth2) Then
                flag = "big"
            ElseIf CInt(OPMonth1) < CInt(OPMonth2) Then
                flag = "small"
            End If
        Else
            If CInt(OPDay1) <> CInt(OPDay2) Then
                If CInt(OPDay1) > CInt(OPDay2) Then
                    flag = "big"
                ElseIf CInt(OPDay1) < CInt(OPDay2) Then
                    flag = "small"
                End If
            Else
                flag = "="
            End If
        End If
    End If

    If (flag = "big") Then
        i = 1
        tempDay = DesData
        Do
            tempDay = Nextday(tempDay)
            i = i + 1
        Loop Until tempDay = SourceData
        i = i - 1
    ElseIf (flag = "small") Then
        i = 1
        tempDay = SourceData
        Do
            tempDay = Nextday(tempDay)
            i = i + 1
        Loop Until tempDay = DesData
        i = i - 1
    Else
        i = 0
    End If

    Days = i
End Function

'检查身份证号是否正确
Function Identification(Text1)
xian = Text1
If (Not IsNumeric(Left(Text1, 15)) And Not IsNumeric(Left(Text1, 18))) Or Text1 = "" Then
  Identification = False
  Exit Function
End If
lenx = Len(Trim(Text1))
If lenx = 15 Or lenx = 18 Then
    If lenx = 15 Then
        yy = "19" & Mid(xian, 7, 2)
        mm = Mid(xian, 9, 2)
        dd = Mid(xian, 11, 2)
        aa = Right(xian, 1)
    End If
    If lenx = 18 Then
        yy = Mid(xian, 7, 4)
        mm = Mid(xian, 11, 2)
        dd = Mid(xian, 13, 2)
        aa = Right(xian, 1)
    End If
    If CInt(mm) > 12 Or CInt(dd) > 31 Then
       Identification = False
       Exit Function
    Else
     Identification = True
     Exit Function
    End If
Else
  Identification = False
  Exit Function
End If
End Function

'检查是否存在数字
Function checkString (myString)
 checkString = False
 Dim myChr
 For myChr = 48 to 57
  If InStr(myString,Chr(myChr)) > 0 Then
   checkString = True
   Exit Function
  End If
 Next
End Function

'查询Access数据库字符出现次数
Function Access_GetCount(DBlocation,TableName,Value)
 set con=createobject("adodb.connection")
 con.open "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=" & DBlocation
 set record = createobject("adodb.recordset")
 sql="select * from " & TableName
 
 record.open sql,con
 DO
  if(record("name")=Value)then
   num=num+1
  end If
  record.MoveNext
 loop until record.eof=True
 
 record.close
 set record=Nothing
 con.close
 set con=Nothing
 
 If num = 0 Then
  Access_GetCount = 0
 Else
  Access_GetCount = num
 End If
End Function

'按ASCII码值冒泡排序
Function BubbleSort(VString,Spl,Func)
 Dim Str,StrLength,i,j
 Str = Split(VString,Spl)
 StrLength = UBound(Str) + 1
 For i = 1 To (StrLength-1)
  For j = (i+1) To StrLength
   If Func = 1 then
    If Asc(Str(i-1)) < Asc(Str(j-1)) Then
     Call Swap(Str(i-1),Str(j-1))
    End If
   Else
    If Asc(Str(i-1)) > Asc(Str(j-1)) Then
     Call Swap(Str(i-1),Str(j-1))
    End If
   End If
  Next
 Next
 j = ""
 For i = 1 To StrLength
  j = j & Str(i-1) & Spl
 Next
 j = Left(j,(StrLength * 2 -1))
 BubbleSort = j
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''以下为仅QuickTest适用函数'''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'让QTP运行时保持最小化
Public Sub QTP_Small()
 Dim objQTPWin
 Set ōbjQTPWin = GetObject("" , "QuickTest.Application")
 objQTPWin.WindowState = "Minimized"
 Set ōbjQTPWin = Nothing
End Sub

'恢复QTP窗口
Public Sub QTP_Big()
 Dim objQTPWin
 Set ōbjQTPWin = GetObject("" , "QuickTest.Application")
 objQTPWin.WindowState = "Restored"
 Set ōbjQTPWin = Nothing
End Sub

'写文件函数(追加)
'输入值：写入内容
Public Function QTP_WriteFile(pathway,words) 
    Dim fileSystemObj,fileSpec,logFile,way
    Set fileSystemObj = CreateObject("scrīpting.FileSystemObject")
    fileSpec = pathway
    Set logFile = fileSystemObj.OpenTextFile(fileSpec, 8, true)
    logFile.WriteLine (CStr(words))
    logFile.Close
    Set logFile = Nothing
End Function

'写文件函数(改写)
'输入值：写入内容
Public Function QTP_WriteFile_Change(pathway,words) 
    Dim fileSystemObj,fileSpec,logFile,way
    Set fileSystemObj = CreateObject("scrīpting.FileSystemObject")
    fileSpec = pathway
    Set logFile = fileSystemObj.OpenTextFile(fileSpec, 2, true)
    logFile.WriteLine (CStr(words))
    logFile.Close
    Set logFile = Nothing
End Function

'读Excel文件元素
Public Function QTP_Read_Excel(pathway,sheetname,x,y)
 Dim srcData,srcDoc,ret
 set srcData = CreateObject("Excel.Application")
 srcData.Visible = True
 set srcDoc = srcData.Workbooks.Open(pathway)
 srcDoc.Worksheets(sheetname).Activate
 ret = srcDoc.Worksheets(sheetname).Cells(x,y).value
 srcData.Workbooks.Close
 Window("text:=Microsoft Excel").Close
 QTP_Read_Excel = ret
End Function

'写Excel文件元素并保存退出
Public Function QTP_Write_Excel(pathway,sheetname,x,y,content)
 Dim srcData,srcDoc,sp1,sp2,num,use,a1,a2,a3
 set srcData = CreateObject("Excel.Application")
 srcData.Visible = True
 set srcDoc = srcData.Workbooks.Open(pathway)
 srcDoc.Worksheets(sheetname).Activate
 srcDoc.Worksheets(sheetname).Cells(x,y).value = content
 
' sp1 = Split(pathway,".")
' sp2 = Split(sp1(0),"\")
' num = UBound(sp2)
' use = sp2(num)

' Set a1 = Descrīption.Create()
' a1("text").value="Microsoft Excel - " + use + ".xls"
' a1("window id").value="0"

' Set a3 = Descrīption.Create()
' a3("Class Name").value="WinObject"
' a3("text").value= use + ".xls"

' Window(a1).WinObject(a3).Type micCtrlDwn + "s" + micCtrlUp

 Dim WshShell
 Set WshShell=CreateObject("Wscrīpt.Shell")
 WshShell.SendKeys "^s"
 wait(1)
 
 srcData.Workbooks.Close
 Set srcDoc = nothing
 
 Window("text:=Microsoft Excel").Close
End Function

'定时停留弹出框函数
Sub QTP_Msgbox(Value,waitTime,Title)
 Dim WshShell
    Set WshShell = CreateObject("Wscrīpt.Shell")
    WshShell.Popup Value, waitTime, Title
    Set WshShell = nothing
End Sub

'改变Excel的单元格颜色
Public Function QTP_Change_Color(pathway,sheetname,x,y,color)
 Dim srcData,srcDoc,sp1,sp2,num,use,a1,a2,a3
 set srcData = CreateObject("Excel.Application")
 srcData.Visible = True
 set srcDoc = srcData.Workbooks.Open(pathway)
 srcDoc.Worksheets(sheetname).Activate
 If color = "red" Then
  srcDoc.Worksheets(sheetname).Cells(x,y).Interior.color=vbred
 ElseIf color = "green" Then
  srcDoc.Worksheets(sheetname).Cells(x,y).Interior.color=vbgreen
 Else
  MsgBox "输入的颜色参数不正确，只接收""red""和""green"""
 End If

 Dim WshShell
 Set WshShell=CreateObject("Wscrīpt.Shell")
 WshShell.SendKeys "^s"
 wait(1)
 
 srcData.Workbooks.Close
 Set srcDoc = nothing
 Window("text:=Microsoft Excel").Close
End Function

'捕获当前屏幕（截图）
Public Function QTP_Capture(pathway)
  Dim datestamp
  Dim filename
  datestamp = Now()
  filename = Environment("TestName")&"_"&datestamp&".png"
  filename = Replace(filename,"/","")
  filename = Replace(filename,":","")
  filename = pathway + "\" + ""&filename
  Desktop.CaptureBitmap filename
  'Reporter.ReportEvent micFail,"image","<img src='" & filename & "'>"
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''QuickTestPlus 帮助文件对于Excel库函数  仅QTP适用''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim ExcelApp 'As Excel.Application
Dim excelSheet 'As Excel.worksheet
Dim excelBook 'As Excel.workbook
Dim fso 'As scrīpting.FileSystemObject

Function CreateExcel() 'As Excel.Application
    Dim excelSheet 'As Excel.worksheet
    Set ExcelApp = CreateObject("Excel.Application") 'Create a new excel Object
    ExcelApp.Workbooks.Add
    ExcelApp.Visible = True
    Set CreateExcel = ExcelApp
End Function

Sub CloseExcel(ExcelApp)
    Set excelSheet = ExcelApp.ActiveSheet
    Set excelBook = ExcelApp.ActiveWorkbook
    Set fso = CreateObject("scrīpting.FileSystemObject")
    On Error Resume Next
    fso.CreateFolder "C:\Temp"
    fso.DeleteFile "C:\Temp\ExcelExamples.xls"
    excelBook.SaveAs "C:\Temp\ExcelExamples.xls"
    ExcelApp.Quit
    Set ExcelApp = Nothing
    Set fso = Nothing
    Err = 0
    On Error GoTo 0
End Sub

Function SaveWorkbook(ExcelApp, workbookIdentifier, path) 'As String
    Dim workbook 'As Excel.workbook
    On Error Resume Next
    Set workbook = ExcelApp.Workbooks(workbookIdentifier)
    On Error GoTo 0
    If Not workbook Is Nothing Then
        If path = "" Or path = workbook.FullName Or path = workbook.Name Then
            workbook.Save
        Else
            Set fso = CreateObject("scrīpting.FileSystemObject")
            If InStr(path, ".") = 0 Then
                path = path & ".xls"
            End If
            On Error Resume Next
            fso.DeleteFile path
            Set fso = Nothing
            Err = 0
            On Error GoTo 0
            workbook.SaveAs path
        End If
        SaveWorkbook = 1
    Else
        SaveWorkbook = 0
    End If
End Function

Sub SetCellValue(excelSheet, row, column, value)
    On Error Resume Next
    excelSheet.Cells(row, column) = value
    On Error GoTo 0
End Sub

Function GetCellValue(excelSheet, row, column)
    value = 0
    Err = 0
    On Error Resume Next
    tempValue = excelSheet.Cells(row, column)
    If Err = 0 Then
        value = tempValue
        Err = 0
    End If
    On Error GoTo 0
    GetCellValue = value
End Function

Function GetSheet(ExcelApp, sheetIdentifier) 'As Excel.worksheet
    On Error Resume Next
    Set GetSheet = ExcelApp.Worksheets.Item(sheetIdentifier)
    On Error GoTo 0
End Function

Function InsertNewWorksheet(ExcelApp, workbookIdentifier, sheetName) 'As Excel.worksheet
    Dim workbook 'As Excel.workbook
    Dim worksheet 'As Excel.worksheet
    'In case that the workbookIdentifier is empty we will work on the active workbook
    If workbookIdentifier = "" Then
        Set workbook = ExcelApp.ActiveWorkbook
    Else
        On Error Resume Next
        Err = 0
        Set workbook = ExcelApp.Workbooks(workbookIdentifier)
        If Err <> 0 Then
            Set InsertNewWorksheet = Nothing
            Err = 0
            Exit Function
        End If
        On Error GoTo 0
    End If
    sheetCount = workbook.Sheets.Count
    workbook.Sheets.Add , sheetCount
    Set worksheet = workbook.Sheets(sheetCount + 1)
    If sheetName <> "" Then
        worksheet.Name = sheetName
    End If
    Set InsertNewWorksheet = worksheet
End Function

Function CreateNewWorkbook(ExcelApp)
    Set NewWorkbook = ExcelApp.Workbooks.Add()
    Set CreateNewWorkbook = NewWorkbook
End Function

Function OpenWorkbook(ExcelApp, path)
    On Error Resume Next
    Set NewWorkbook = ExcelApp.Workbooks.Open(path)
    Set ōpenWorkbook = NewWorkbook
    On Error GoTo 0
End Function

Sub ActivateWorkbook(ExcelApp, workbookIdentifier)
    On Error Resume Next
    ExcelApp.Workbooks(workbookIdentifier).Activate
    On Error GoTo 0
End Sub

Sub CloseWorkbook(ExcelApp, workbookIdentifier)
    On Error Resume Next
    ExcelApp.Workbooks(workbookIdentifier).Close
    On Error GoTo 0
End Sub

Function CompareSheets(sheet1, sheet2, startColumn, numberOfColumns, startRow, numberOfRows, trimed) 'As Boolean
    Dim returnVal 'As Boolean
    returnVal = True
    If sheet1 Is Nothing Or sheet2 Is Nothing Then
        CompareSheets = False
        Exit Function
    End If
    For r = startRow to (startRow + (numberOfRows - 1))
        For c = startColumn to (startColumn + (numberOfColumns - 1))
            Value1 = sheet1.Cells(r, c)
            Value2 = sheet2.Cells(r, c)
            If trimed Then
                Value1 = Trim(Value1)
                Value2 = Trim(Value2)
            End If
            If Value1 <> Value2 Then
                Dim cell 'As Excel.Range
                sheet2.Cells(r, c) = "Compare conflict - Value was '" & Value2 & "', Expected value is '" & Value1 & "'."
                Set cell = sheet2.Cells(r, c)
                cell.Font.Color = vbRed
                returnVal = False
            End If
        Next
    Next
    CompareSheets = returnVal
End Function

'写入word文件
Sub QTP_WriteWord(pathway,content)
 Dim oWord,oRange,oDoc
 Set ōWord = CreateObject("Word.Application")
 oWord.documents.open pathway,forwriting, True
 Set ōDoc = oWord.ActiveDocument
 Set ōRange = oDoc.content
 oRange.insertafter content
 oWord.ActiveDocument.Save
' Dim WshShell
' Set WshShell=CreateObject("Wscrīpt.Shell")
' WshShell.SendKeys "^s"
' wait(1)
    oWord.Application.Quit True
 Set ōRange = Nothing
 Set ōDoc = Nothing
 Set ōWord = Nothing
End Sub