frmsetup.frm

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

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("      更改标志", 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