一年多前写的代码,看看先:
On Error GoTo errMessage
Screen.MousePointer = 11
Dim sql As String, page As Integer Dim A2$, A4$, A6$, C2$, C6$, M2$, M4$, M6$, A8$, B8$, C7$, A37$, F37$, M37$
C2 = getKeyVal("Company", "Title", "", langINI)
A2 = getKeyVal("IRReport", "IRReport02", "", langINI)
A4 = getKeyVal("IRReport", "IRReport03", "", langINI)
A6 = getKeyVal("IRReport", "IRReport04", "", langINI)
C6 = getKeyVal("IRReport", "IRReport01", "", langINI)
M2 = getKeyVal("IRReport", "IRReport05", "", langINI)
M4 = getKeyVal("IRReport", "IRReport06", "", langINI)
M6 = getKeyVal("IRReport", "IRReport07", "", langINI)
A8 = getKeyVal("IRReport", "IRReport08", "", langINI)
B8 = getKeyVal("IRReport", "IRReport09", "", langINI)
C7 = getKeyVal("IRReport", "IRReport10", "", langINI)
A37 = getKeyVal("IRReport", "IRReport11", "", langINI)
F37 = getKeyVal("IRReport", "IRReport12", "", langINI)
M37 = getKeyVal("IRReport", "IRReport13", "", langINI)
Dim xlsBook As Excel.Workbook
Dim xlsApp As Excel.Application
Dim xlsSheet As Excel.Worksheet Set xlsBook = GetObject(App.Path & "\IPQC.xls")
If xlsBook Is Nothing Then
Screen.MousePointer = 0
MsgBox Err.Description, vbExclamation
Exit Sub
End If
Set xlsApp = xlsBook.Application
xlsApp.Visible = True
xlsApp.Parent.Windows("IPQC.xls").Visible = True
xlsApp.WindowState = xlMinimized
'xlsApp.DisplayAlerts = False
On Error GoTo errMessage
Screen.MousePointer = 11
Dim sql As String, page As Integer Dim A2$, A4$, A6$, C2$, C6$, M2$, M4$, M6$, A8$, B8$, C7$, A37$, F37$, M37$
C2 = getKeyVal("Company", "Title", "", langINI)
A2 = getKeyVal("IRReport", "IRReport02", "", langINI)
A4 = getKeyVal("IRReport", "IRReport03", "", langINI)
A6 = getKeyVal("IRReport", "IRReport04", "", langINI)
C6 = getKeyVal("IRReport", "IRReport01", "", langINI)
M2 = getKeyVal("IRReport", "IRReport05", "", langINI)
M4 = getKeyVal("IRReport", "IRReport06", "", langINI)
M6 = getKeyVal("IRReport", "IRReport07", "", langINI)
A8 = getKeyVal("IRReport", "IRReport08", "", langINI)
B8 = getKeyVal("IRReport", "IRReport09", "", langINI)
C7 = getKeyVal("IRReport", "IRReport10", "", langINI)
A37 = getKeyVal("IRReport", "IRReport11", "", langINI)
F37 = getKeyVal("IRReport", "IRReport12", "", langINI)
M37 = getKeyVal("IRReport", "IRReport13", "", langINI)
Dim xlsBook As Excel.Workbook
Dim xlsApp As Excel.Application
Dim xlsSheet As Excel.Worksheet Set xlsBook = GetObject(App.Path & "\IPQC.xls")
If xlsBook Is Nothing Then
Screen.MousePointer = 0
MsgBox Err.Description, vbExclamation
Exit Sub
End If
Set xlsApp = xlsBook.Application
xlsApp.Visible = True
xlsApp.Parent.Windows("IPQC.xls").Visible = True
xlsApp.WindowState = xlMinimized
'xlsApp.DisplayAlerts = False
Dim file As String, outputdir As String
file = App.Path & SETTINGPRIVATEPROFILENAME
outputdir = getKeyVal("Setting", "ReportDir", "c:\report", file)
If Right(outputdir, 1) = "\" Then
outputdir = Left(outputdir, Len(outputdir) - 1)
End If
Dim ts As String
ts = Dir(outputdir, vbDirectory)
If ts = "" Then
outputdir = "c:"
End If
Set xlsSheet = xlsBook.ActiveSheet
Dim rgPN As String, pnid As Integer, rgName As String, rgCP As String, rgOP As String, rgMN As String, mnid As Integer
Dim recPN As New ADODB.Recordset
Dim sampf, sampu, t
t = InStr(sampfreq, "/") + 1
sampf = val(sampfreq)
sampu = Mid(sampfreq, t)
sql = "select idxPNID, cppartname, ctProcessDrawingNo from producttable where cppartno='" & pn & "'"
recPN.Open sql, conn, adOpenKeyset, adLockReadOnly
If recPN.RecordCount > 0 Then
rgPN = pn
pnid = recPN("idxPNID")
rgName = recPN("cppartname")
rgCP = recPN("ctProcessDrawingNo")
End If
recPN.Close
Set recPN = Nothing
mnid = getID(conn, "MachineTable", "IdxMNID", "MachineNo", mn)
Dim recSPEC As New ADODB.Recordset
sql = "SELECT DISTINCT dimensionno AS DIMNO, nominal AS NOM, uptol AS UPT, lowtol AS LOWT FROM DATA WHERE idxpnid=" & pnid & " AND idxmnid=" & mnid & _
" AND workingprocedure='" & op & "' AND go_ng=0 AND (inspectiontime BETWEEN '" & _
Format(stime, "yyyy/MM/dd hh:mm:ss") & "' AND '" & _
Format(etime, "yyyy/MM/dd hh:mm:ss") & "' AND SampleFrequency=" & sampf & " AND SampleFreqUnits ='" & sampu & "') ORDER BY DIMNO "
recSPEC.Open sql, conn, adOpenKeyset, adLockReadOnly
Dim recData As New ADODB.Recordset, row As Long, col As Long
Dim sqlQry As String, timeline As Integer
row = 10: timeline = 1
Dim head(15) As String
Dim vpagecounter As Long '|
Dim hpagecounter As Long '_
Dim maxhpagecounter As Long
head(1) = A2
head(2) = rgName
head(3) = A4
head(4) = rgCP
head(5) = A6
head(6) = rgPN
head(7) = C2
head(8) = C6
head(9) = M2
head(10) = op
head(11) = M4
head(12) = mn
head(13) = M6
head(14) = Date
head(15) = C7
vpagecounter = 0 '羇璸计
hpagecounter = 0 '绢璸计
maxhpagecounter = 0 'max
With xlsSheet
Dim isOK As Boolean
isOK = False
If recSPEC.RecordCount > 0 Then
If recSPEC.RecordCount Mod 26 <> 0 Then
page = recSPEC.RecordCount \ 26 + 1
Else
page = recSPEC.RecordCount \ 26
End If
Do While Not recSPEC.EOF
'***繷
''ipqcrptheader xlsSheet, vpagecounter, hpagecounter, head
'***
col = 1
sqlQry = "SELECT * FROM DATA WHERE idxpnid=" & pnid & " AND idxmnid=" & mnid & _
" AND workingprocedure='" & op & "' AND (inspectiontime BETWEEN '" & _
Format(stime, "yyyy/MM/dd HH:mm:ss") & "' AND '" & Format(etime, "yyyy/MM/dd HH:mm:ss") & "') AND dimensionno='" & recSPEC("DIMNO") & _
"' AND nominal=" & recSPEC("NOM") & " AND uptol=" & recSPEC("UPT") & _
" AND lowtol=" & recSPEC("LOWT") & " AND go_ng=0 ORDER BY SampleTime"
recData.Open sqlQry, conn, adOpenKeyset, adLockReadOnly
If recData.RecordCount > 0 Then
Debug.Print recSPEC.RecordCount
Do While Not recData.EOF
'***繷
If col Mod 16 = 1 Or row Mod 35 = 1 Then
ipqcrptheader xlsSheet, vpagecounter, hpagecounter, head
End If
'***item
If col Mod 16 = 1 Then
.Cells(row, col) = recData("dimensionno")
col = col + 1
.Cells(row, col) = recData("nominal") & " (" & recData("uptol") & "/" & recData("lowtol") & ")"
col = col + 1
timeline = col
End If
'***date/time
If col >= timeline Then
.Cells(8, col) = Format(DateValue(recData("SampleTime")), "yy/M/D")
.Cells(9, col) = Format(TimeValue(recData("SampleTime")), "hh:mm:ss")
End If
If row = (35) * (vpagecounter) + 10 Or col >= timeline Then
.Cells((35) * (vpagecounter) + 10 - 2, col) = Format(DateValue(recData("SampleTime")), "yy/M/D")
.Cells((35) * (vpagecounter) + 10 - 1, col) = Format(TimeValue(recData("SampleTime")), "hh:mm:ss")
End If
'***measure value
.Cells(row, col) = recData("actual")
'*** fail vlaue
If recData("actual") > (recData("nominal") + recData("uptol")) Or recData("actual") < (recData("nominal") + recData("lowtol")) Then
''.Cells(row, col).Font.Bold = True
.Cells(row, col).Font.Underline = xlUnderlineStyleSingle
.Cells(row, col).Font.Italic = True
End If
recData.MoveNext
col = col + 1
timeline = col
If (col Mod 16) = 1 Then
hpagecounter = hpagecounter + 1
If maxhpagecounter <= hpagecounter Then
maxhpagecounter = hpagecounter
End If
End If
Loop
End If
'timeline = 1
recData.Close
Set recData = Nothing
recSPEC.MoveNext
hpagecounter = 0
row = row + 1
If row > (35) * (vpagecounter + 1) Then
row = row + 9 ' * (vpagecounter + 1) + 26 * vpagecounter
vpagecounter = vpagecounter + 1
End If
Loop
'***delete rest grid
.Rows(CStr(page * 35 + 1) & ":5000").Delete Shift:=xlUp
'.Columns(.Range(.Cells(1, maxhpagecounter * 16 + 1), .Cells(page * 35 + 1, 225))).Delete Shift:=xlToLeft
.Range(.Cells(1, (maxhpagecounter + 1) * 16 + 1), .Cells(page * 35 + 1, 225)).Delete Shift:=xlToLeft
.Range("a1").Select
'***setting print area
.PageSetup.PrintArea = .Range(.Cells(1, 1), .Cells(page * 35, (maxhpagecounter + 1) * 16)).Address
If isSave Then
.SaveAs outputdir & "\" & Format(Now(), "yyyyMMddhhmmss") & ".xls"
End If
'If isPrint Then
' .PrintOut
'End If
.PrintPreview
xlsApp.WindowState = xlMaximized
isOK = True
End If
If isOK Then GoTo goEnd
errMessage:
Screen.MousePointer = 0
MsgBox getKeyVal("Message", "Message04", "Error:" & vbCr & Err.Description, langINI), vbExclamation
goEnd:
On Error Resume Next
xlsApp.WindowState = xlMaximized
recSPEC.Close
Set recSPEC = Nothing
'xlsApp.Quit
Set xlsSheet = Nothing
Set xlsBook = Nothing
Set xlsApp = Nothing
End With Screen.MousePointer = 0