datainfrm.frm

一个关于进销存的源代码

                  Else
                '     Dim ts As String
                     ts = MsgBox("导入相同记录,确定覆盖,取消跳过", vbOKCancel, "记录重复")
                      If ts = vbOK Then
                '        Dim dr As New ADODB.Recordset
                          dr.Open "delete * from " & mdbname & " where 区='" & rdst.Fields(1).Value & "'and 序号='" & rdst.Fields(3).Value & "'", g_conn
                        Set dr = Nothing
                                   xlsvalue = ""
                                     For i = 1 To mdbcols
                                        If IsNull(rdst.Fields(i - 1).Value) = True Then
                                           xlsvalue = xlsvalue & "'0'" & ","
                                        Else
                                           xlsvalue = xlsvalue & "'" & rdst.Fields(i - 1).Value & "'" & ","
                                        End If
                                     Next i
                                     xlsvalue = Left(xlsvalue, Len(xlsvalue) - 1)
                                    '打开mdb进行追加
                                     rdst2.Open "insert into " & mdbname & " values(" & xlsvalue & ")", g_conn
                         Else
                           MsgBox "跳过" & rdst.Fields(2).Value & rdst.Fields(4).Value, vbOKOnly, "跳过记录"
                         End If
                    End If
                    Set ardst = Nothing
                    rdst.MoveNext
                Loop
                 killmore (mdbname)
             Set rdst = Nothing
             Set rdst2 = Nothing
             Set rdst3 = Nothing
             xlsname = ""
             mdbname = ""
             mdbcols = 0
             Text1.Text = ""
             datain_conn.Close
             MsgBox "导入完成", vbOKOnly, "数据导入完成"
             Exit Sub
          End If
Case Is > 6
         If Text1.Text = "" Then
            MsgBox "请选择*.xls数据", vbOKOnly, "数据导入操作"
            Exit Sub
           Else
               'mdbname = dhfrm.List1.list(dhfrm.List1.ListIndex)
               'Dim rdst3 As New ADODB.Recordset
                   rdst3.Open "select * from tablename where fid = " & dhfrm.List1.ListIndex + 1 & "", g_conn
                   mdbname = rdst3!表名
                   mdbcols = rdst3!列数
                'CommonDialog1.Flags = cdlOFNAllowMultiselect  单选多选
                '连接*.xls文件
                datain_conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & xlsname & ""
                '打开*.xls文件
             '   Dim rdst As New ADODB.Recordset
                rdst.Open "select * from [a$]", datain_conn
                '循环xls数据表,进行逐行添加
              Do While Not rdst.EOF
               '     Dim ardst As New ADODB.Recordset
                      ardst.Open "select * from " & mdbname & " where 区='" & rdst.Fields(1).Value & "'and 序号='" & rdst.Fields(2).Value & "'", g_conn
               If ardst.EOF = True Then
                    'Dim i As Integer
                  '  Dim xlsvalue As String
                    xlsvalue = ""
                    For i = 1 To mdbcols
                       If IsNull(rdst.Fields(i - 1).Value) = True Then
                          xlsvalue = xlsvalue & "'0'" & ","
                       Else
                          xlsvalue = xlsvalue & "'" & rdst.Fields(i - 1).Value & "'" & ","
                       End If
                    Next i
                    xlsvalue = Left(xlsvalue, Len(xlsvalue) - 1)
                   Debug.Print xlsvalue
                   '打开mdb进行追加
               '     Dim rdst2 As New ADODB.Recordset
                    rdst2.Open "insert into " & mdbname & " values(" & xlsvalue & ")", g_conn
                  Else
                '     Dim ts As String
                     ts = MsgBox("导入相同记录,确定覆盖,取消跳过", vbOKCancel, "记录重复")
                      If ts = vbOK Then
                '        Dim dr As New ADODB.Recordset
                          dr.Open "delete * from " & mdbname & " where 区='" & rdst.Fields(1).Value & "'and 序号='" & rdst.Fields(2).Value & "'", g_conn
                        Set dr = Nothing
                                   xlsvalue = ""
                                     For i = 1 To mdbcols
                                        If IsNull(rdst.Fields(i - 1).Value) = True Then
                                           xlsvalue = xlsvalue & "'0'" & ","
                                        Else
                                           xlsvalue = xlsvalue & "'" & rdst.Fields(i - 1).Value & "'" & ","
                                        End If
                                     Next i
                                     xlsvalue = Left(xlsvalue, Len(xlsvalue) - 1)
                                    '打开mdb进行追加
                                     rdst2.Open "insert into " & mdbname & " values(" & xlsvalue & ")", g_conn
                         Else
                           MsgBox "跳过" & rdst.Fields(2).Value & rdst.Fields(4).Value, vbOKOnly, "跳过记录"
                         End If
                    End If
                    Set ardst = Nothing
                    rdst.MoveNext
                Loop
                 killmore (mdbname)
             Set rdst = Nothing
             Set rdst2 = Nothing
             Set rdst3 = Nothing
             xlsname = ""
             mdbname = ""
             mdbcols = 0
             Text1.Text = ""
             datain_conn.Close
             MsgBox "导入完成", vbOKOnly, "数据导入完成"
             Exit Sub
          End If
End Select
'err1:
   '  MsgBox "数据错误,请检查xls文件", vbOKOnly, "数据导入操作"
End Sub
Private Sub Command2_Click()
'清空导入xls数据
On Error GoTo err1:
            If Text1.Text = "" Then
               MsgBox "请选择*.xls数据", vbOKOnly, "数据导入操作"
               Exit Sub
           Else
               'mdbname = dhfrm.List1.list(dhfrm.List1.ListIndex)
               Dim rdst3 As New ADODB.Recordset
               rdst3.Open "select * from tablename where fid = " & dhfrm.List1.ListIndex + 1 & "", g_conn
                    mdbname = rdst3!表名
                    mdbcols = rdst3!列数
              Dim rdst4 As New ADODB.Recordset
                '清空数据库
                rdst4.Open "delete * from " & mdbname & "", g_conn
                 ' CommonDialog1.Flags = cdlOFNAllowMultiselect  单选多选
                '连接*.xls文件
                datain_conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & xlsname & ""
                '打开*.xls文件
              Dim rdst As New ADODB.Recordset
                rdst.Open "select * from [a$]", datain_conn
                '循环xls数据表,进行逐行添加
              Do While Not rdst.EOF
                   Dim i As Integer
                   Dim xlsvalue As String
                   xlsvalue = ""
                   For i = 1 To mdbcols
                       If IsNull(rdst.Fields(i - 1).Value) = True Then
                          xlsvalue = xlsvalue & "'0'" & ","
                       Else
                          xlsvalue = xlsvalue & "'" & rdst.Fields(i - 1).Value & "'" & ","
                       End If
                   Next i
                 
                    xlsvalue = Left(xlsvalue, Len(xlsvalue) - 1)
                    Debug.Print xlsvalue
                  '打开mdb进行追加
                    Dim rdst2 As New ADODB.Recordset
                    rdst2.Open "insert into " & mdbname & " values(" & xlsvalue & ")", g_conn
                    rdst.MoveNext
                Loop
             '清空多余数据
             killmore (mdbname)
             '释放rdst记录
             Set rdst = Nothing
             Set rdst2 = Nothing
             Set rdst3 = Nothing
             Set rdst4 = Nothing
             xlsname = ""
             mdbname = ""
             mdbcols = 0
             Text1.Text = ""
             datain_conn.Close
             MsgBox "导入完成", vbOKOnly, "数据导入完成"
             Exit Sub
          End If
err1:
    MsgBox "数据错误,请检查xls文件", vbOKOnly, "数据导入操作"
End Sub

Private Sub Command3_Click()
        Unload Me
End Sub

Private Sub Command4_Click()
     CommonDialog1.Filter = "*.xls|*.xls"
     CommonDialog1.ShowOpen
        '获得*.xls文件
     xlsname = CommonDialog1.filename
     Text1.Text = xlsname
End Sub
Private Sub Command5_Click()
'覆盖导入的时候对表的判断
'①1-6表用村和序号来判断
'②7表用区和序号来判断
'③8-11表用区和序号来判断
On Error GoTo err1:
   Select Case dhfrm.List1.ListIndex
        Case Is < 6
                    If Text1.Text = "" Then
                            MsgBox "请选择*.xls数据", vbOKOnly, "数据导入操作"
                            Exit Sub
                    Else
                            'mdbname = dhfrm.List1.list(dhfrm.List1.ListIndex)
                            Dim rdst3 As New ADODB.Recordset
                            rdst3.Open "select * from tablename where fid = " & dhfrm.List1.ListIndex + 1 & "", g_conn
                            mdbname = rdst3!表名
                            mdbcols = rdst3!列数
                           'CommonDialog1.Flags = cdlOFNAllowMultiselect  单选多选
                           '连接*.xls文件
                            datain_conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & xlsname & ""
                            '打开*.xls文件
                            Dim rdst As New ADODB.Recordset
                            rdst.Open "select * from [a$]", datain_conn