数据导入窗口.frm

光栅式指示表检定仪应用程序

    Dim xlbook As Excel.Workbook
    Dim xlsheet1 As Excel.Worksheet
    Dim xlsheet2 As Excel.Worksheet
    Dim record(300) As String
    Dim rec1(120) As String
    Dim rec2(120) As String
    Dim s1 As String
    Dim s2 As String
    Dim s3 As String
    Dim no As String
    Dim i As Integer, j As Integer, k As Integer, sn As Integer, n As Integer
    Dim a As Integer, b As Integer, c As Integer, l As Integer
    i = 0
    Do While i < 300
        record(i) = ""
        i = i + 1
    Loop
    i = 0
    Do While i < 120
        rec1(i) = "/"
        rec2(i) = "/"
        i = i + 1
    Loop
    i = 1
    j = 0
    s1 = Mid(s, i, 1)
    s2 = ""
    Do While s1 <> "#"
        If s1 <> "," Then
            s2 = s2 + s1
        Else
            s2 = Trim(s2)
            record(j) = s2
            j = j + 1
            s2 = ""
        End If
        i = i + 1
        s1 = Mid(s, i, 1)
    Loop
    Select Case record(3)
        Case "(0 ～ 3)mm百分表"
            sn = 34
            n = 3
            c = 0
            l = 0
        Case "(0 ～ 5)mm百分表"
            sn = 34
            n = 5
            c = 0
            l = 0
        Case "(0 ～ 10)mm百分表"
            sn = 34
            n = 10
            c = 0
            l = 0
        Case "(0 ～ 20)mm百分表"
            sn = 32
            n = 4
            c = 1
            l = 0
        Case "(0 ～ 30)mm百分表"
            sn = 32
            n = 6
            c = 1
            l = 0
        Case "(0 ～ 50)mm百分表"
            sn = 32
            n = 10
            c = 2
            l = 0
        Case "(0 ～ 1)mm千分表"
            sn = 32
            'n = 2
            n = 5
            c = 2
            l = 1
        Case "(0 ～ 2)mm千分表"
            sn = 32
            'n = 4
            n = 10
            c = 2
            l = 1
        Case "(0 ～ 3)mm千分表"
            sn = 32
            'n = 6
            n = 15
            c = 2
            l = 1
        Case "(0 ～ 5)mm千分表"
            sn = 32
            'n = 5
            n = 15
            c = 2
            l = 1
    End Select
    i = sn
    j = n
    k = 0
    Do While j > 0
        rec1(k) = record(i)
        k = k + 1
        If l = 0 Then
            If ((i - sn) Mod 10 = 0) And (i <> sn) Then
                j = j - 1
                If j <> 0 Then
                    rec1(k) = record(i)
                    k = k + 1
                End If
            End If
        ElseIf l = 1 Then
            If ((i - sn) Mod 4 = 0) And (i <> sn) Then
                j = j - 1
                If j <> 0 Then
                    rec1(k) = record(i)
                    k = k + 1
                End If
            End If
        Else
            MsgBox "不存在该选项!", vbExclamation + vbOKOnly, "提示"
        End If
        i = i + 1
    Loop
    sn = i
    j = n
    k = 0
    Do While j > 0
        rec2(k) = record(i)
        k = k + 1
        If l = 0 Then
            If ((i - sn) Mod 10 = 0) And (i <> sn) Then
                j = j - 1
                If j <> 0 Then
                    rec2(k) = record(i)
                    k = k + 1
                End If
            End If
        ElseIf l = 1 Then
            If ((i - sn) Mod 4 = 0) And (i <> sn) Then
                j = j - 1
                If j <> 0 Then
                    rec2(k) = record(i)
                    k = k + 1
                End If
            End If
        Else
            MsgBox "不存在该选项!", vbExclamation + vbOKOnly, "提示"
        End If
        i = i + 1
    Loop
    
    Adodc1.Recordset.MoveLast
    s3 = Adodc1.Recordset.Fields(0)
    s1 = Mid(s3, 1, 4)
    s2 = Mid(s3, 5, 8)
    s2 = Val(s2) + 1
    s3 = Trim(s1) & Trim(Str$(s2))
    no = Trim(s3)
    Adodc1.Recordset.Fields(0) = s3
    Adodc1.Recordset.Update
    
    Set xlapp = CreateObject("excel.application")
    Set xlbook = xlapp.Workbooks.Add
    If l = 0 Then
        Set fil1 = fso.GetFile(app_path & "\model\JDY.xls")
        fil1.Copy (app_path & "\打印文件\" & no & ".xls")
        Set xlbook = Workbooks.Open(app_path & "\打印文件\" & no & ".xls")
        Set xlsheet1 = xlbook.Worksheets(1)
        Set xlsheet2 = xlbook.Worksheets(2)
        i = 0
        j = 0
        Do While j < 10
            a = 15 + j * 2
            b = 16 + j * 2
            xlsheet1.Range("c" & Trim(Str$(a))) = rec1(i)
            xlsheet1.Range("c" & Trim(Str$(b))) = rec2(i)
            i = i + 1
            xlsheet1.Range("D" & Trim(Str$(a))) = rec1(i)
            xlsheet1.Range("D" & Trim(Str$(b))) = rec2(i)
            i = i + 1
            xlsheet1.Range("E" & Trim(Str$(a))) = rec1(i)
            xlsheet1.Range("E" & Trim(Str$(b))) = rec2(i)
            i = i + 1
            xlsheet1.Range("F" & Trim(Str$(a))) = rec1(i)
            xlsheet1.Range("F" & Trim(Str$(b))) = rec2(i)
            i = i + 1
            xlsheet1.Range("G" & Trim(Str$(a))) = rec1(i)
            xlsheet1.Range("G" & Trim(Str$(b))) = rec2(i)
            i = i + 1
            xlsheet1.Range("H" & Trim(Str$(a))) = rec1(i)
            xlsheet1.Range("H" & Trim(Str$(b))) = rec2(i)
            i = i + 1
            xlsheet1.Range("I" & Trim(Str$(a))) = rec1(i)
            xlsheet1.Range("I" & Trim(Str$(b))) = rec2(i)
            i = i + 1
            xlsheet1.Range("J" & Trim(Str$(a))) = rec1(i)
            xlsheet1.Range("J" & Trim(Str$(b))) = rec2(i)
            i = i + 1
            xlsheet1.Range("K" & Trim(Str$(a))) = rec1(i)
            xlsheet1.Range("K" & Trim(Str$(b))) = rec2(i)
            i = i + 1
            xlsheet1.Range("L" & Trim(Str$(a))) = rec1(i)
            xlsheet1.Range("L" & Trim(Str$(b))) = rec2(i)
            i = i + 1
            xlsheet1.Range("M" & Trim(Str$(a))) = rec1(i)
            xlsheet1.Range("M" & Trim(Str$(b))) = rec2(i)
            i = i + 1
            If i Mod 11 = 0 Then
                j = j + 1
            End If
        Loop
    ElseIf l = 1 Then
        Set fil1 = fso.GetFile(app_path & "\model\JDY1.xls")
        fil1.Copy (app_path & "\打印文件\" & no & ".xls")
        Set xlbook = Workbooks.Open(app_path & "\打印文件\" & no & ".xls")
        Set xlsheet1 = xlbook.Worksheets(1)
        Set xlsheet2 = xlbook.Worksheets(2)
        i = 0
        j = 0
        Do While j < 10
            a = 15 + j * 2
            b = 16 + j * 2
            xlsheet1.Range("c" & Trim(Str$(a))) = rec1(i)
            xlsheet1.Range("c" & Trim(Str$(b))) = rec2(i)
            i = i + 1
            xlsheet1.Range("E" & Trim(Str$(a))) = rec1(i)
            xlsheet1.Range("E" & Trim(Str$(b))) = rec2(i)
            i = i + 1
            xlsheet1.Range("G" & Trim(Str$(a))) = rec1(i)
            xlsheet1.Range("G" & Trim(Str$(b))) = rec2(i)
            i = i + 1
            xlsheet1.Range("I" & Trim(Str$(a))) = rec1(i)
            xlsheet1.Range("I" & Trim(Str$(b))) = rec2(i)
            i = i + 1
            xlsheet1.Range("K" & Trim(Str$(a))) = rec1(i)
            xlsheet1.Range("K" & Trim(Str$(b))) = rec2(i)
            i = i + 1
            If i Mod 5 = 0 Then
                j = j + 1
            End If
        Loop
    End If
    xlsheet1.Range("c3") = record(5)
    xlsheet1.Range("i3") = Left(Trim(record(11)), Len(Trim(record(11))) - 2)
    If l = 0 Then
        xlsheet1.Range("o3") = "0.01"
    ElseIf l = 1 Then
        xlsheet1.Range("o3") = "0.001"
    End If
    xlsheet1.Range("q3") = record(14) & "℃"
    xlsheet1.Range("c4") = Right(Trim(record(3)), 3)
    xlsheet1.Range("i4") = record(4)
    xlsheet1.Range("o4") = record(2)
    xlsheet1.Range("q4") = record(13) & "%"
    If l = 0 Then
        xlsheet1.Range("p35") = record(16)
    Else
        xlsheet1.Range("o35") = record(16)
    End If
    If c = 0 Then
        xlsheet1.Range("n15") = record(31) & "μm(" & record(30) & "mm段)"
        xlsheet1.Range("o15") = record(33) & "μm(" & record(32) & "mm处)"
        xlsheet1.Range("p15") = record(27) & "μm"
        xlsheet1.Range("q15") = record(29) & "μm(" & record(28) & "mm处)"
    ElseIf c = 1 Or c = 2 Then
        xlsheet1.Range("m15") = record(31) & "μm(" & record(30) & "mm段)"
        If l = 0 Then
            xlsheet1.Range("p15") = record(27) & "μm"
        Else
            xlsheet1.Range("o15") = record(27) & "μm"
        End If
        xlsheet1.Range("q15") = record(29) & "μm(" & record(28) & "mm处)"
    End If
    ''Adodc1.Recordset.Open
    'Adodc1.Recordset.MoveLast
    's3 = Adodc1.Recordset.Fields(0)
    's1 = Mid(s3, 1, 4)
    's2 = Mid(s3, 5, 8)
    's2 = Val(s2) + 1
    's3 = Trim(s1) & Trim(Str$(s2))
    'Adodc1.Recordset.Fields(0) = s3
    'Adodc1.Recordset.Update
    'Adodc1.Recordset.Close
    xlsheet2.Range("d6") = s3 ' 证书编号：
    xlsheet2.Range("d8") = record(5) '   委托方
    xlsheet2.Range("d9") = record(3) '   计量器具名称
    xlsheet2.Range("d10") = record(11) '   型   号  规   格
    xlsheet2.Range("d11") = record(4) '   制      造      厂
    xlsheet2.Range("d12") = record(2) '   出   厂  编   号
    xlsheet2.Range("d13") = "------" '   器   具   编   号
    xlsheet2.Range("d14") = record(16) '   结                论
    xlsheet2.Range("c20") = record(10) '检定日期
    s1 = Left$(Trim(record(10)), 5)
    i = Val(s1)
    s2 = Mid$(Trim(record(10)), 6, Len(Trim(record(10))) - 8)
    j = Val(s2)
    s3 = Right$(Trim(record(10)), 3)
    k = Val(s3)
    i = i + 1
    k = k - 1
    If k = 0 Then
        j = j - 1
        If j = 0 Then
            i = i - 1
            j = 12
            k = 30
        Else
            Select Case j
                Case 1, 3, 5, 7, 8, 10, 12
                    k = 31
                Case 2
                    If (i Mod 100 = 0 And i Mod 400 = 0) Or (i Mod 100 <> 0 And i Mod 4 = 0) Then
                        k = 29
                    Else
                        k = 28
                    End If
                Case 4, 6, 9, 11
                    k = 30
            End Select
        End If
    End If
    xlsheet2.Range("c21") = Trim(Str$(i)) & Trim("年") & Trim(Str$(j)) & Trim("月") & Trim(Str$(k)) & Trim("日") '检定日期
    xlbook.Save
    xlbook.Close
    Workbooks.Close
    xlapp.Quit
    aa = Shell("d:\Office10\excel.exe " & app_path & "\打印文件\" & no & ".xls" & " ", vbNormalFocus)
    
    
End Sub

Private Sub Command3_Click()
    End
End Sub

Private Sub Command4_Click()
    tlen = tlen - 1
    If tlen > 0 Then
        s = ts.ReadLine + ",#"
        Text1.Text = s
    Else
        Command4.Enabled = False
    End If
End Sub

Private Sub Command5_Click()
    Set fill = fso.GetFile(CommonDialog1.FileName)
    Set ts = fill.OpenAsTextStream(ForReading)
    Set ts1 = fill.OpenAsTextStream(ForReading)
    s = ts.ReadLine
    s = s + ",#"
    Text1.Text = s
    tlen = 1
    sa = ts1.ReadLine
    Do While ts1.AtEndOfStream = False
        sa = ts1.ReadLine
        tlen = tlen + 1
    Loop
    Command4.Enabled = True
End Sub

Private Sub Command6_Click()
    ts.Close
    ts1.Close
    Text1.Text = ""
    Command2.Enabled = False
    Command4.Enabled = False
    Command5.Enabled = False
End Sub

Private Sub Command7_Click()
    Dim s1 As String
    Dim s2 As String
    Dim s3 As String
    s3 = Text2.Text
    If Len(Trim(s3)) = 12 Then
        Adodc1.Recordset.MoveLast
        s1 = Mid(s3, 1, 4)
        s2 = Mid(s3, 5, 8)
        s2 = Val(s2) - 1
        s3 = Trim(s1) & Trim(Str$(s2))
        Adodc1.Recordset.Fields(0) = s3
        Adodc1.Recordset.Update
        MsgBox "恭喜您，您的证书编号修改操作成功!", vbExclamation + vbOKOnly, "修改成功"
    Else
        MsgBox "证书编号输入错误，请重新输入!", vbExclamation + vbOKOnly, "提示"
    End If
End Sub

Private Sub Command8_Click()
    Unload Me
    登录窗口.Show
    登录窗口.Text2.Text = ""
    登录窗口.Text3.Text = ""
End Sub

Private Sub Command9_Click()
    Dim aa As String
    aa = Shell("d:\检定仪27N\jdy27.exe " & " ", vbNormalFocus)
End Sub

Private Sub Form_Load()
    app_path = App.Path
    Adodc1.Refresh
    数据导入窗口.Height = 6800
    Frame3.Height = 2399.675
    Command2.Enabled = False
    Command4.Enabled = False
    Command5.Enabled = False
    Command6.Enabled = False
    'If Adodc2.Recordset.Fields(0) = 1 Then
    If user = 1 Then
        Frame3.Enabled = True
        Text2.Enabled = True
        Label1.Enabled = True
        Label2.Enabled = False
        Label2.Visible = False
        Command7.Enabled = True
        数据导入窗口.Height = 6300
        Frame3.Height = 1600
    'ElseIf Adodc2.Recordset.Fields(0) = 2 Then
    Else
        Frame3.Enabled = False
        Text2.Enabled = False
        Label1.Enabled = False
        Label2.Enabled = True
        Label2.Visible = True
        Command7.Enabled = False
    End If
End Sub