frmsetup.frm

收银机库存销售管理程序

    Call MacButton("   Save", frmSetup.cmdSave, 0, 0, 73, 50, frmLogin.Source, 0, 0, 1)
    Call MacButton("   Undo", frmSetup.cmdUndo, 0, 0, 73, 50, frmLogin.Source, 0, 0, 1)
    Call MacButton("    Exit", frmSetup.cmdExit, 0, 0, 73, 50, frmLogin.Source, 0, 0, 1)
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    On Error Resume Next
    Dim AltDown
    AltDown = (Shift And vbAltMask) > 0
    Select Case KeyCode
        Case vbKeyEscape:
                Me.Hide
        Case vbKeyL:
                If AltDown Then
                    Call MacButton("      Change Logo", frmSetup.cmdPicture, 0, 0, 170, 30, frmLogin.Source, 147, 0, 2)
                End If
        Case vbKeyE:
                If AltDown Then
                    Call MacButton("    Edit", frmSetup.cmdEdit, 0, 0, 73, 50, frmLogin.Source, 0, 0, 1)
                End If
        Case vbKeyS:
                If AltDown Then
                    Call MacButton("   Save", frmSetup.cmdSave, 0, 0, 73, 50, frmLogin.Source, 0, 0, 1)
                End If
        Case vbKeyU:
                If AltDown Then
                    Call MacButton("   Undo", frmSetup.cmdUndo, 0, 0, 73, 50, frmLogin.Source, 0, 0, 1)
                End If
        Case vbKeyX:
                If AltDown Then
                    Call MacButton("    Exit", frmSetup.cmdExit, 0, 0, 73, 50, frmLogin.Source, 0, 0, 1)
                End If
    End Select
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    On Error Resume Next
    Dim AltDown
    AltDown = (Shift And vbAltMask) > 0
    Select Case KeyCode
        Case vbKeyEscape:
                Me.Hide
        Case vbKeyF1:
                frmHelp.Show
                frmHelp.Help_Values = Space(1) & vbCrLf & _
                                      "Note: The following are Software Setup Key Shortcuts." & vbCrLf & _
                                      Space(1) & vbCrLf & _
                                      "ALT-E=Edit, ALT-S=Save, ALT-U=Undo, ALT-X=Exit" & vbCrLf & _
                                      "ALT-L=Change Logo"
        Case vbKeyL:
                If AltDown Then
                    Call MacButton("      Change Logo", frmSetup.cmdPicture, 0, 0, 170, 30, frmLogin.Source, 182, 30, 2)
                    cmdPicture_Click
                End If
        Case vbKeyE:
                If AltDown Then
                    Call MacButton("    Edit", frmSetup.cmdEdit, 0, 0, 73, 50, frmLogin.Source, 74, 0, 1)
                    cmdEdit_Click
                End If
        Case vbKeyS:
                If AltDown Then
                    Call MacButton("   Save", frmSetup.cmdSave, 0, 0, 73, 50, frmLogin.Source, 74, 0, 1)
                    cmdSave_Click
                End If
        Case vbKeyU:
                If AltDown Then
                    Call MacButton("   Undo", frmSetup.cmdUndo, 0, 0, 73, 50, frmLogin.Source, 74, 0, 1)
                    cmdUndo_Click
                End If
        Case vbKeyX:
                If AltDown Then
                    Call MacButton("    Exit", frmSetup.cmdExit, 0, 0, 73, 50, frmLogin.Source, 74, 0, 1)
                    cmdExit_Click
                End If
    End Select
End Sub

Private Sub titleBar_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call DragForm(Me)
End Sub

Private Sub Closed_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call BitBlt(frmSetup.Closed.hDC, 0, 0, 73, 50, frmLogin.Source.hDC, 18, 107, SRCCOPY)
    frmSetup.Closed.Refresh
End Sub

Private Sub Closed_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call BitBlt(frmSetup.Closed.hDC, 0, 0, 73, 50, frmLogin.Source.hDC, 0, 107, SRCCOPY)
    frmSetup.Closed.Refresh
End Sub

Private Sub Maximized_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call BitBlt(frmSetup.Maximized.hDC, 0, 0, 73, 50, frmLogin.Source.hDC, 18, 72, SRCCOPY)
    frmSetup.Maximized.Refresh
End Sub

Private Sub Maximized_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call BitBlt(frmSetup.Maximized.hDC, 0, 0, 73, 50, frmLogin.Source.hDC, 0, 72, SRCCOPY)
    frmSetup.Maximized.Refresh
End Sub

Private Sub Minimized_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call BitBlt(frmSetup.Minimized.hDC, 0, 0, 73, 50, frmLogin.Source.hDC, 18, 124, SRCCOPY)
    frmSetup.Minimized.Refresh
End Sub

Private Sub Minimized_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call BitBlt(frmSetup.Minimized.hDC, 0, 0, 73, 50, frmLogin.Source.hDC, 0, 124, SRCCOPY)
    frmSetup.Minimized.Refresh
End Sub

Private Sub Display_Fields()
    On Error Resume Next
    If datprimary.AbsolutePosition <> -1 Then
        txtField(0) = IIf(IsNull(datprimary("COMPANY_NAME")), "", datprimary("COMPANY_NAME"))
        txtField(1) = IIf(IsNull(datprimary("COMPANY_ADDRESS")), "", datprimary("COMPANY_ADDRESS"))
        txtField(2) = IIf(IsNull(datprimary("COMPANY_TELEPHONE")), "", datprimary("COMPANY_TELEPHONE"))
        txtCheck(0).Value = IIf(IsNull(datprimary("OPTION_ALAS")), 0, IIf(datprimary("OPTION_ALAS") = 0, 0, 1))
        txtCheck(1).Value = IIf(IsNull(datprimary("OPTION_HWT")), 0, IIf(datprimary("OPTION_HWT") = 0, 0, 1))
        txtCheck(2).Value = IIf(IsNull(datprimary("OPTION_HDI")), 0, IIf(datprimary("OPTION_HDI") = 0, 0, 1))
        txtCheck(3).Value = IIf(IsNull(datprimary("OPTION_E3DT")), 0, IIf(datprimary("OPTION_E3DT") = 0, 0, 1))
        txtCheck(4).Value = IIf(IsNull(datprimary("OPTION_DRCM")), 0, IIf(datprimary("OPTION_DRCM") = 0, 0, 1))
        txtCheck(5).Value = IIf(IsNull(datprimary("OPTION_DCADATS")), 0, IIf(datprimary("OPTION_DCADATS") = 0, 0, 1))
        txtCheck(6).Value = IIf(IsNull(datprimary("OPTION_DPW")), 0, IIf(datprimary("OPTION_DPW") = 0, 0, 1))
        txtField(3) = IIf(IsNull(datprimary("COMPANY_EXPIRYCOUNT")), "0", datprimary("COMPANY_EXPIRYCOUNT"))
        DatePick(0).Value = IIf(IsDate(datprimary("COMPANY_EXPIRYDATE")), datprimary("COMPANY_EXPIRYDATE"), Date)
        DatePick(1).Value = IIf(IsDate(datprimary("SELLING_CLEANUPDATE")), datprimary("SELLING_CLEANUPDATE"), Date)
        txtField(4) = IIf(IsNull(datprimary("SELLING_HEADER")), "", datprimary("SELLING_HEADER"))
        txtField(5) = IIf(IsNull(datprimary("SELLING_FOOTER")), "", datprimary("SELLING_FOOTER"))
        Call ResetLogo(Logo)
        Call DisplayLogo(datprimary("COMPANY_LOGO"))
    Else
        Clear_Fields
    End If
End Sub

Private Sub Clear_Fields()
    For i = 0 To 5
        txtField(i) = ""
    Next i
    For i = 0 To 6
        txtCheck(i) = 0
    Next i
End Sub

Private Sub Update_Fields(isNew As Boolean)
    On Error Resume Next
    Dim SaveToPicture
    datprimary.Edit
    datprimary("COMPANY_NAME") = txtField(0)
    datprimary("COMPANY_ADDRESS") = txtField(1)
    datprimary("COMPANY_TELEPHONE") = txtField(2)
    datprimary("OPTION_ALAS") = IIf(txtCheck(0).Value = 0, 0, -1)
    datprimary("OPTION_HWT") = IIf(txtCheck(1).Value = 0, 0, -1)
    datprimary("OPTION_HDI") = IIf(txtCheck(2).Value = 0, 0, -1)
    datprimary("OPTION_E3DT") = IIf(txtCheck(3).Value = 0, 0, -1)
    datprimary("OPTION_DRCM") = IIf(txtCheck(4).Value = 0, 0, -1)
    datprimary("OPTION_DCADATS") = IIf(txtCheck(5).Value = 0, 0, -1)
    datprimary("OPTION_DPW") = IIf(txtCheck(6).Value = 0, 0, -1)
    datprimary("COMPANY_EXPIRYCOUNT") = IIf(txtField(3) = "", 0, txtField(3))
    datprimary("COMPANY_EXPIRYDATE") = DatePick(0).Value
    datprimary("SELLING_CLEANUPDATE") = DatePick(1).Value
    datprimary("SELLING_HEADER") = txtField(4)
    datprimary("SELLING_FOOTER") = txtField(5)
    SaveToPicture = CopyFileToField(cdlPicture.filename, datprimary("COMPANY_LOGO"))
    datprimary.Update
End Sub

Private Sub Enable_Fields(isLock As Boolean)
    On Error Resume Next
    For i = 0 To 5
        txtField(i).Enabled = Not isLock
    Next i
    For i = 0 To 6
        txtCheck(i).Enabled = Not isLock
    Next i
    For i = 0 To 1
        DatePick(i).Enabled = Not isLock
    Next i
    Object_Tab_Trigger (Not isLock)
End Sub

Public Sub Press_Buttons(p_type As String)
    On Error Resume Next
    Select Case p_type
            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
    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
    cmdEdit.Enabled = p_edit
    cmdSave.Enabled = p_save
    cmdUndo.Enabled = p_undo
    cmdExit.Enabled = Not cmdSave.Enabled
End Sub
                            
Private Sub Object_Tab_Trigger(isTab As Boolean)
    On Error Resume Next
    For i = 0 To 5
        txtField(i).TabStop = isTab
    Next i
    For i = 0 To 1
        DatePick(i).TabStop = isTab
    Next i
    For i = 0 To 6
        txtCheck(i).TabStop = isTab
    Next i
End Sub

Function DisplayLogo(xField As 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.FieldSize
            Chunks = lngTotalSize \ ChunkSize
            Fragment = lngTotalSize Mod ChunkSize
        ReDim Chunk(ChunkSize)
            Chunk() = xField.GetChunk(lngOffset, ChunkSize)
        Put DataFile, , Chunk()
            lngOffset = lngOffset + ChunkSize
        Do While lngOffset < lngTotalSize
            Chunk() = xField.GetChunk(lngOffset, ChunkSize)
            Put DataFile, , Chunk()
            lngOffset = lngOffset + ChunkSize
        Loop
        Close DataFile
        filename = MediaTemp
        Logo = LoadPicture(filename)
    End If
End Function

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