frmprod.frm

Visual basic 数据库编程技术与实例源码 源码

        txtField(1) = IIf(IsNull(datprimary("PRODCODE")), "", datprimary("PRODCODE"))
        txtField(7) = IIf(IsNull(datprimary("GENERICNAME")), "", datprimary("GENERICNAME"))
        txtField(2) = IIf(IsNull(datprimary("PRODDES")), "", datprimary("PRODDES"))
        txtCombo(0) = IIf(IsNull(datprimary("CATCODE")), "", datprimary("CATCODE"))
        txtField(3) = IIf(IsNull(datprimary("UNIT_COST")), "0", datprimary("UNIT_COST"))
        txtField(4) = IIf(IsNull(datprimary("SELLING_PRICE")), "0", datprimary("SELLING_PRICE"))
        txtField(5) = IIf(IsNull(datprimary("QUAN")), "0", datprimary("QUAN"))
        txtField(0) = IIf(IsNull(datprimary("REORDER")), "0", datprimary("REORDER"))
        txtCombo(1) = IIf(IsNull(datprimary("SUPCODE")), "", datprimary("SUPCODE"))
        DatePick.Value = IIf(IsDate(datprimary("PDATE")), datprimary("PDATE"), Date)
        Call ResetPicture(Photo)
        Call DisplayPicture(datprimary("PICTURE"))
    Else
        Clear_Fields
    End If
        txtField(3) = Convert_Numeric(txtField(3), True)
        txtField(4) = Convert_Numeric(txtField(4), True)
        txtField(5) = Convert_Numeric(txtField(5), False)
        txtField(0) = Convert_Numeric(txtField(0), False)
        txtField(6) = Convert_Numeric(CDbl(txtField(3)) * CDbl(txtField(5)), True)
End Sub

Private Sub Clear_Fields()
    ' ENABLE ONLY TO BLANK FIELD txtField(1)
    'txtField(1) = ""
    txtField(7) = ""
    txtField(2) = ""
    txtField(3) = "0"
    txtField(4) = "0"
    txtField(5) = "0"
    txtField(0) = "0"
    txtField(6) = "0"
End Sub


Private Sub Update_Fields(isNew As Boolean)
    On Error Resume Next
    Dim SaveToPicture
    If isNew Then
        datprimary.AddNew
        datprimary("PRODCODE") = txtField(1)
        datprimary("GENERICNAME") = txtField(7)
        datprimary("PRODDES") = txtField(2)
        datprimary("CATCODE") = txtCombo(0)
        datprimary("UNIT_COST") = IIf(txtField(3) = "", 0, txtField(3))
        datprimary("SELLING_PRICE") = IIf(txtField(4) = "", 0, txtField(4))
        datprimary("QUAN") = IIf(txtField(5) = "", 0, txtField(5))
        datprimary("REORDER") = IIf(txtField(0) = "", 0, txtField(0))
        datprimary("SUPCODE") = txtCombo(1)
        datprimary("PDATE") = DatePick.Value
        SaveToPicture = CopyFileToField(cdlPicture.filename, datprimary("PICTURE"))
        datprimary.Update
    Else
        datprimary("PRODCODE") = txtField(1)
        datprimary("GENERICNAME") = txtField(7)
        datprimary("PRODDES") = txtField(2)
        datprimary("CATCODE") = txtCombo(0)
        datprimary("UNIT_COST") = IIf(txtField(3) = "", 0, txtField(3))
        datprimary("SELLING_PRICE") = IIf(txtField(4) = "", 0, txtField(4))
        datprimary("QUAN") = IIf(txtField(5) = "", 0, txtField(5))
        datprimary("REORDER") = IIf(txtField(0) = "", 0, txtField(0))
        datprimary("SUPCODE") = txtCombo(1)
        datprimary("PDATE") = DatePick.Value
        SaveToPicture = CopyFileToField(cdlPicture.filename, datprimary("PICTURE"))
        datprimary.Update
    End If
    If isNew Then datprimary.MoveLast
End Sub

Private Sub Enable_Fields(isLock As Boolean)
    On Error Resume Next
    For i = 0 To 7
        txtField(i).Enabled = Not isLock
    Next i
        txtCombo(0).Enabled = Not isLock
        txtCombo(1).Enabled = Not isLock
        DatePick.Enabled = Not isLock
    If p_isadding Then
        txtField(1).Locked = isLock
        txtField(1).TabStop = True
    End If
        Object_Tab_Trigger (Not isLock)
End Sub

Public Sub Press_Buttons(p_type As String)
    On Error Resume Next
    Select Case p_type
            Case "New"
                Clear_Fields
                p_save = True
                p_isadding = True
            Case "Edit"
                p_isediting = True
                p_save = True
                p_isadding = False
            Case "Save"
                Update_Fields (p_isadding)
                p_save = False
                p_isadding = False
                p_isediting = False
            Case "Undo"
                p_save = False
                p_isadding = False
                p_isediting = False
            Case "Top"
                p_save = False
                p_isadding = False
                p_isediting = False
                datprimary.MoveFirst
            Case "Prev"
                p_save = False
                p_isadding = False
                p_isediting = False
                datprimary.MovePrevious
            Case "Next"
                p_save = False
                p_isadding = False
                p_isediting = False
                datprimary.MoveNext
            Case "Last"
                p_save = False
                p_isadding = False
                p_isediting = False
                datprimary.MoveLast
            Case "Delete"
                p_save = False
                p_isadding = False
                p_isediting = False
                p_isdeleting = True
                p_isnavigate = False
                With datprimary
                    .Delete
                    .MoveNext
                    p_isnavigate = True
                    If .RecordCount > 0 And .EOF Then .MoveLast
                End With
    End Select
    Enable_Fields (Not p_save)
    Enable_Buttons
    If Not p_isadding Then Display_Fields
End Sub

Private Sub Enable_Buttons()
    On Error Resume Next
    Dim cur_rec, fst_rec, lst_rec, rec_cnt As Integer
    Dim mark_rec As Variant
    rec_cnt = datprimary.RecordCount
    If rec_cnt > 0 Then
        If Not datprimary.BOF Or Not datprimary.EOF Then
            cur_rec = datprimary.AbsolutePosition + 1
            mark_rec = datprimary.Bookmark
        End If
        datprimary.MoveFirst
        fst_rec = datprimary.AbsolutePosition + 1
        datprimary.MoveLast
        lst_rec = datprimary.AbsolutePosition + 1
        If Not datprimary.BOF Or Not datprimary.EOF Then
            datprimary.Bookmark = mark_rec
        End If
        If fst_rec = cur_rec Then
            p_top = False
            p_prev = False
            p_next = True
            p_last = True
        End If
        If lst_rec = cur_rec Then
            p_top = True
            p_prev = True
            p_next = False
            p_last = False
        End If
        If (rec_cnt >= 0 And rec_cnt <= 1) Then
            p_top = False
            p_prev = False
            p_next = False
            p_last = False
        End If
        If cur_rec <> fst_rec And cur_rec <> lst_rec Then
            p_top = True
            p_prev = True
            p_next = True
            p_last = True
        End If
    End If
    If rec_cnt = 0 Then 'And Not p_isadding Then
        p_add = True
        p_edit = False
        p_undo = False
        p_top = False
        p_prev = False
        p_next = False
        p_last = False
        p_del = False
    End If
    If rec_cnt > 0 And (Not p_isediting And Not p_isadding) Then
        p_add = True
        p_edit = True
        p_del = True
    End If
    If Not p_isediting And Not p_isadding Then
        p_save = False
        p_undo = False
    Else
        p_save = True
        p_undo = True
        p_add = False
        p_edit = False
        p_top = False
        p_prev = False
        p_next = False
        p_last = False
        p_del = False
    End If
    cmdNew.Enabled = p_add
    cmdEdit.Enabled = p_edit
    cmdSave.Enabled = p_save
    cmdUndo.Enabled = p_undo
    cmdTop.Enabled = p_top
    cmdPrev.Enabled = p_prev
            cmdNext.Enabled = p_next
    cmdLast.Enabled = p_last
    cmdDel.Enabled = p_del
    If p_del Then
        cmdFind.Enabled = IIf(rec_cnt > 1, True, False)
    Else
        cmdFind.Enabled = False
    End If
        cmdExit.Enabled = Not cmdSave.Enabled
End Sub
                            
Private Sub txtField_KeyPress(Index As Integer, KeyAscii As Integer)
    On Error Resume Next
    If Index = 0 Or Index = 3 Or Index = 4 Or Index = 5 Then
        Select Case KeyAscii
                Case Asc("0") To Asc("9")
                Case Asc(".")
                    KeyAscii = IIf(Index = 5 Or Index = 1, 0, KeyAscii)
                Case KeyAscii = vbKeyBack
                Case Else
                    KeyAscii = 0
        End Select
    End If
End Sub

Private Sub txtField_LostFocus(Index As Integer)
    On Error Resume Next
    If Index = 3 Then txtField(3) = Convert_Numeric(txtField(3), True)
    If Index = 4 Then txtField(4) = Convert_Numeric(txtField(4), True)
    If Index = 0 Or Index = 5 Or Index = 3 Then
        txtField(5) = Convert_Numeric(txtField(5), False)
        txtField(0) = Convert_Numeric(txtField(0), False)
        txtField(6) = Convert_Numeric(CStr(CDbl(txtField(3)) * CDbl(txtField(5))), True)
    End If
End Sub

Private Sub Object_Tab_Trigger(isTab As Boolean)
    On Error Resume Next
    txtField(2).TabStop = isTab
    txtField(7).TabStop = isTab
    txtCombo(0).TabStop = isTab
    txtField(3).TabStop = isTab
    txtField(4).TabStop = isTab
    txtField(5).TabStop = isTab
    txtField(0).TabStop = isTab
    txtCombo(1).TabStop = isTab
    DatePick.TabStop = isTab
End Sub

Function Get_Product_Code() As Boolean
    On Error Resume Next
    strs = "select * from PROD_STOCKS where PRODCODE = '" & txtField(1) & "'"
    'Set dummy = frmLogin.db.OpenRecordset(strs)
    Set dummy = New adodb.Recordset
    dummy.Open strs, myDB, 1, 3
    

    If Not dummy.BOF Then

        Get_Product_Code = True
    Else
        Get_Product_Code = False
    End If
End Function

Function DisplayPicture(xField As adodb.Field)
    On Error Resume Next
    Dim DataFile As Integer, Fl As Long, Chunks As Integer
    Dim Fragment As Integer, Chunk() As Byte, i As Integer
    Const ChunkSize As Integer = 16384
    Dim MediaTemp As String
    Dim lngOffset As Long
    Dim lngTotalSize As Long
    Dim strChunk As String
    If Not IsNull(xField) Then
        MediaTemp = App.Path & "\TEMP\PICTURE.TMP"
        DataFile = 1
        Open MediaTemp For Binary Access Write As DataFile
        lngTotalSize = xField.ActualSize
        Chunks = lngTotalSize \ ChunkSize
        Fragment = lngTotalSize Mod ChunkSize
        ReDim Chunk(ChunkSize)
        
        For i = 1 To Chunks
        
            Chunk() = xField.GetChunk(ChunkSize)
            Put DataFile, , Chunk()
            DoEvents
        Next i
        ReDim Chunk(Fragment)
        Chunk() = xField.GetChunk(Fragment)
        Put DataFile, , Chunk()
        
'        lngOffset = lngOffset + ChunkSize
'        Do While lngOffset < lngTotalSize
'            Chunk() = xField.GetChunk(ChunkSize)
'            Put DataFile, , Chunk()
'            lngOffset = lngOffset + ChunkSize
'        Loop
        Close DataFile
        filename = MediaTemp
        Photo = LoadPicture(filename)
    End If
End Function

Function ResetPicture(xPicture As PictureBox)
    On Error Resume Next
    filename = ""
    xPicture.Picture = LoadPicture("")
    xPicture.Refresh
End Function