WINCC+用户归档+VBS+EXCEL实时报表

Sub OnClick(Byval Item)

Dim fso,folder
Dim type1
Dim patch,filename
Dim testposition,testnumber,startdate,printdate,brand,tyremodel,rim,tread,condition,load,speed,pressure,status
Set testposition=HMIRuntime.tags("TestPosition_2")
Set testnumber=HMIRuntime.tags("TestNumber_2")
Set startdate=HMIRuntime.tags("StartDate_2")
Set printdate=HMIRuntime.tags("PrintDate_2")
Set brand=HMIRuntime.tags("TypeBrand_2")
Set tyremodel=HMIRuntime.tags("TyreType_2")
Set rim=HMIRuntime.tags("RimStandard_2")
Set tread=HMIRuntime.tags("TyreTread_2")
Set condition=HMIRuntime.tags("TestConditionFile_2")
Set load=HMIRuntime.tags("StandardLoad_2")
Set speed=HMIRuntime.tags("SpeedSymbol_2")
Set pressure=HMIRuntime.tags("StandardPressure_2")
Set status=HMIRuntime.tags("FinalStatus_2")
'***********************check tyre type*******************
tyremodel.Read
type1=tyremodel.Value
If type1="" Then
MsgBox "Please check tire type" , ,"Info"
Exit Sub
Else
End If
'***********************check Report folder****************
Set fso=CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists("E:\Report")) Then
Else
Set folder=fso.CreateFolder("E:\Report")
End If
'***********************close report*************************
Dim objExcelApp,objExcelBook,objExcelSheet
On Error Resume Next
Dim ExcelApp,ExcelBook
Set ExcelApp = GetObject(,"Excel.Application")
If TypeName(ExcleApp) = "Application" Then
For Each ExcelBook In ExcelApp.WorkBooks
If ExcelBook.FullName = "D:\TTM-Monitor 2STA. ver.1.2\TTM-Monitor\Report\Report.xls" Then
ExcelApp.ActiveWorkbook.Save
ExcelApp.Workbooks.Close
ExcelApp.Quit
Set ExcelApp= Nothing
Exit For
End If
Next
End If
'************************Report waiting massgae***************************
Dim waittingbit
Set waittingbit = HMIRuntime.Tags("waittingbit")
waittingbit.Read
waittingbit.write 1
'************************creat connect report_2 archive********************
Dim sCon
Dim sSql
Dim conn
Dim oRs
Dim oCom
Dim m,n
Dim DSN
DSN = HMIRuntime.Tags("@DatasourceNameRT").Read
sCon="Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Data Source=.\WINCC;Initial Catalog='" & DSN & "';"
sSql = "Select * from UA#Report_2"
Set conn = CreateObject("ADODB.Connection")
conn.ConnectionString = sCon
conn.CursorLocation = 3
conn.Open
Set oRs = CreateObject("ADODB.Recordset")
Set oCom = CreateObject("https://www.360docs.net/doc/ad942297.html,mand")
https://www.360docs.net/doc/ad942297.html,mandType = 1
Set oCom.ActiveConnection = conn
https://www.360docs.net/doc/ad942297.html,mandText = sSql
Set oRs = oCom.Execute
m = oRs.Fields.Count
'************************* write datas to report.xls**********************
Set objExcelApp =CreateObject("Excel.Application")
objExcelApp.Visible=False
objExcelApp.Workbooks.Open"D:\TTM-Monitor 2STA. ver.1.2\TTM-Monitor\Report\Report.xls"
objExcelApp.Worksheets(Rep

ortDatas).Activate
'****************************report wating message***************************************************
Set waittingbit = HMIRuntime.Tags("waittingbit")
waittingbit.Read
waittingbit.write 1
'********************************************************************************
If (m > 0) Then
oRs.MoveFirst
n = 11
testposition.Read
objExcelApp.cells(5,3).value=testposition.value
testnumber.Read
objExcelApp.cells(4,3).value=testnumber.value
startdate.Read
objExcelApp.cells(6,3).value=startdate.value
printdate=Now
objExcelApp.cells(7,3).value=printdate
brand.Read
objExcelApp.cells(8,3).value=brand.value
tyremodel.Read
objExcelApp.cells(9,3).value=tyremodel.value
rim.Read
objExcelApp.cells(3,10).value=rim.value
tread.Read
objExcelApp.cells(4,10).value=tread.value
condition.Read
objExcelApp.cells(5,10).value=condition.value
load.Read
objExcelApp.cells(6,10).value=load.value
speed.read
objExcelApp.cells(7,10).value=speed.value
pressure.Read
objExcelApp.cells(8,10).value=pressure.value
status.Read
objExcelApp.cells(9,10).value=status.value

Do While Not oRs.EOF
n = n + 1
objExcelApp.Cells(n,1).Value=oRs.Fields(1).Value
objExcelApp.Cells(n,2).Value=oRs.Fields(2).Value
objExcelApp.Cells(n,3).Value=oRs.Fields(3).Value
objExcelApp.Cells(n,4).Value=oRs.Fields(4).Value
objExcelApp.Cells(n,5).Value=oRs.Fields(5).Value
objExcelApp.Cells(n,6).Value=oRs.Fields(6).Value
objExcelApp.Cells(n,7).Value=oRs.Fields(7).Value
objExcelApp.Cells(n,8).Value=oRs.Fields(8).Value
objExcelApp.Cells(n,9).Value=oRs.Fields(9).Value
objExcelApp.Cells(n,10).Value=oRs.Fields(10).Value
objExcelApp.Cells(n,11).Value=oRs.Fields(11).Value
objExcelApp.Cells(n,12).Value=oRs.Fields(12).Value
objExcelApp.Cells(n,13).Value=oRs.Fields(13).Value
objExcelApp.Cells(n,14).Value=oRs.Fields(14).Value
objExcelApp.Cells(n,15).Value=oRs.Fields(15).Value
objExcelApp.Cells(n,16).Value=oRs.Fields(16).Value
objExcelApp.Cells(n,17).Value=oRs.Fields(17).Value
oRs.MoveNext
Loop
filename=CStr(Year(Now))&"-"&CStr(Month(Now))&"-"&CStr(Day(Now))&"_"&CStr(Hour(Now))&"."&CStr(Minute(Now))&"_"&"STA2"
patch= "E:\Report\"&filename&"_"&type1&".xls"
objExcelApp.ActiveWorkbook.SaveAs patch
objExcelApp.Workbooks.Close
objExcelApp.Quit
Set objExcelApp= Nothing
End If
oRs.Close
Set oRs = Nothing
conn.Close
Set conn = Nothing
'**************************************close message*************************
MsgBox "报表保存成功，路径：E:\Report\"
Set waittingbit = HMIRuntime.Tags("waittingbit")
waittingbit.Read
waittingbit.write 0
'***************************close save as report***********************************
End Sub