frmioorder.frm

这个是VB环境开发的,我也是转载的把原来的Access数据库改成了SQl Server数据库.希望大家可以借鉴

    If txtfilename <> "" Then
       Dim FileNumber As Integer
       Dim col As String
       Dim lStr As String
       Dim LStr1 As String
       Dim OldSave As String
       Dim i As Integer
       Dim OldDate As String
       i = i + 1
       OneLIne = 0
       FileNumber = FreeFile
       Open txtfilename For Input As #FileNumber
            Line Input #FileNumber, lStr
            Do While Not EOF(FileNumber)
            DoEvents
            Line Input #FileNumber, LStr1
            ReDate = test(LStr1)
            '对数据操作
            RsE.Filter = "etype='" & Trim(strcol(1)) & "'and ename='" & Trim(strcol(0)) & "'"
            If Not (RsE.EOF Or RsE.BOF) Then
               lblprod = RsE!ID
            Else
               IAdd = RsE.RecordCount
               RsE.AddNew
               RsE!ID = IAdd + 1
               RsE!ename = strcol(0)
               If Trim(RsE!ename) = "" Then
                frmioorder.Caption = OldCaption
                Toolbar1.Enabled = True
                Screen.MousePointer = vbDefault
                MsgBox "    数据导入成功！ ", , ginfo
                Exit Sub
               End If
               RsE!Estandard = strcol(4)
               RsE!etype = strcol(1)
               If Trim(RsE!etype) = "" Or Trim(RsE!ename) = "" Then
                   Call Toolbarsave
                   Toolbar1.Enabled = True
                   Screen.MousePointer = vbDefault
               End If
               If strcol(6) <> "" Then
                  RsE!eunit = strcol(6) & ""
               Else
                  RsE!eunit = "个"
               End If
               RsE.UpdateBatch adAffectCurrent
               RsE.Requery
               lblprod = RsE!ID
            End If
            IAdd = RsIO.RecordCount
            RsIO.AddNew
            RsIO!ID = IAdd + 1
            RsIO!ioid = txtid
            RsIO!bh = lblprod
            'RsIO!price = Val(strcol(4))
            RsIO!amount = Val(strcol(2))
            RsIO!Memo = strcol(7)
            If strcol(5) <> "" Then
                RsIO!Flg = strcol(5)
            Else
               RsIO!Flg = "半成品"
            End If
            RsIO.UpdateBatch adAffectCurrent
            RsIO.Requery
            FIO.Filter = "id=" & txtid
            FIO.Requery
            Set dtgrd.DataSource = FIO
        Loop
        MsgBox "    数据导入成功！ ", , ginfo
     End If
      dlg.Filename = ""
      frmioorder.Caption = OldCaption
      Toolbar1.Enabled = True
     Screen.MousePointer = vbDefault
     Exit Sub
l: MsgBox err.Description
     frmioorder.Caption = OldCaption
     Toolbar1.Enabled = True
     Screen.MousePointer = vbDefault
   Exit Sub
End Sub
Private Sub xslopen(Filename)
    Dim exlapp As Object
    Dim Exlsheet As Object
    Dim i As Integer
    Dim row As Integer
    Dim colstr(7) As String
    Set exlapp = CreateObject("excel.application")
    exlapp.Workbooks.Open Filename:=Filename
    Set Exlsheet = exlapp.ActiveSheet
    i = 1: row = 2
    Do
        For i = 1 To 8
            colstr(i) = Exlsheet.Cells(row, i)
            If Trim(colstr(i)) = 0 Then Exit Do
        Next
        row = row + 1
    Loop
    Exlsheet.Close
    exlapp.Quit
    Set Exlsheet = nohing
    Set exlapp = noting
End Sub
Private Function test(lStr As String) As String
    On Error GoTo suberror
    Dim col As Integer
    Dim i As Integer
    For i = 0 To 7
    col = InStr(lStr, vbTab)
    If col = 0 Then
         strcol(i) = Left(lStr, Len(lStr))
         test = strcol(3)
         Exit Function
    Else
         strcol(i) = Left(lStr, col - 1)
         lStr = Right(lStr, Len(lStr) - col)
    End If
    Next
    test = strcol(3)
    Exit Function
suberror:
    MsgBox "读取文件失败，请检查文件格式是否正确后，重试！", vbOKOnly, "抱歉"
    End
End Function
Private Sub cmbPT_KeyPress(KeyAscii As Integer)
    KeyAscii = 0
End Sub

Private Sub CMDADDDTL_Click()
On Error GoTo err
    Dim IAdd As Integer
    If Len(txtamount) = 0 Or Len(txtProd) = 0 Then
        MsgBox " 数据不完整，请检查！", , ginfo
        Exit Sub
    End If
    IAdd = RsIO.RecordCount
    RsIO.AddNew
    RsIO!ID = IAdd + 1
    RsIO!ioid = Val(txtid)
    RsIO!bh = lblprod
   If cmbPT.Text <> "成品" Then
    RsIO!Flg = 0
    Else
    RsIO!Flg = 1
    End If
    If Trim(txtPrice) <> "" Then RsIO!price = Val(txtPrice)
    RsIO!amount = Val(txtamount)
    RsIO.UpdateBatch adAffectCurrent
    RsIO.Requery
    If cmbPT.Text <> "成品" Then
        FIO.Filter = "id=" & txtid
        FIO.Requery
        dtgrd.Visible = True
        Set dtgrd.DataSource = FIO
        txtcompname = ""
    Else
        FioP.Filter = "id=" & txtid    '对成品做处理
        FioP.Requery
        dtgrd.Visible = False
        Set dtgrd1.DataSource = FioP
    End If
    txtPrice = ""
    txtamount = ""
    txtProd = ""
    txttype = ""
    Exit Sub
err: MsgBox err.Description
End Sub

Private Sub Command1_Click()
    frmcompany.CmdInsert.Visible = True
    frmcompany.InsertType = "FRMIOorder"
    frmcompany.Show

End Sub

Private Sub Command2_Click()
 
    If cmbPT.Text <> "成品" Then
        frmelement.InsertType = "FRMIOorder"
        frmelement.Show
    Else
         frmPinfo.InsertType = "FRMIOorder"
        frmPinfo.Show
    End If
End Sub

Private Sub Command3_Click()
On Error GoTo l
     If dtgrd.row <> -1 Then
        RsIO.Find "id=" & dtgrd.Columns(5).Text
        If Not RsIO.BOF Or Not RsIO.EOF Then
             If Trim(txtPrice) <> "" Then RsIO!price = txtPrice
             RsIO!amount = txtamount
             RsIO!Flg = cmbPT
             RsIO!bh = lblprod
             RsIO.UpdateBatch adAffectCurrent
             RsIO.Requery
             FIO.Requery
        End If
    End If
    Exit Sub
l:    MsgBox err.Description
End Sub

Private Sub Command4_Click()

On Error GoTo l
    Dim txtfilename As String
    Dim OldCaption As String
    Dim IAdd As Integer
    OldCaption = Format(Now, "yyyy-mm-dd")
    If Format(dtptime.Value, "yyyy-mm-dd") = OldCaption Then
       MsgBox "  请选择导入历史数据的入库时间！ ", , ginfo
       Exit Sub
    End If
    dlg.InitDir = App.Path & "\data"
    dlg.ShowOpen
    txtfilename = dlg.Filename
    Toolbar1.Enabled = False
    If txtfilename <> "" Then
       Dim FileNumber As Integer
       Dim col As String
       Dim lStr As String
       Dim LStr1 As String
       Dim OldSave As String
       Dim i As Integer
       Dim OldDate As String
       Dim OneLIne As Integer
       Dim ReDate As String
       i = i + 1
       OneLIne = 0
       Screen.MousePointer = 11
       Frame1.MousePointer = 11
       frmio.MousePointer = 11
       FileNumber = FreeFile
            Open txtfilename For Input As #FileNumber
            Line Input #FileNumber, lStr
            
            Do While Not EOF(FileNumber)
            Screen.MousePointer = 11
            Frame1.MousePointer = 11
            frmio.MousePointer = 11
            
            Command4.MousePointer = 11
            DoEvents
            Line Input #FileNumber, LStr1
            ReDate = test(LStr1)
            If Trim(strcol(0)) = "" Then ' 可以取值 val =0
               GoTo nextline
            End If
     If Format(ReDate, "yyyy-mm-dd") = Format(dtptime.Value, "yyyy-mm-dd") Or Trim(ReDate) = "" Then
'以下导入是对元件导入

MarkD:
    If cmbPT.Text <> "成品" Then
        RsE.Filter = "etype='" & Trim(strcol(1)) & "'and ename='" & Trim(strcol(0)) & "'"
            If Not (RsE.EOF Or RsE.BOF) Then
               lblprod = RsE!ID
            Else
               RsE.Filter = ""
               RsE.Requery
               IAdd = RsE.RecordCount
               RsE.AddNew
               RsE!ID = IAdd + 1
               RsE!ename = strcol(0)
               RsE!Estandard = strcol(4)
               RsE!etype = strcol(1)

               If Trim(strcol(6)) <> "" Then
                   RsE!eunit = strcol(6) & ""
               Else
                   RsE!eunit = "个"
               End If
               RsE.UpdateBatch adAffectCurrent
               lblprod = RsE!ID
               RsE.Requery
            End If
Else '成品导入
           
       RsP.Filter = "ptype='" & Trim(strcol(1)) & "'and pname='" & Trim(strcol(0)) & "'"
            If Not (RsP.EOF Or RsP.BOF) Then
               lblprod = RsP!ID
            Else
               RsP.Filter = ""
               RsP.Requery
               IAdd = RsP.RecordCount
               RsP.AddNew
               RsP!ID = IAdd + 1
               RsP!pname = strcol(0)
               RsP!pstardard = strcol(4)
               RsP!ptype = strcol(1)

               If Trim(strcol(6)) <> "" Then
                   RsP!Punit = strcol(6) & ""
               Else
                   RsP!Punit = "个"
               End If
               RsP.UpdateBatch adAffectCurrent
               lblprod = RsP!ID
               RsP.Requery
            End If

End If
            'RsE.Requery
            IAdd = RsIO.RecordCount
            RsIO.AddNew
            RsIO!ID = IAdd + 1
            RsIO!ioid = txtid
            RsIO!bh = lblprod
            'RsIO!price = Val(strcol(4))
            RsIO!amount = Val(strcol(2))
            RsIO!Memo = strcol(7)
            If strcol(5) <> "" Then
                RsIO!Flg = strcol(5)
            Else
               RsIO!Flg = cmbPT.Text ''半成品
            End If
            RsIO.UpdateBatch adAffectCurrent
            RsIO.Requery
            FIO.Filter = "id=" & txtid
            FIO.Requery
            Set dtgrd.DataSource = FIO
     Else
        Call Toolbarsave
        Call Toolbarnew
        dtptime.Value = Format(ReDate, "yyyy-mm-dd")
       GoTo MarkD
     End If
nextline:     Loop

     MsgBox "    数据导入成功！ ", , ginfo
     Call Toolbarsave
     Toolbar1.Enabled = True
     Screen.MousePointer = vbDefault
      Frame1.MousePointer = vbDefault
       frmio.MousePointer = vbDefault
    End If
     dlg.Filename = ""
     Exit Sub
l: MsgBox err.Description  ' " 可能是导入历史数据的最初日期错误，请检查！"
     Toolbar1.Enabled = True
     Screen.MousePointer = vbDefault
   Exit Sub
End Sub
'               If Trim(RsE!etype) = "" Or Trim(RsE!ename) = "" Then  'or ?
'                   Call Toolbarsave
'                   Call Toolbarnew
'                   dtptime.Value = Format(ReDate, "yyyy-mm-dd")
'                    Toolbar1.Enabled = True
'                    Screen.MousePointer = vbDefault
'                    GoTo MarkD
'               Exit Sub
'               End If

Private Sub dtcmb_KeyPress(KeyAscii As Integer)
   KeyAscii = 0
End Sub

Private Sub dtgrd_Click()
On Error GoTo l
    If dtgrd.row <> -1 Or dtgrd1.row <> -1 Then
        Command3.Enabled = True
        If cmbPT.Text <> "成品" Then
            txtcompname = FIO!Memo & ""
            txtProd = FIO!ename
            txtPrice = FIO!price
            txtamount = FIO!amount