搬家第14天-173.Wincc V7.3 vbs 读取多个变量归档数据到excel

前面的一篇博客记录了如何读取多个变量归档数据到mshgrid控件，根据的是西门子官网的教学。有网友询问为什么他照着官网方法就是无法导出到excel。我自己也做了一遍，没有问题。本篇主要记录导出按钮的脚本。

前面的准备工作与上一篇一致，导出按钮的vbs脚本如下：

Sub OnClick(ByVal Item)  
Dim myCatalog,myDS,PCName,cnstr,sqlstr1,sqlstr2
Dim xlapp,BTime,ETime,utcbtime,utcetime,utcbtstr,utcetstr
Dim conobj,rsobj1,comobj1
Dim rsobj2,comobj2
Dim rscount,i,curRow
Dim filename
myCatalog=HMIRuntime.Tags("@DatasourceNameRT").Read
PCName=HMIRuntime.Tags("@LocalMachineName").Read 
myDS=PCName & "\Wincc"
Set BTime=HMIRuntime.Tags("btime")
Set ETime=HMIRuntime.Tags("etime")
'北京时间时区修正
utcbtime=Dateadd("h",-8,BTime.Read) '起始时间
utcetime=Dateadd("h",-8,ETime.Read) '结束时间
'日期时间格式修正
utcbtstr = Year(utcbtime) & "-" & Month(utcbtime) & "-" & Day(utcbtime) & " " & Hour(utcbtime) & ":" & Minute(utcbtime) & ":" & Second(utcbtime)
utcetstr = Year(utcetime) & "-" & Month(utcetime) & "-" & Day(utcetime) & " " & Hour(utcetime) & ":" & Minute(utcetime) & ":" & Second(utcetime)
'连接字符串
cnstr="Provider=WinCCOLEDBProvider.1; Catalog=" & myCatalog & "; Data Source=" &  myDS
'创建连接对象
Set conobj=CreateObject("ADODB.Connection")
conobj.connectionstring=cnstr
conobj.CursorLocation = 3
conobj.Open
'查询字符串
'sqlstr = "Tag:R,('VA\flow1';'VA\flow2'),'" & utcbtstr & "','" & utcetstr & "'," & "'order by Timestamp ASC','TimeStep=1,1'"
sqlstr1 = "Tag:R,('VA\flow1'),'" & utcbtstr & "','" & utcetstr & "'," & "'order by Timestamp ASC','TimeStep=1,1'"
sqlstr2 = "Tag:R,('VA\flow2'),'" & utcbtstr & "','" & utcetstr & "'," & "'order by Timestamp ASC','TimeStep=1,1'"

'进行查询
Set rsobj1 = CreateObject("ADODB.Recordset")
Set comobj1 = CreateObject("ADODB.Command")
comobj1.CommandType = 1
Set comobj1.ActiveConnection = conobj
comobj1.CommandText = sqlstr1
Set rsobj1 = comobj1.Execute

Set rsobj2 = CreateObject("ADODB.Recordset")
Set comobj2 = CreateObject("ADODB.Command")
comobj2.CommandType = 1
Set comobj2.ActiveConnection = conobj
comobj2.CommandText = sqlstr2
Set rsobj2 = comobj2.Execute

rscount=rsobj1.recordcount
rsobj1.movefirst
rsobj2.movefirst

if rscount=0 then

   msgbox "没有记录"

   exit sub

end if

Set xlapp=CreateObject("Excel.Application")
xlapp.visible=False
xlapp.workbooks.add
'初始化excel
xlapp.worksheets(1).cells(1,1)="编号："
xlapp.worksheets(1).cells(1,2)="QB-2017.001"
xlapp.worksheets(1).range("a2:c2").mergecells=True '合并单元格
xlapp.worksheets(1).cells(2,1)="这是一个测试"
xlapp.worksheets(1).cells(2,1).HorizontalAlignment = 3 '文字居中
xlapp.worksheets(1).cells(3,1)="日期时间"
xlapp.worksheets(1).cells(3,2)="flow1"
xlapp.worksheets(1).cells(3,3)="flow2"

'导出到excel
For i=1 To rscount
 xlapp.worksheets(1).cells(3+i,1)=Dateadd("h",+8,rsobj1.fields(1).value)
 xlapp.worksheets(1).cells(3+i,2)=rsobj1.fields(2).value
 xlapp.worksheets(1).cells(3+i,3)=rsobj2.fields(2).value
 rsobj1.movenext
 rsobj2.movenext
Next
'释放资源
Set rsobj1 = Nothing
Set rsobj2 = Nothing
conobj.Close
Set conobj = Nothing

'画边框
xlapp.worksheets(1).range("a3:c" & CStr(3+rscount)).borders(1).linestyle=9
xlapp.worksheets(1).range("a3:c" & CStr(2+rscount)).borders(1).weight=2
xlapp.worksheets(1).range("a3:c" & CStr(2+rscount)).borders(2).linestyle=9
xlapp.worksheets(1).range("a3:c" & CStr(2+rscount)).borders(2).weight=2
xlapp.worksheets(1).range("a3:c" & CStr(2+rscount)).borders(3).linestyle=9
xlapp.worksheets(1).range("a3:c" & CStr(2+rscount)).borders(3).weight=2
xlapp.worksheets(1).range("a3:c" & CStr(2+rscount)).borders(4).linestyle=9
xlapp.worksheets(1).range("a3:c" & CStr(2+rscount)).borders(4).weight=2
'保存文件
filename= "c:\" & Year(Now) & "年" & Month(Now) & "月" & Day(Now) & "日-" & Hour(Now) & "点" & Minute(Now) & "分" & Second(Now) & "秒生成生产报表.xlsx"
xlapp.Activeworkbook.saveas (filename)
xlapp.workbooks.close
xlapp.quit
Msgbox "成功导出到C:\"

End Sub

无法导出数据的朋友，检查一下官网提示的那个连接包是否安装了。

标签：xlapp,Set,V7.3,rscount,cells,vbs,range,worksheets,14
来源： https://www.cnblogs.com/fishingsriver/p/14397432.html