📄 mdlmain.bas
字号:
PwdLenToString = "1"
Case 2
PwdLenToString = "2"
Case 3
PwdLenToString = "3"
Case 4
PwdLenToString = "4"
Case 5
PwdLenToString = "5"
Case 6
PwdLenToString = "6"
Case 7
PwdLenToString = "7"
Case 8
PwdLenToString = "8"
Case 9
PwdLenToString = "9"
Case 10
PwdLenToString = "A"
Case 11
PwdLenToString = "B"
Case 12
PwdLenToString = "C"
Case 13
PwdLenToString = "D"
Case 14
PwdLenToString = "E"
Case 15
PwdLenToString = "F"
Case 16
PwdLenToString = "G"
Case 17
PwdLenToString = "H"
Case 18
PwdLenToString = "I"
Case 19
PwdLenToString = "J"
Case 20
PwdLenToString = "K"
End Select
End Function
'关闭对应窗口
'=====================================================================================================================================
Public Sub CloseWindows(WindowsStyle As String)
Select Case WindowsStyle
Case "FrmWarrant"
FrmStu.FrmWarrant = True
Case "CloseAll"
FrmStu.FrmWarrant = True
End Select
End Sub
'=====================================================================================================================================
Public Sub Mdb2Excel(Rec As ADODB.Recordset, strCaption As String, strPh As String)
Dim xlApp As New Excel.Application
Dim xlSheet As Excel.Worksheet
Dim xlBook As Excel.Workbook
Dim T, AAA, AA, a, B As Integer
Dim Tm, Tpjbf, Tshjf, Tzhm, Tpfm As Double
T = 0: AAA = 0: AA = 0: a = 0: B = 0
Tm = 0: Tpjbf = 0: Tshjf = 0: Tzhm = 0: Tpfm = 0
On Error GoTo Err_TxlApp
DoEvents
Set xlBook = xlApp.Workbooks.Open(strCaption)
Set xlSheet = xlApp.Worksheets(1)
' xlSheet.Unprotect "indestyp"
Rec.MoveFirst
xlSheet.Cells(3, 4) = Val(Rec.Fields("pid"))
xlSheet.Cells(6, 4) = Rec.Fields("orderid")
xlSheet.Cells(6, 8) = strPh
xlSheet.Cells(6, 17) = Rec.Fields("xh")
xlSheet.Cells(6, 36) = Rec.Fields("year")
xlSheet.Cells(6, 39) = Rec.Fields("month")
xlSheet.Cells(6, 41) = Rec.Fields("day")
xlSheet.Cells(8, 4) = Rec.Fields("bf")
xlSheet.Cells(8, 8) = Rec.Fields("ys")
xlSheet.Cells(8, 17) = Rec.Fields("zhsh")
xlSheet.Cells(8, 34) = Rec.Fields("bch")
xlSheet.Cells(12, 8) = Rec.Fields("lx")
Do While Not Rec.EOF
T = T + 1
Tm = Val(Rec.Fields("shjm")) + Tm
Tpjbf = Val(Rec.Fields("pjbf")) + Tpjbf
Tshjf = Val(Rec.Fields("shjf")) + Tshjf
Tzhm = Val(Rec.Fields("zhm")) + Tzhm
Tpfm = Val(Rec.Fields("pfm")) + Tpfm
Select Case Rec.Fields("dj")
Case "AAA"
AAA = AAA + 1
Case "AA"
AA = AA + 1
Case "A"
a = a + 1
Case "B"
B = B + 1
End Select
xlSheet.Rows(14 + Rec.AbsolutePosition).Insert
xlSheet.Cells(13 + Rec.AbsolutePosition, 2) = Val(Rec.Fields("pid"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 3) = Rec.Fields("shjm")
xlSheet.Cells(13 + Rec.AbsolutePosition, 4) = Rec.Fields("shjf")
xlSheet.Cells(13 + Rec.AbsolutePosition, 5) = Rec.Fields("zhm")
xlSheet.Cells(13 + Rec.AbsolutePosition, 6) = Rec.Fields("pfm")
xlSheet.Cells(13 + Rec.AbsolutePosition, 7) = Rec.Fields("pjbf")
xlSheet.Cells(13 + Rec.AbsolutePosition, 8) = Rec.Fields("lxzh")
xlSheet.Cells(13 + Rec.AbsolutePosition, 9) = Rec.Fields("dj")
If Rec.Fields("pd") = 0 Then
xlSheet.Cells(13 + Rec.AbsolutePosition, 10) = "不合格"
Else
xlSheet.Cells(13 + Rec.AbsolutePosition, 10) = "合格"
End If
xlSheet.Cells(13 + Rec.AbsolutePosition, 11) = Rec.Fields("day") & "/" & Rec.Fields("month")
xlSheet.Cells(13 + Rec.AbsolutePosition, 12) = GetVal(Rec.Fields("a"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 13) = GetVal(Rec.Fields("b"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 14) = GetVal(Rec.Fields("c"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 15) = GetVal(Rec.Fields("d"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 16) = GetVal(Rec.Fields("e"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 17) = GetVal(Rec.Fields("f"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 18) = GetVal(Rec.Fields("g"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 19) = GetVal(Rec.Fields("h"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 20) = GetVal(Rec.Fields("i"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 21) = GetVal(Rec.Fields("j"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 22) = GetVal(Rec.Fields("k"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 23) = GetVal(Rec.Fields("l"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 24) = GetVal(Rec.Fields("m"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 25) = GetVal(Rec.Fields("n"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 26) = GetVal(Rec.Fields("o"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 27) = GetVal(Rec.Fields("p"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 28) = GetVal(Rec.Fields("q"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 29) = GetVal(Rec.Fields("r"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 30) = GetVal(Rec.Fields("s"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 31) = GetVal(Rec.Fields("t"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 32) = GetVal(Rec.Fields("u"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 33) = GetVal(Rec.Fields("v"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 34) = GetVal(Rec.Fields("w"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 35) = GetVal(Rec.Fields("x"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 36) = GetVal(Rec.Fields("y"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 37) = GetVal(Rec.Fields("z"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 38) = GetVal(Rec.Fields("aa"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 39) = GetVal(Rec.Fields("ab"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 40) = GetVal(Rec.Fields("ac"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 41) = GetVal(Rec.Fields("ad"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 42) = GetVal(Rec.Fields("ae"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 43) = GetVal(Rec.Fields("af"))
xlSheet.Cells(13 + Rec.AbsolutePosition, 44) = GetVal(Rec.Fields("ag"))
Rec.MoveNext
Loop
Rec.MoveLast
xlSheet.Cells(3, 8) = Val(Rec.Fields("pid"))
xlSheet.Cells(17 + Rec.RecordCount, 4) = Tm
xlSheet.Cells(19 + Rec.RecordCount, 4) = Format(Tpjbf / T, "####.#")
xlSheet.Cells(17 + Rec.RecordCount, 11) = Format(Tshjf / T, "####.#")
xlSheet.Cells(19 + Rec.RecordCount, 11) = Format(Tzhm / T, "####.#")
xlSheet.Cells(21 + Rec.RecordCount, 11) = Format(Tpfm / T, "####.#")
xlSheet.Cells(19 + Rec.RecordCount, 21) = AAA
xlSheet.Cells(19 + Rec.RecordCount, 25) = Format(100 * AAA / T, "####.#")
xlSheet.Cells(21 + Rec.RecordCount, 21) = AA
xlSheet.Cells(21 + Rec.RecordCount, 25) = Format(100 * AA / T, "####.#")
xlSheet.Cells(23 + Rec.RecordCount, 21) = a
xlSheet.Cells(23 + Rec.RecordCount, 25) = Format(100 * a / T, "####.#")
xlSheet.Cells(25 + Rec.RecordCount, 21) = B
xlSheet.Cells(25 + Rec.RecordCount, 25) = Format(100 * B / T, "####.#")
' If Dir(strCaption) <> "" Then Kill strCaption
xlApp.AlertBeforeOverwriting = False
xlSheet.Protect
xlApp.Workbooks(1).Save
xlApp.Visible = True
DoEvents
If Not (xlSheet Is Nothing) Then
Set xlSheet = Nothing
End If
If Not (xlBook Is Nothing) Then
Set xlBook = Nothing
End If
If Not (xlApp Is Nothing) Then
Set xlApp = Nothing
End If
Exit_TxlApp:
On Error GoTo 0
Exit Sub
Err_TxlApp:
Select Case Err
Case 0
Resume Next
Case Else
MsgBox "Error: " & Err.Number & vbCrLf & vbCrLf & _
Err.Description, vbInformation, App.Title & " - Advisory"
' Resume
End Select
End Sub
Private Function GetVal(S As String) As String
Dim j As Integer
Dim v As Integer
S = Trim(S)
v = 0
For j = 1 To Len(S)
If IsNumeric(Mid(S, j, 1)) Then v = v + Val(Mid(S, j, 1))
Next j
GetVal = v
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -