frmmain.frm

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

Public What_Rpt As String
Private Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long
Private Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Dim i, intDiskSize, intfreeKB, intUsedKB As Long
Dim nReturnValue, SectorsPerCluster, BytesPerSector As Long
Dim TotalClusters, FreeClusters As Long
'Dim pnlError As Panel
Dim sDriveLetter, sDrive As String
Dim fs, abc, dc As Integer
Private Const SR = 0
Private Const GDI = 1
Private Const USR = 2
Private Const VER_PLATFORM_WIN32s = 0
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32_NT = 2
Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion      As Long
    dwMinorVersion      As Long
    dwBuildNumber       As Long
    dwPlatformId        As Long
    szCSDVersion        As String * 128
End Type
Private Type MEMORYSTATUS
    dwLength        As Long
    dwMemoryLoad    As Long
    dwTotalPhys     As Long
    dwAvailPhys     As Long
    dwTotalPageFile As Long
    dwAvailPageFile As Long
    dwTotalVirtual  As Long
    dwAvailVirtual  As Long
End Type
Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)
Private Declare Function pBGetFreeSystemResources Lib "rsrc32.dll" Alias "_MyGetFreeSystemResources32@4" (ByVal iResType As Integer) As Integer
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private mIsWin32 As Boolean
Dim datprimary As adodb.Recordset
Dim datsecondary As adodb.Recordset
Dim datthirdary As adodb.Recordset


Private Sub Closed_Click()
    UnloadAllForms
End Sub

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

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

Private Sub cmdAbout_Click()
    frmAbout.Show
End Sub

Private Sub cmdAbout_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call MacButton("            About", frmMain.cmdAbout, 0, 0, 170, 30, frmLogin.Source, 182, 30, 2)
End Sub

Private Sub cmdAbout_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call MacButton("            About", frmMain.cmdAbout, 0, 0, 170, 30, frmLogin.Source, 147, 0, 2)
End Sub

Private Sub cmdChangeUser_Click()
    frmLogin.txtUserName = ""
    frmLogin.txtPassword = ""
    frmLogin.Show
    frmLogin.txtUserName.SetFocus
End Sub

Private Sub cmdChangeUser_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call MacButton("       Change User", frmMain.cmdChangeUser, 0, 0, 170, 30, frmLogin.Source, 182, 30, 2)
End Sub

Private Sub cmdChangeUser_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call MacButton("       Change User", frmMain.cmdChangeUser, 0, 0, 170, 30, frmLogin.Source, 147, 0, 2)
End Sub

Private Sub cmdShutdown_Click()
    'UnloadAllForms
    'Call DoExitWindows
    End
End Sub

Private Sub cmdShutdown_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call MacButton("         Shutdown", frmMain.cmdShutdown, 0, 0, 170, 30, frmLogin.Source, 182, 30, 2)
End Sub

Private Sub cmdShutdown_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call MacButton("         Shutdown", frmMain.cmdShutdown, 0, 0, 170, 30, frmLogin.Source, 147, 0, 2)
End Sub


Private Sub Form_Load()
Dim VolName As String, fSys As String
Dim Drive As String, DriveType As Long, erg As Long
Dim OSInfo As OSVERSIONINFO
    OSInfo.dwOSVersionInfoSize = Len(OSInfo)
    Call GetVersionEx(OSInfo)
    mIsWin32 = (OSInfo.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS)
    tmrUpdate_Timer
    tmrUpdate.Enabled = True
    sDriveLetter = "C:\"
    nReturnValue = GetDiskFreeSpace(sDriveLetter, SectorsPerCluster, BytesPerSector, FreeClusters, TotalClusters)
    If nReturnValue = "0" Then
        txtLabel = ""
        txtFsys = ""
        txtDriveType = ""
        txtFreeSpace = ""
        txtDiskSize = ""
        txtUsedKB = ""
    Else
        VolName = Space(127)
        fSys = Space(127)
        Drive = sDriveLetter
        DriveType& = GetDriveType(Drive$)
        txtLabel = VolName$
        txtFsys = fSys$
        Select Case DriveType
            Case 1:
                txtDriveType = "Unknown"
            Case 2:
                txtDriveType = "Removable"
            Case 3:
                txtDriveType = "Fixed"
            Case 4:
                txtDriveType = "Remote"
            Case 5:
                txtDriveType = "CD-Rom"
            Case 6:
                txtDriveType = "RAMdisk"
            Case Else:
                txtDriveType = "*ERROR*"
        End Select
        intDiskSize = SectorsPerCluster * BytesPerSector * (TotalClusters \ 1024) \ 1024
        intfreeKB = SectorsPerCluster * BytesPerSector * (FreeClusters \ 1024) \ 1024
        intUsedKB = intDiskSize - intfreeKB
        If intDiskSize > 1024 Then
           intDiskSize = Format((intDiskSize / 1024), "##,##0.00")
           lblTotal = "Gigabytes"
           lblTotal.Visible = True
        Else
           lblTotal = "MBytes"
           lblTotal.Visible = True
        End If
        
        If intfreeKB > 1024 Then
           intfreeKB = Format((intfreeKB / 1024), "##,##0.00")
           lblFree = "Gigabytes"
           lblFree.Visible = True
        Else
           lblFree = "MBytes"
           lblFree.Visible = True
        End If
        If intUsedKB > 1024 Then
           intUsedKB = Format((intUsedKB / 1024), "##,##0.00")
           lblUsed = "Gigabytes"
           lblUsed.Visible = True
         Else
           lblUsed = "MBytes"
           lblUsed.Visible = True
        End If
        txtUsedKB = intUsedKB
        txtFreeSpace = intfreeKB
        txtDiskSize = intDiskSize
    End If
    Call ColForm(BoxContainer, 217, 211, 213, 125)
    Call ColForm(MenuContainer, 217, 211, 213, 125)
    Call ColForm(Applets, 217, 211, 213, 125)
    Call CreateMacOSTitleBar(titleBar, " 迪迪POS系统 ")
    Call CreateMacOSTitleBar(MenuHeader, " 功能列表 ")
    Call MacButton("         切换用户", frmMain.cmdChangeUser, 0, 0, 170, 30, frmLogin.Source, 147, 0, 2)
    Call MacButton("         关于系统", frmMain.cmdAbout, 0, 0, 170, 30, frmLogin.Source, 147, 0, 2)
    Call MacButton("         退出系统", frmMain.cmdShutdown, 0, 0, 170, 30, frmLogin.Source, 147, 0, 2)
    Call BitBlt(frmMain.Closed.hDC, 0, 0, 73, 50, frmLogin.Source.hDC, 0, 107, SRCCOPY)
    frmMain.Closed.Refresh
    Call BitBlt(frmMain.Maximized.hDC, 0, 0, 73, 50, frmLogin.Source.hDC, 0, 72, SRCCOPY)
    frmMain.Maximized.Refresh
    Call BitBlt(frmMain.Minimized.hDC, 0, 0, 73, 50, frmLogin.Source.hDC, 0, 124, SRCCOPY)
    frmMain.Minimized.Refresh
    KeyPreview = True
    StatusMessage.Caption = " 今天是 " + Date$
    '创建Recordset实例datsecondary
    Set datsecondary = New adodb.Recordset
    '从INVOICE中获得信息
    datsecondary.Open "select * from INVOICE order by INVOICE_NO", myDB, 1, 3
    '创建datthirdary
    Set datthirdary = New adodb.Recordset
    '从INVOICE_DETAIL表中获得信息
    datthirdary.Open "select * from INVOICE_DETAIL order by INVOICE_NOD", myDB, 1, 3
    
    '创建datprimary
    Set datprimary = New adodb.Recordset
    '从SETUP表获得信息
    datprimary.Open "select * from SETUP order by COMPANY_NAME", myDB, 1, 3

    
    
End Sub

Public Sub Operation_CleanUp()
    'On Error Resume Next
    '用sql语句删除，速度快
    '如果采用delete方法，则需要循环删除，效率极低
    myDB.Execute ("delete from INVOICE")
    myDB.Execute ("delete from INVOICE_DETAIL")
   
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:
                UnloadAllForms
                End
        Case vbKeyC:
                If AltDown Then
                    Call MacButton("       更改用户", frmMain.cmdChangeUser, 0, 0, 170, 30, frmLogin.Source, 182, 30, 2)
                    cmdChangeUser_Click
                    Call MacButton("       更改用户", frmMain.cmdChangeUser, 0, 0, 170, 30, frmLogin.Source, 147, 0, 2)
                End If
        Case vbKeyA:
                If AltDown Then
                    Call MacButton("            关于", frmMain.cmdAbout, 0, 0, 170, 30, frmLogin.Source, 182, 30, 2)
                    cmdAbout_Click
                    Call MacButton("            关于", frmMain.cmdAbout, 0, 0, 170, 30, frmLogin.Source, 147, 0, 2)
                End If
        Case vbKeyS:
                If AltDown Then
                    Call MacButton("         退出系统", frmMain.cmdShutdown, 0, 0, 170, 30, frmLogin.Source, 182, 30, 2)
                    cmdShutdown_Click
                    Call MacButton("         退出系统", frmMain.cmdShutdown, 0, 0, 170, 30, frmLogin.Source, 147, 0, 2)
                Else
                    MenuFunction ("S")
                End If
         Case vbKeyP:
                MenuFunction ("P")
         Case vbKeyG:
                MenuFunction ("G")
         Case vbKeyF:
                MenuFunction ("F")
         Case vbKeyI:
                MenuFunction ("I")
         Case vbKeyK:
                MenuFunction ("K")
         Case vbKeyL:
                MenuFunction ("L")
         Case vbKeyT:
                MenuFunction ("T")
         Case vbKeyY:
                MenuFunction ("Y")
          Case vbKeyM:
                MenuFunction ("M")
         Case vbKeyD:
                MenuFunction ("D")
         Case vbKeyQ:
                MenuFunction ("Q")
         Case vbKeyX:
                MenuFunction ("X")
               
         Case vbKeyReturn:
                Call MenuFunction("")
    End Select
End Sub
    
Function MenuFunction(Fun As String)
    If MenuList = "供应商(S)" Or Fun = "S" Then
        frmSupplier.Show
    ElseIf MenuList = "商品信息(P)" Or Fun = "P" Then
        frmProduct.Show
    ElseIf MenuList = "商品分类(G)" Or Fun = "G" Then
        frmCategory.Show
    ElseIf MenuList = "前台销售(F)" Or Fun = "F" Then
        frmSelling.Show
    ElseIf MenuList = "入库信息(I)" Or Fun = "I" Then
        frmReceiving.Show
    ElseIf MenuList = "销售报表(K)" Or Fun = "K" Then
    ElseIf MenuList = "入库报表(L)" Or Fun = "L" Then
    ElseIf MenuList = "分类报表(T)" Or Fun = "T" Then
    ElseIf MenuList = "商品报表(Y)" Or Fun = "Y" Then
    ElseIf MenuList = "供应商报表(M)" Or Fun = "M" Then
    ElseIf MenuList = "数据处理(D)" Or Fun = "D" Then
        frmBackup.Show
    ElseIf MenuList = "权限设置(Q)" Or Fun = "Q" Then
        frmPassword.Show
    ElseIf MenuList = "系统设置(X)" Or Fun = "X" Then
        frmSetup.Show
    End If
End Function

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

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

Private Sub MenuList_Click()
    Call MenuFunction("")
End Sub

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

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

Private Sub Timer1_Timer()
    On Error Resume Next
    datsecondary.MoveFirst
    If (Not datsecondary.BOF) And (Not datthirdary.BOF) = 0 Then
    Else
        If datprimary("SELLING_CLEANUPDATE") <= Date Then
            Call MessageBox("frmMain", "You are scheduled for Invoice Cleanup." & vbCrLf & _
                            "Do you want to proceed with Invoice Cleanup ?", 1)
            frmMessageBox2.Show
            frmMessageBox2.SetFocus
        End If
    End If
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 tmrUpdate_Timer()
    On Local Error Resume Next
    Dim MS As MEMORYSTATUS
    Today = Now
    Clock.Caption = Format(Today, "hh:mm:ss ampm ")
    MS.dwLength = Len(MS)
    Call GlobalMemoryStatus(MS)
    With MS
        lbl(0) = Format$(.dwTotalPhys / 1024, "#,###") & " Kb"
        lbl(1) = Format$(.dwAvailPhys / 1024, "#,###") & " Kb"
        lbl(2) = Format$(.dwTotalVirtual / 1024, "#,###") & " Kb"
        lbl(3) = Format$(.dwAvailVirtual / 1024, "#,###") & " Kb"
        lbl(4) = Format$(.dwTotalPageFile / 1024, "#,###") & " Kb"
        lbl(5) = Format$(.dwAvailPageFile / 1024, "#,###") & " Kb"
        'lbl(6) = Format$(.dwMemoryLoad, "##0") & "%"
    End With
    If mIsWin32 Then
        Dim nIndex As Integer
            guageSystem.Value = pBGetFreeSystemResources(SR)
            guageSystem.ForeColor = AssignColour(guageSystem.Value)
            guageUser.Value = pBGetFreeSystemResources(USR)
            guageUser.ForeColor = AssignColour(guageUser.Value)
            'guageGDI.Value = pBGetFreeSystemResources(GDI)
            'guageGDI.ForeColor = AssignColour(guageGDI.Value)
            Select Case guageSystem.Value
                Case Is > 99
                Case Is < 1
                Case Else
                    nIndex = (100 - guageSystem.Value) * 0.13
                Select Case nIndex
                    Case Is < 0
                        nIndex = 0
                    Case Is > 12
                        nIndex = 12
                End Select
        End Select
    End If
End Sub

Private Function AssignColour(nPercent As Integer) As Long
    Select Case nPercent
        Case Is < 10
            AssignColour = vbRed
        Case Is < 25
            AssignColour = vbMagenta
        Case Else
            AssignColour = vbBlue
    End Select
End Function