Wincc导出报警到EXCEL

2021年7月5日下午3:57 • SIMATIC WinCC

案例是在工业支持中心下的修改过查询语句原先：sSql = "ALARMVIEWEx:Select * FROM AlgViewExCHT "&MySqlStr.Value 点击导出Excel提示“没数据” 后来：改为sSql = "ALARMVIEWEx:Select * FROM AlgViewExENU "&MySqlStr.Value可以导出，但是消息文本没有，请教各位谢谢
完整代码：Sub OnClick(Byval Item)
'变量定义和初始化
Dim sPro,sDsn,sSer,sCon,conn,sSql,oRs,oCom
Dim tagDSNName
Dim m,i
Dim objExcelApp,objExcelBook,objExcelSheet,sheetname
Dim MySqlStr
Set MySqlStr = HMIRuntime.Tags("MySqlStr")
item.Enabled = False
'On Error Resume Next
sheetname="Sheet1"
'打开Excel模板
Set objExcelApp = CreateObject("Excel.Application")
  objExcelApp.Visible = False
  objExcelApp.Workbooks.Open "D:\WinCCWriteExcel\abcd.xlsx"
  objExcelApp.Worksheets(sheetname).Activate
  '准备查询条件 Catalog
Set tagDSNName = HMIRuntime.Tags("@DatasourceNameRT")
  tagDSNName.Read
'创建数据库联接
sPro = "Provider=WinCCOLEDBProvider.1;"
sDsn = "Catalog=" &tagDSNName.Value& ";"
sSer = "Data Source=.\WinCC"
sCon = sPro + sDsn + sSer
Set conn = CreateObject("ADODB.Connection")
  conn.ConnectionString = sCon
  conn.CursorLocation = 3
  conn.Open
'定义查询的命令文本 SQL
MySqlStr.Read

sSql = "ALARMVIEWEx:Select * FROM AlgViewExENU "&MySqlStr.Value

  MsgBox sSql
HMIRuntime.Trace "Sql is: " & sSql & vbCrLf
Set oRs = CreateObject("ADODB.Recordset")
Set oCom = CreateObject("ADODB.Command")
  oCom.CommandType = 1
Set oCom.ActiveConnection = conn
  oCom.CommandText = sSql
'填充数据到Excel中
Set oRs = oCom.Execute
  m = oRs.RecordCount
If (m > 0) Then
     oRs.MoveFirst
     i=3
     Do While Not oRs.EOF                           '是否到记录末尾，循环填写表格
         objExcelApp.Worksheets(sheetname).cells(i,1).value= CStr(oRs.Fields(0).Value)
          objExcelApp.Worksheets(sheetname).cells(i,2).value= CStr(oRs.Fields(1).Value)
         objExcelApp.Worksheets(sheetname).cells(i,3).value= CStr(oRs.Fields(2).Value)
         objExcelApp.Worksheets(sheetname).cells(i,4).value= CStr(oRs.Fields(37).Value)

         oRs.MoveNext
         i=i+1
     Loop
     oRs.Close
Else
     MsgBox "没有所需数据……"
     item.Enabled = True
     Set oRs = Nothing
  conn.Close
     Set conn = Nothing
     objExcelApp.Workbooks.Close
     objExcelApp.Quit
     Set objExcelApp= Nothing
     Exit Sub
End If
'释放资源
Set oRs = Nothing
  conn.Close
Set conn = Nothing
'生成新的文件,关闭Excel
Dim patch,filename
filename=CStr(Year(Now))&CStr(Month(Now))&CStr(Day(Now))&CStr(Hour(Now))+CStr(Minute(Now))&CStr(Second(Now))
patch= "D:\"&filename&"demo.xlsx"
objExcelApp.ActiveWorkbook.SaveAs patch
objExcelApp.Workbooks.Close
objExcelApp.Quit
Set objExcelApp= Nothing
MsgBox "成功生成数据文件!"
item.Enabled = True
End Sub