frmmain.frm

本程序源码是由vb编写的

   Begin VB.Image Image1 
      Height          =   480
      Left            =   7950
      Picture         =   "frmMain.frx":25ACD
      Top             =   2280
      Width           =   480
   End
   Begin VB.Label lbAuthor 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "All Copyright Reserved  http://www.vb-code.net 温州东化计算机科技有限公司"
      ForeColor       =   &H00C0C0C0&
      Height          =   180
      Left            =   7215
      TabIndex        =   1
      Top             =   8385
      Width           =   6570
   End
   Begin VB.Label lbTop 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "全球通商务管理系统  Global Commerce Manage System"
      ForeColor       =   &H00000000&
      Height          =   180
      Left            =   6780
      TabIndex        =   0
      Top             =   2970
      Width           =   4410
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Const WM_SYSCOMMAND = &H112
Const SC_CLOSE = &HF060&

Private WithEvents m_cMenu As cPopupMenu
Attribute m_cMenu.VB_VarHelpID = -1
Dim s_Button As New AniCursor

Private Sub Form_Activate()
  
  '初始化菜单
   InitMenu
End Sub

'显示弹出菜单    lIndex = m_cMenu1.ShowPopupMenu(X + 50, Y + tbToolBar.Height + tbToolbar2.Height + 100, X + 50, Y + tbToolBar.Height + tbToolbar2.Height + 100, Me.ScaleWidth, 0, False)
Private Sub Form_Load()

  '御载Load窗体
   If LoginSucceeded = True Then
      Unload frmLogin
   End If
   
   s_Button.AniFileName = App.Path & "\Sys\7.ani"
   s_Button.SetAniCursor frmMain.hwnd
   
End Sub

Private Sub Form_Resize()

  If Me.WindowState = 1 Then Exit Sub '最小化
     
  On Error Resume Next
  
  lbAuthor.left = Me.Width - lbAuthor.Width - 300
  lbAuthor.tOp = Me.Height - lbAuthor.Height - 500
       
End Sub

Private Sub Form_Unload(Cancel As Integer)

  s_Button.RelaseAniCursor frmMain.hwnd
  Set Start_print = Nothing
    On Error Resume Next
    Unload frmLogin
    Unload frmSet
    Unload frmAbout
    Unload frmMain
    Unload frmAcount
   
End Sub

Private Sub Image2_Click()
 
 '显示菜单
  ShowMenu
  
End Sub

Private Sub tSet_ButtonClick(ByVal Button As MSComctlLib.Button)

  If Button.Key = "set" Then
     frmSet.Show 1
  End If
   
End Sub

Public Sub LoadAuthority()
   
   If sUserName = "超级用户" Then Exit Sub  '无须设置
   
   '测试不同权限
  Dim EF As Recordset, Db As Database, TmpStr As String
  Dim Us As String
      Us = sUserName
  Set Db = OpenDatabase(ConData, False, False, ConStr)
  Set EF = Db.OpenRecordset("Select * from UserLimit Where UserName='" & Us & "'", dbOpenDynaset)
         Authority(0) = NullValue(EF.Fields("SL100"))
         Authority(1) = NullValue(EF.Fields("Order100"))
         Authority(2) = NullValue(EF.Fields("QK100"))
         Authority(3) = NullValue(EF.Fields("RK100"))
         Authority(4) = NullValue(EF.Fields("Store100"))
         Authority(5) = NullValue(EF.Fields("Upload100"))
         Authority(6) = NullValue(EF.Fields("Config100"))
         Authority(7) = NullValue(EF.Fields("Acount100"))
      EF.Close
      Db.Close
      Set EF = Nothing
      Set Db = Nothing
   
End Sub

Private Sub ShowMenu()

  '显示弹出菜单
   lIndex = m_cMenu.ShowPopupMenu(200, frmMain.ScaleHeight - 1000, 0, 0, 0, 0, False)
   If (lIndex > 0) Then
       Select Case m_cMenu.ItemKey(lIndex)
         Case "Sell"
              frmSaleForm.Show
         Case "Qk"
              frmQK.Show
         Case "Fk"
              frmFK.Show
         Case "Rk"
              frmStore.Show
         Case "Store"
              frmChart.Show
         Case "Order"
              frmOrder.Show
         Case "Acount"
              frmAcount.Show
         Case "Upload"
              On Error GoTo No_File
              Shell App.Path & "\Upload.Exe"
              Exit Sub
No_File:
              MsgBox "上传部件Upload.Exe不存在，请与供应商联系！   " & vbCrLf & vbCrLf & "错误原因: " & Err.Description, vbExclamation, "E-Mail:[e-mail] 13806540284"
         Case "Config"
               frmSet.Show 1
         Case "About"
               frmAbout.Show 1
         Case "Close"
            '关闭
              Unload Me
              'PostMessage frmMain.hwnd, WM_SYSCOMMAND, SC_CLOSE, 0
         End Select
   End If

End Sub

Private Sub InitMenu()

   Dim i As Long
   Dim iI As Long
     
   ' 设置上弹菜单
   Set m_cMenu = New cPopupMenu
   With m_cMenu

      .hWndOwner = Me.hwnd
      .ImageList = ilsIcons16
      .HeaderStyle = ecnmHeaderSeparator
         
      ' 设置菜单项
      If Authority(0) = -1 Or sUserName = "超级用户" Then
         i = .AddItem("&T 上台销售 ...      " & vbCrLf, , , , 14, , , "Sell")
         .OwnerDraw(i) = True
         i = .AddItem("-")
         .OwnerDraw(i) = True
      End If
      If Authority(2) = -1 Or sUserName = "超级用户" Then
        i = .AddItem("&Q 应付款报表 ...      " & vbCrLf, , , , 5, , , "Qk")
        .OwnerDraw(i) = True
        i = .AddItem("&F 付款单管理 ...          " & vbCrLf, , , , 6, , , "Fk")
        .OwnerDraw(i) = True
        i = .AddItem("-")
        .OwnerDraw(i) = True
      End If
      If Authority(3) = -1 Or sUserName = "超级用户" Then
        i = .AddItem("&R 入库单管理 ...    " & vbCrLf, , , , 6, , , "Rk")
        .OwnerDraw(i) = True
      End If
      If Authority(4) = -1 Or sUserName = "超级用户" Then
        i = .AddItem("&S 产品库存浏览 ...   " & vbCrLf, , , , 40, , , "Store")
        .OwnerDraw(i) = True
        i = .AddItem("-")
        .OwnerDraw(i) = True
      End If
      If Authority(1) = -1 Or sUserName = "超级用户" Then
        i = .AddItem("&O 订单管理 ...      " & vbCrLf, , , , 6, , , "Order")
        .OwnerDraw(i) = True
        i = .AddItem("-")
        .OwnerDraw(i) = True
      End If
      If Authority(7) = -1 Or sUserName = "超级用户" Then
        i = .AddItem("&A 销售汇总与现金 ...     " & vbCrLf, , , , 16, , , "Acount")
        .OwnerDraw(i) = True
        i = .AddItem("-")
        .OwnerDraw(i) = True
      End If
      If Authority(5) = -1 Or sUserName = "超级用户" Then
        i = .AddItem("&U 上传到公司总部 ...     " & vbCrLf, , , , 4, , , "Upload")
        .OwnerDraw(i) = True
        i = .AddItem("-")
       .OwnerDraw(i) = True
      End If
      ' 添加你自己的菜单到子菜单中
      '.AddItem "VB中国" & vbCrLf, , mcWEBSITE, i, 38, , , "http://www.vb-code.net/"
      '.AddItem "VB讨论" & vbCrLf, , mcWEBSITE, i, 38, , , "http://www.vb-code.net/bbs"
      '.AddItem "温州东化计算机科技有限公司            " & vbCrLf, , mcWEBSITE, i, 38, , , "http://www.freelong.net"
      '.AddItem "-网上直销    " & vbCrLf, , , i
      '.AddItem "网上五金 >> 五金配件、电动工具、电览、电线 ...                    " & vbCrLf, , mcWEBSITE, i, 38, , , "http://www.freelong.net/hardware"
      '.AddItem "网上鞋城 >> 男女皮鞋、凉鞋、拖鞋 ...            " & vbCrLf, , mcWEBSITE, i, 38, , , "http://www.freelong.net/shoes"
      '.AddItem "网上眼镜 >> 太阳镜、墨镜 ...           " & vbCrLf, , mcWEBSITE, i, 38, , , "http://www.freelong.net/glasses"
      If Authority(6) = -1 Or sUserName = "超级用户" Then
        i = .AddItem("&C 系统配置 ...        " & vbCrLf, , , , 4, , , "Config")
        .OwnerDraw(i) = True
      End If
      i = .AddItem("&B 关于我们 ...    " & vbCrLf, , , , 41, , , "About")
      .OwnerDraw(i) = True
      i = .AddItem("-")
      .OwnerDraw(i) = True
      i = .AddItem("&X 退出系统     " & vbCrLf, , , , 28, , , "Close")
      .OwnerDraw(i) = True
      
   End With
   
   ' 首先估计菜单高度
   Dim lHeight As Long, lT As Long
   'Debug.Print m_cMenu.Count
   For i = 1 To m_cMenu.Count
      ' 检查，如果项目是主菜单时
      If (m_cMenu.hMenu(i) = m_cMenu.hMenu(1)) Then
         ' 添加项
         lHeight = lHeight + m_cMenu.MenuItemHeight(i)
         lT = lT + 1
      End If
   Next i
   
   picSideBar.Height = lHeight * Screen.TwipsPerPixelY
   ' 画渐变Logo
   Dim c As New cLogo
   With c
      .DrawingObject = picSideBar
      .StartColor = &H0
      .EndColor = &HFF
      .Caption = "  东化科技"
      .Draw
   End With
    
End Sub

Private Sub m_cMenu_DrawItem(ByVal hDC As Long, ByVal lMenuIndex As Long, lLeft As Long, lTop As Long, lRight As Long, lBottom As Long, ByVal bSelected As Boolean, ByVal bChecked As Boolean, ByVal bDisabled As Boolean, bDoDefault As Boolean)

Dim lW As Long
   lW = picSideBar.Width \ Screen.TwipsPerPixelX
   BitBlt hDC, lLeft, lTop, lW, lBottom - (lTop), picSideBar.hDC, 0, lTop - 2, vbSrcCopy
   lLeft = lLeft + lW + 1
   bDoDefault = True
   
End Sub

Private Sub m_cMenu_ItemHighlight(ItemNumber As Long, bEnabled As Boolean, bSeparator As Boolean)
   
   ' 显示用户条高亮
   'If (m_cMenu.ItemData(ItemNumber) = mcWEBSITE) Then
      'sbWinsockStatus.Panels(1).Text = "选择：" & m_cMenu.Caption(ItemNumber) & " (" & m_cMenu.ItemKey(ItemNumber) & ")"
   'Else
      'sbWinsockStatus.Panels(1).Text = m_cMenu.Caption(ItemNumber)
   'End If
End Sub

Private Sub m_cMenu_MeasureItem(ByVal lMenuIndex As Long, lWidth As Long, lHeight As Long)
   
   ' 画菜单项，我们必须提取该菜单项事件
   If m_cMenu.hMenu(1) = m_cMenu.hMenu(lMenuIndex) Then
      ' 添加渐变条
      lWidth = lWidth + picSideBar.Width \ Screen.TwipsPerPixelX + 1
   End If
   
End Sub