以下程序加入中午文注释:Option Explicit
Function action
Const PC_name = "USER1" '计算机名称
Const SQL_name = "CC_wincc_re_15_01_23_16_37_05R" '数据库名称
Const single_OK = 0 '是否指定计算机和数据库
Dim sPro,sDsn,sSer,sCon,conn,sSql,oRs,oCom,tagDSNName
Dim objExcelApp,objExcelBook,objExcelSheet,sheetname
Dim m,i,itime,itag,xainshi
Dim datetime1,datetime2,UTCBeginTime, UTCEndTime
Dim startdate,startdate_value,enddate,enddate_value
Dim starthour,startminute,starthour_value,startminute_value
Dim endhour,endminute,endhour_value,endminute_value,jiange,jiange_value
Dim startyear,startmonth,startday,endyear,endmonth,endday
Dim startyear_value,startmonth_value,startday_value,endyear_value,endmonth_value,endday_value
Dim report_type,report_name,report_type_value,report_name_value
Dim tagname,tagtype,sumacc_one,sumacc_last
Dim sumdate,conmdate,sumacc
Dim patch,filename,Excel_date,patch_m
Dim mode_file_name,wincc_name,out_file_name
Dim filename_cell,tagname_cell_r,tagname_cell_c,tagtype_cell_r,tag_cell_r
Dim Excel_date_cell,out_path,report_zong,nodata,errdata,daystarttime,xunhuan_ok
Dim pingjun_ok,leiji_ok,quality0,guding_ok,day_jiange,user_name_cell,report_auto_time_minute
Dim report_auto_shu,report_auto_ok,report_auto_out,report_auto_time,report_auto_name
On Error Resume Next
err=0
out_path = "\report"
sheetname="Sheet1"
filename_cell = "C2"
Excel_date_cell = "I2"
tagname_cell_c = 2
tagname_cell_r = 6
tagtype_cell_r = 7
tag_cell_r = 6
nodata = "*"
errdata = "#"
report_auto_shu = 1
report_auto_ok = 0
report_auto_out = 0
report_auto_time = 8
report_auto_time_minute = 0
daystarttime = 0
xunhuan_ok = 0
leiji_ok = 0
pingjun_ok = 1
quality0 = 64
guding_ok = 0
day_jiange = 60
wincc_name = HMIRuntime.ActiveProject.Path
'MsgBox wincc_name
Set tagDSNName = HMIRuntime.Tags("@DatasourceNameRT")
tagDSNName.Read
'MsgBox tagDSNName.Value
Dim set_filename,fso2,fso_ok2,MyFile,txt(30),xi
set_filename = wincc_name & out_path &"\set.txt"
Const forreading=1
xi=1
Set fso2=CreateObject("Scripting.FileSystemObject")
fso_ok2=fso2.FileExists(set_filename)
If fso_ok2 Then
Set MyFile = fso2.OpenTextFile(set_filename,forreading)
For xi=1 To 30
txt(xi)= MyFile.ReadLine
'MsgBox "第"&xi&"行:"&txt(xi)
Next
sheetname = txt(1)
filename_cell = txt(2)
Excel_date_cell = txt(3)
tagname_cell_c = txt(4)
tagname_cell_r = txt(5)
tagtype_cell_r = txt(6)
tag_cell_r = txt(7)
nodata = txt(8)
errdata = txt(9)
report_auto_shu = txt(10)
report_auto_ok = txt(11)
report_auto_out = txt(12)
report_auto_time = txt(13)
report_auto_name = txt(14)
daystarttime = txt(15)
xunhuan_ok = Cint(txt(16))
leiji_ok = Cint(txt(17))
pingjun_ok = CInt(txt(18))
quality0 = CInt(txt(19))
guding_ok = CInt(txt(20))
If CInt(txt(21)) > 0 And CInt(txt(21)) < 1440 Then
day_jiange = CInt(txt(21))
End If
user_name_cell = txt(22)
report_auto_time_minute = txt(23)
MyFile.close
Else
'MsgBox "参数设置文件不存在!"
End If
Set fso2=Nothing
HMIRuntime.Trace "go " & Time & vbCrLf
If CInt(report_auto_ok)=0 Then
Exit Function
End If
If Not (CInt(report_auto_time)=CInt(Hour(Now)) And CInt(Minute(Now))>=CInt(report_auto_time_minute) And _
CInt(Minute(Now)) <= CInt(report_auto_time_minute)+4 )Then
Exit Function
End If
Dim autodate
autodate=DateAdd("d",-1,Date())
startyear_value = CInt(Year(autodate))
startmonth_value = CInt(Month(autodate))
startday_value = CInt(Day(autodate))
Dim ryn
If Day(Date())=1 Then
If Month(Date())=1 Then
ryn =3
Else
ryn =2
End If
Else
ryn =1
End If
'报表循环-----------------------------------------------------------------------------------------
For report_type_value = 1 To ryn
For report_name_value =1 To CInt(report_auto_shu)
Dim name_c0,name_c1,name_y1,name_y2,name_t1,Rfilename
'MsgBox "report_auto_name:"&report_auto_name
name_c0=Len(CStr(report_auto_name))
name_c1=Len(CStr(report_name_value))
name_y1 = InStr(report_auto_name,CStr(CStr(report_name_value)&","))
name_t1=Right(report_auto_name,name_c0 - name_y1 - name_c1)
name_y2=InStr(name_t1,";")
'MsgBox name_t1
out_file_name=Left(name_t1,name_y2-1)
'MsgBox "out_file_name:"&out_file_name
xainshi = 1
HMIRuntime.Trace "go: " & xainshi & "%" & vbCrLf
Dim a,b
Select Case report_type_value
Case 1
a = 0
If xunhuan_ok = 0 Then
b= int(1440/day_jiange) - 1
'b = 23
Else
b= int(1440/day_jiange)
'b = 24
End If
Case 2
If (startmonth_value=1)Or(startmonth_value=3)Or(startmonth_value=5)Or(startmonth_value=7)_
Or(startmonth_value=8)Or(startmonth_value=10)Or(startmonth_value=12) Then
a = 0
b = 30
Else
If (startmonth_value=2) Then
If (((startyear_value Mod 4)=0) And ((startyear_value Mod 100)=0)) Or _
((startyear_value Mod 400)=0) Then
a = 0
b = 28
Else
a = 0
b = 27
End If
Else
a = 0
b = 29
End If
End If
Case 3
a = 0
b = 11
Case Else
a = 0
b = 23
End Select
'MsgBox "a:" & a &" b:" & b
Select Case report_type_value
Case 1
Excel_date = CStr(startyear_value) & "-" & CStr(startmonth_value) & "-" & CStr(startday_value)
patch_m = wincc_name & out_path & "\day\"
Case 2
Excel_date = CStr(startyear_value) & "-" & CStr(startmonth_value)
patch_m = wincc_name & out_path & "\month\"
Case 3
Excel_date = CStr(startyear_value)
patch_m = wincc_name & out_path & "\year\"
Case Else
Excel_date = CStr(startyear_value) & "-" & CStr(startmonth_value) & "-" & CStr(startday_value)
patch_m = wincc_name & out_path & "\day\"
End Select
filename=out_file_name &"_" & Excel_date & ".xml"
patch= patch_m & filename
'MsgBox patch
Dim fso1,fso_ok1,v1
Set fso1=CreateObject("Scripting.FileSystemObject")
fso_ok1=fso1.FileExists(patch)
' MsgBox fso_ok1
If fso_ok1=0 Then
xainshi = 5
HMIRuntime.Trace "go: " & xainshi & "%" & vbCrLf
Select Case CInt(report_type_value)
Case 1 '-选择日报表
mode_file_name = wincc_name & out_path & "\model\day" & report_name_value & ".xml"
Case 2 '-选择月报表
mode_file_name = wincc_name & out_path & "\model\month" & report_name_value & ".xml"
Case 3 '-选择年报表
mode_file_name = wincc_name & out_path & "\model\year" & report_name_value & ".xml"
End Select
'MsgBox mode_file_name
Dim fso,fso_ok
Set fso=CreateObject("Scripting.FileSystemObject")
fso_ok=fso.FileExists(mode_file_name)
If fso_ok Then
Set objExcelApp = CreateObject("Excel.Application")
objExcelApp.Visible = False
objExcelApp.Workbooks.Open mode_file_name
objExcelApp.Worksheets(sheetname).Activate
Select Case CInt(report_type_value)
Case 1 '-选择日报表
objExcelApp.Worksheets(sheetname).Range(filename_cell).value = out_file_name &"日报表"
objExcelApp.Worksheets(sheetname).Range(Excel_date_cell).value= Excel_date & "日"
Case 2 '-选择月报表
objExcelApp.Worksheets(sheetname).Range(filename_cell).value = out_file_name &"月报表"
objExcelApp.Worksheets(sheetname).Range(Excel_date_cell).value= Excel_date & "月"
Case 3 '-选择年报表
objExcelApp.Worksheets(sheetname).Range(filename_cell).value = out_file_name &"年报表"
objExcelApp.Worksheets(sheetname).Range(Excel_date_cell).value= Excel_date & "年"
Case Else
objExcelApp.Worksheets(sheetname).Range(filename_cell).value = out_file_name &"日报表"
objExcelApp.Worksheets(sheetname).Range(Excel_date_cell).value= Excel_date
End Select
'MsgBox out_file_name
If not(user_name_cell = "") Then
dim user_name
Set user_name = HMIRuntime.Tags("@CurrentUserName")
user_name.Read
objExcelApp.Worksheets(sheetname).Range(user_name_cell).value= user_name.Value
End If
Dim i_ll,line_accshu,shuzhi_1,kongjilu
For i_ll = CInt(tagname_cell_c) To CInt(tagname_cell_c)+200
shuzhi_1 = objExcelApp.Worksheets(sheetname).cells(CInt(tagname_cell_r),i_ll).value
if shuzhi_1 = "" then
kongjilu = kongjilu +1
line_accshu = i_ll
end if
if kongjilu > 3 then
kongjilu = 0
line_accshu = i_ll - 3
exit for
end if
next
xainshi = 8
HMIRuntime.Trace "go: " & xainshi & "%" & vbCrLf
For itime = a To b
Select Case report_type_value
Case 1
Dim celltime1
celltime1=DateAdd("n",day_jiange*itime,CDate(startyear_value &"-"& startmonth_value &"-"&_
startday_value & " " & daystarttime & ":00:00"))
objExcelApp.Worksheets(sheetname).cells(itime+tag_cell_r,1).value= CStr(Hour(celltime1)) &":"& CStr(Minute(celltime1))
Case 2
objExcelApp.Worksheets(sheetname).cells(itime+tag_cell_r,1).value= itime+1
Case 3
objExcelApp.Worksheets(sheetname).cells(itime+tag_cell_r,1).value= itime+1
Case Else
objExcelApp.Worksheets(sheetname).cells(itime+tag_cell_r,1).value= itime
End Select
Next
If guding_ok = 1 And report_type_value = 2 Then
If pingjun_ok = 1 Then
'objExcelApp.Worksheets(sheetname).cells(31+tag_cell_r,tagname_cell_c-1).value= "平均值"
objExcelApp.Worksheets(sheetname).cells(31+tag_cell_r,1).value= "平均值"
objExcelApp.Worksheets(sheetname).cells(32+tag_cell_r,1).value= "最小值"
objExcelApp.Worksheets(sheetname).cells(33+tag_cell_r,1).value= "最大值"
If leiji_ok = 1 Then
objExcelApp.Worksheets(sheetname).cells(34+tag_cell_r,1).value= "累积值"
End If
Else
If leiji_ok = 1 Then
objExcelApp.Worksheets(sheetname).cells(31+tag_cell_r,1).value= "累积值"
End If
End If
Else
If pingjun_ok = 1 Then
'objExcelApp.Worksheets(sheetname).cells(b+1+tag_cell_r,tagname_cell_c-1).value= "平均值"
objExcelApp.Worksheets(sheetname).cells(b+1+tag_cell_r,1).value= "平均值"
objExcelApp.Worksheets(sheetname).cells(b+2+tag_cell_r,1).value= "最小值"
objExcelApp.Worksheets(sheetname).cells(b+3+tag_cell_r,1).value= "最大值"
If leiji_ok = 1 Then
objExcelApp.Worksheets(sheetname).cells(b+4+tag_cell_r,1).value= "累积值"
End If
Else
If leiji_ok = 1 Then
objExcelApp.Worksheets(sheetname).cells(b+1+tag_cell_r,1).value= "累积值"
End If
End If
End If
sPro = "Provider=WinCCOLEDBProvider.1;"
if single_OK = 1 then
sDsn = "Catalog=" & SQL_name & ";"
sSer = "Data Source=" & PC_name &"\WinCC"
else
sDsn = "Catalog=" &tagDSNName.Value& ";"
sSer = "Data Source=.\WinCC"
End If
sCon = sPro + sDsn + sSer
Set conn = CreateObject("ADODB.Connection")
conn.ConnectionString = sCon
conn.CursorLocation = 3
conn.Open
For itag = CInt(tagname_cell_c) To line_accshu
tagname = objExcelApp.Worksheets(sheetname).cells(CInt(tagname_cell_r),itag).value
tagtype = objExcelApp.Worksheets(sheetname).cells(CInt(tagtype_cell_r),itag).value
If (StrComp(tagname,"")) Then
sumacc_one = -1.0
sumacc_last = -1.0
Dim datetime1m
For itime = a To b
Select Case report_type_value
Case 1
datetime1 = DateAdd("n",day_jiange*itime,CDate(startyear_value &"-"& startmonth_value &"-"&_
startday_value & " " & daystarttime & ":00:00"))
datetime2= DateAdd("n",day_jiange,CDate(datetime1))
'MsgBox "datetime1:" & datetime1
Case 2
datetime1= startyear_value &"-"& startmonth_value &"-"& itime+1 &" "& daystarttime &":00:00"
datetime2= DateAdd("d",+1,CDate(datetime1))
Case 3
datetime1= startyear_value &"-"& itime+1 &"-01 "& daystarttime &":00:00"
datetime2= DateAdd("m",+1,CDate(datetime1))
Case Else
datetime1 = startyear_value &"-"& startmonth_value &"-"& startday_value & " " & itime & ":00:00"
datetime1 = DateAdd("h",daystarttime,CDate(datetime1))
datetime2= DateAdd("h",+1,CDate(datetime1))
End Select
'MsgBox datetime1 & " " & datetime2
UTCBeginTime = DateAdd("h",-8,CDate(datetime1))
UTCEndTime = DateAdd("h",-8,CDate(datetime2))
UTCBeginTime = CStr(Year(UTCBeginTime) &"-"& Month(UTCBeginTime) &"-"& Day(UTCBeginTime) &" "&_
Hour(UTCBeginTime) &":"& Minute(UTCBeginTime) &":"& Second(UTCBeginTime))
UTCEndTime = CStr(Year(UTCEndTime) &"-"& Month(UTCEndTime) &"-"& Day(UTCEndTime) &" "&_
Hour(UTCEndTime) &":"& Minute(UTCEndTime) &":"& Second(UTCEndTime))
'MsgBox "UTCBeginTime:" & UTCBeginTime & "---UTCEndTime:" & UTCEndTime
sSql = "Tag:R,'" & tagname & "'," & UTCBeginTime & "','" & UTCEndTime
'sSql=sSql+",'TimeStep= 60,1'"
'HMIRuntime.Trace "sSql: " & sSql & vbCrLf
Set oRs = CreateObject("ADODB.Recordset")
Set oCom = CreateObject("ADODB.Command")
oCom.CommandType = 1
Set oCom.ActiveConnection = conn
oCom.CommandText = sSql
Set oRs = oCom.Execute
m = oRs.RecordCount
sumdate = 0.0
conmdate = 0.0
sumacc = 0.0
If (m > 0) Then
Select Case tagtype
Case 1
oRs.MoveFirst
Do While oRs.Fields("Quality").Value < quality0
oRs.MoveNext
If oRs.EOF Then
Exit Do
End If
Loop
If oRs.Fields("Quality").Value < quality0 Then
objExcelApp.Worksheets(sheetname).cells(itime+tag_cell_r,itag).value= errdata
Else
objExcelApp.Worksheets(sheetname).cells(itime+tag_cell_r,itag).value= oRs.Fields("RealValue").Value
End If
Case 2
oRs.MoveFirst
Do While Not oRs.EOF
If oRs.Fields("Quality").Value >= quality0 Then
sumdate = sumdate + oRs.Fields("RealValue").Value
conmdate = conmdate +1.0
End If
oRs.MoveNext
Loop
If conmdate = 0.0 Then
objExcelApp.Worksheets(sheetname).cells(itime+tag_cell_r,itag).value= errdata
Else
objExcelApp.Worksheets(sheetname).cells(itime+tag_cell_r,itag).value= sumdate/conmdate
End If
Case 3
oRs.MoveFirst
Do While oRs.Fields("Quality").Value < quality0
oRs.MoveNext
If oRs.EOF Then
Exit Do
End If
Loop
If oRs.Fields("Quality").Value < quality0 Then
sumacc = 0.0
Else
sumacc = oRs.Fields("RealValue").Value
If sumacc_one=-1.0 Then
sumacc_one = oRs.Fields("RealValue").Value
End If
End If
oRs.MoveLast
Do While oRs.Fields("Quality").Value < quality0
oRs.MovePrevious
If oRs.BOF Then
Exit Do
End If
Loop
If oRs.Fields("Quality").Value < quality0 Then
objExcelApp.Worksheets(sheetname).cells(itime+tag_cell_r,itag).value= errdata
Else
objExcelApp.Worksheets(sheetname).cells(itime+tag_cell_r,itag).value= oRs.Fields("RealValue").Value - sumacc
If Not(report_type_value=1 And itime>23) Then
sumacc_last = oRs.Fields("RealValue").Value
End If
End If
Case 4
oRs.MoveLast
Do While oRs.Fields("Quality").Value < quality0
oRs.MovePrevious
If oRs.BOF Then
Exit Do
End If
Loop
If oRs.Fields("Quality").Value < quality0 Then
objExcelApp.Worksheets(sheetname).cells(itime+tag_cell_r,itag).value= errdata
Else
objExcelApp.Worksheets(sheetname).cells(itime+tag_cell_r,itag).value= oRs.Fields("RealValue").Value
End If
Case Else
oRs.MoveFirst
objExcelApp.Worksheets(sheetname).cells(itime+tag_cell_r,itag).value= oRs.Fields("RealValue").Value
End Select
Else
objExcelApp.Worksheets(sheetname).cells(itime+tag_cell_r,itag).value= nodata
End If
oRs.Close
Set oRs = Nothing
Next
Dim list,list_s,list_y
If itag <=26 Then
list=Chr(itag+64)
Else
list_s = Int(itag \ 26)
list_y = Int(itag Mod 26)
If list_y = 0 Then
list_s = list_s -1
list_y = 26
End If
list= Chr(list_s+64) & Chr(list_y+64)
End If
If guding_ok = 1 And report_type_value = 2 Then
If pingjun_ok = 1 Then
objExcelApp.Worksheets(sheetname).cells(31+tag_cell_r,itag).value= "=AVERAGE("& list & tag_cell_r &":"& list & b+tag_cell_r &")" '平均值
objExcelApp.Worksheets(sheetname).cells(32+tag_cell_r,itag).value= "=Min("& list & tag_cell_r &":"& list & b+tag_cell_r &")" '最小值
objExcelApp.Worksheets(sheetname).cells(33+tag_cell_r,itag).value= "=Max("& list & tag_cell_r &":"& list & b+tag_cell_r &")" '最大值
If (tagtype = 3 And leiji_ok = 1) Then
objExcelApp.Worksheets(sheetname).cells(34+tag_cell_r,itag).value= sumacc_last - sumacc_one '累计值
'MsgBox "sumacc_last:"& sumacc_last & "- sumacc_one:" & sumacc_one & "=" & sumacc_last - sumacc_one
End If
Else
If (tagtype = 3 And leiji_ok = 1) Then
objExcelApp.Worksheets(sheetname).cells(31+tag_cell_r,itag).value= sumacc_last - sumacc_one '累计值
End If
End If
Else
If pingjun_ok = 1 Then
objExcelApp.Worksheets(sheetname).cells(b+1+tag_cell_r,itag).value= "=AVERAGE("& list & tag_cell_r &":"& list & b+tag_cell_r &")" '平均值
objExcelApp.Worksheets(sheetname).cells(b+2+tag_cell_r,itag).value= "=Min("& list & tag_cell_r &":"& list & b+tag_cell_r &")" '最小值
objExcelApp.Worksheets(sheetname).cells(b+3+tag_cell_r,itag).value= "=Max("& list & tag_cell_r &":"& list & b+tag_cell_r &")" '最大值
If (tagtype = 3 And leiji_ok = 1) Then
objExcelApp.Worksheets(sheetname).cells(b+4+tag_cell_r,itag).value= sumacc_last - sumacc_one '累计值
'MsgBox "sumacc_last:"& sumacc_last & "- sumacc_one:" & sumacc_one & "=" & sumacc_last - sumacc_one
End If
Else
If (tagtype = 3 And leiji_ok = 1) Then
objExcelApp.Worksheets(sheetname).cells(b+1+tag_cell_r,itag).value= sumacc_last - sumacc_one '累计值
End If
End If
End If
'Else
' Exit For
End If
xainshi = 10+Int((itag/line_accshu)*92)
HMIRuntime.Trace "go: " & xainshi & "%" & vbCrLf
Next
conn.Close
Set conn = Nothing
xainshi = 99
HMIRuntime.Trace "go: " & xainshi & "%" & vbCrLf
objExcelApp.DisplayAlerts = False
objExcelApp.ActiveWorkbook.SaveAs patch
'打印机输出
If CInt(report_auto_out)=1 Then
objExcelApp.ActiveSheet.PrintOut
End If
objExcelApp.ActiveWorkbook.Saved = True
objExcelApp.Workbooks.Close False
objExcelApp.Quit
Set objExcelApp= Nothing
xainshi = 100
HMIRuntime.Trace "go: " & xainshi & "%" & vbCrLf
'MsgBox "生成数据文件成功!文件保存在" & patch_m
Else
HMIRuntime.Trace "没有模板文件:" & mode_file_name & vbCrLf
End If
Set fso=Nothing
Else
HMIRuntime.Trace "报表文件" & patch & "已经存在!"& vbCrLf
End If
Set fso1=Nothing
Next '报表数循环
Next '报表日月年循环
'MsgBox "自动生成数据文件成功!文件保存在"
HMIRuntime.Trace "end" & vbCrLf
End Function
最新发布