frmmain.frm

采用面向负荷控制技术

         Caption         =   "排列图标(&A)"
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "帮助(&H)"
      Begin VB.Menu mnuHelpContents 
         Caption         =   "目录(&C)"
      End
      Begin VB.Menu mnuHelpSearchForHelpOn 
         Caption         =   "搜索帮助主题(&S)..."
      End
      Begin VB.Menu mnuHelpBar0 
         Caption         =   "-"
      End
      Begin VB.Menu mnuHelpAbout 
         Caption         =   "关于(&A) "
      End
   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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Const EM_UNDO = &HC7
Private Declare Function OSWinHelp% Lib "user32" Alias "WinHelpA" (ByVal hwnd&, ByVal HelpFile$, ByVal wCommand%, dwData As Any)

Private Sub MDIForm_Load()
    Me.Left = GetSetting(App.Title, "Settings", "MainLeft", 1000)
    Me.Top = GetSetting(App.Title, "Settings", "MainTop", 1000)
    Me.Width = GetSetting(App.Title, "Settings", "MainWidth", 6500)
    Me.Height = GetSetting(App.Title, "Settings", "MainHeight", 6500)
End Sub

Private Sub MDIForm_Unload(Cancel As Integer)
    If Me.WindowState <> vbMinimized Then
        SaveSetting App.Title, "Settings", "MainLeft", Me.Left
        SaveSetting App.Title, "Settings", "MainTop", Me.Top
        SaveSetting App.Title, "Settings", "MainWidth", Me.Width
        SaveSetting App.Title, "Settings", "MainHeight", Me.Height
    End If
End Sub

Private Sub mnu_chj_Click()
   frmgeneralpartplan1.Show
End Sub



Private Sub mnu_order_Click()
   Frmorder1.Show
End Sub

Private Sub mnu_shgfp_Click()
    Dim i As Integer
i = getPower("2")
If i = 1 Then
    frmPower.Show vbModal
    If frmPower.OK_power Then
    i = 0
    Unload frmPower
    End If
End If
If i = 0 Then
    fMainForm.mnuTaskSort.Enabled = False
    frmTaskdist.Show
End If
End Sub

Private Sub mnu_zdfp_Click()
      frmsuanfa1.Show
End Sub

Private Sub mnuData_Click()
'fMainForm.mnuData.Enabled = False
'frmMain.mnuData.Enabled = False
frmDataAdm.Show
End Sub


Private Sub mnuSeeBigIcon_Click()
frmWorkshop.LVDevice.View = lvwIcon
frmWorkshop.LVDeviceClass.View = lvwIcon
mnuSeeBigIcon.Checked = True
mnuSeeDetail.Checked = False
mnuSeeList.Checked = False
mnuSeeSmallIcon.Checked = False
End Sub

Private Sub mnuSeeDetail_Click()
frmWorkshop.LVDevice.View = lvwReport
frmWorkshop.LVDeviceClass.View = lvwReport
mnuSeeDetail.Checked = True
mnuSeeList.Checked = False
mnuSeeSmallIcon.Checked = False
mnuSeeBigIcon.Checked = False
End Sub

Private Sub mnuSeeList_Click()
frmWorkshop.LVDevice.View = lvwList
frmWorkshop.LVDeviceClass.View = lvwList
mnuSeeList.Checked = True
mnuSeeSmallIcon.Checked = False
mnuSeeBigIcon.Checked = False
mnuSeeDetail.Checked = False
End Sub

Private Sub mnuSeeSmallIcon_Click()
frmWorkshop.LVDevice.View = lvwSmallIcon
frmWorkshop.LVDeviceClass.View = lvwSmallIcon
mnuSeeSmallIcon.Checked = True
mnuSeeList.Checked = False
mnuSeeBigIcon.Checked = False
mnuSeeDetail.Checked = False
End Sub

Private Sub mnusfgz_Click()
  Form1.Show
End Sub

Private Sub mnuSpect_Click()
fMainForm.mnuSpect.Enabled = False
frmSpect.Show
End Sub

Private Sub mnuSysShop1_Click()
frmworkshop1.Show
End Sub

Private Sub mnuSystemAdm_Click()
fMainForm.mnuSystemAdm.Enabled = False
frmSystemAdm.Show
End Sub

Private Sub mnuSysWorkshop_Click()
'fMainForm.mnuSysWorkshop.Enabled = False
'frmMain.mnuSysWorkshop.Enabled = False
frmWorkshop.Show
End Sub

Private Sub mnuTaskDes_Click()
fMainForm.mnuTaskDes.Enabled = False
frmTaskDes.Show
End Sub

Private Sub mnuTaskSend_Click()
'fMainForm.mnuTaskSend.Enabled = False
'frmMain.mnuTaskSend.Enabled = False
frmTaskSend.Show
End Sub



Private Sub mnuTest_Click()
Frmtest.Show
End Sub


Private Sub tbToolBar_ButtonClick(ByVal Button As MSComctlLib.Button)
    On Error Resume Next
    Select Case Button.Key
        Case "sysadm"
            fMainForm.mnuSystemAdm.Enabled = False
            frmSystemAdm.Show
        Case "workshop"
            fMainForm.mnusysworkshop.Enabled = False
            frmWorkshop.Show
        Case "changeGroup"
            'fMainForm.mnuSysWorkshop.Enabled = False
            'frmWorkshop.Show
        Case "send"
            fMainForm.mnuTaskSend.Enabled = False
            frmTaskSend.Show
        Case "dist"
            fMainForm.mnuTaskSort.Enabled = False
            frmTaskdist.Show
        Case "spect"
            fMainForm.mnuSpect.Enabled = False
            frmSpect.Show
        Case "dataadm"
            fMainForm.mnuData.Enabled = False
            frmDataAdm.Show
            
        Case "quit"
            Call mnuSystemExit_Click
        Case "test"
            'fMainForm.mnuTest = False
           ' Frmtest.Show
            
            'mnuFilePrint_Click
        Case "algrithm"
            frmsuanfa1.Show
        Case "复制"
            'mnuEditCopy_Click
        Case "粘贴"
            'mnuEditPaste_Click
        Case "粗体"
            'ActiveForm.rtfText.SelBold = Not ActiveForm.rtfText.SelBold
            'Button.Value = IIf(ActiveForm.rtfText.SelBold, tbrPressed, tbrUnpressed)
        Case "斜体"
            'ActiveForm.rtfText.SelItalic = Not ActiveForm.rtfText.SelItalic
            'Button.Value = IIf(ActiveForm.rtfText.SelItalic, tbrPressed, tbrUnpressed)
        Case "下划线"
            'ActiveForm.rtfText.SelUnderline = Not ActiveForm.rtfText.SelUnderline
            'Button.Value = IIf(ActiveForm.rtfText.SelUnderline, tbrPressed, tbrUnpressed)
        Case "左对齐"
            'ActiveForm.rtfText.SelAlignment = rtfLeft
        Case "置中"
            'ActiveForm.rtfText.SelAlignment = rtfCenter
        Case "右对齐"
            'ActiveForm.rtfText.SelAlignment = rtfRight
    End Select
End Sub

Private Sub mnuHelpAbout_Click()
    frmAbout.Show vbModal, Me
End Sub

Private Sub mnuHelpSearchForHelpOn_Click()
    Dim nRet As Integer


    '如果这个工程没有帮助文件，显示消息给用户
    '可以在“工程属性”对话框中为应用程序设置帮助文件
    If Len(App.HelpFile) = 0 Then
        MsgBox "无法显示帮助目录，该工程没有相关联的帮助。", vbInformation, Me.Caption
    Else

    On Error Resume Next
        nRet = OSWinHelp(Me.hwnd, App.HelpFile, 261, 0)
        If err Then
            MsgBox err.Description
        End If
    End If

End Sub

Private Sub mnuHelpContents_Click()
    Dim nRet As Integer


    '如果这个工程没有帮助文件，显示消息给用户
    '可以在“工程属性”对话框中为应用程序设置帮助文件
    If Len(App.HelpFile) = 0 Then
        MsgBox "无法显示帮助目录，该工程没有相关联的帮助。", vbInformation, Me.Caption
    Else
        On Error Resume Next
        nRet = OSWinHelp(Me.hwnd, App.HelpFile, 3, 0)
        If err Then
            MsgBox err.Description
        End If
    End If

End Sub


Private Sub mnuWindowArrangeIcons_Click()
    Me.Arrange vbArrangeIcons
End Sub

Private Sub mnuWindowTileVertical_Click()
    Me.Arrange vbTileVertical
End Sub

Private Sub mnuWindowTileHorizontal_Click()
    Me.Arrange vbTileHorizontal
End Sub

Private Sub mnuWindowCascade_Click()
    Me.Arrange vbCascade
End Sub

Private Sub mnuWindowNewWindow_Click()
    LoadNewDoc
End Sub

Private Sub mnuToolsOptions_Click()
    frmOptions.Show vbModal, Me
End Sub

Private Sub mnuViewWebBrowser_Click()
    Dim frmB As New frmBrowser
    frmB.StartingAddress = "http://www.microsoft.com"
    frmB.Show
End Sub

Private Sub mnuViewOptions_Click()
    frmOptions.Show vbModal, Me
End Sub

Private Sub mnuViewRefresh_Click()
    '应做:添加 'mnuViewRefresh_Click' 代码。
    MsgBox "添加 'mnuViewRefresh_Click' 代码。"
End Sub

Private Sub mnuViewStatusBar_Click()
    mnuViewStatusBar.Checked = Not mnuViewStatusBar.Checked
    sbStatusBar.Visible = mnuViewStatusBar.Checked
End Sub

Private Sub mnuViewToolbar_Click()
    mnuViewToolbar.Checked = Not mnuViewToolbar.Checked
    tbToolBar.Visible = mnuViewToolbar.Checked
End Sub

Private Sub mnuSystemExit_Click()
    '卸载窗体
    Unload Me

End Sub

Private Sub tbToolBar_ButtonMenuClick(ByVal ButtonMenu As MSComctlLib.ButtonMenu)
Select Case ButtonMenu.Key
    Case "buff"
        FrmAlgBuff.Tag = "buff"
        FrmAlgBuff.Show
    Case "prodtime"
        FrmAlgBuff.Tag = "prodtime"
        FrmAlgBuff.Show
    Case "ljb"
        FrmAlgBuff.Tag = "ljb"
        FrmAlgBuff.Show
    Case "other"
        FrmAlgBuff.Tag = "other"
        FrmAlgBuff.Show
    Case "ddjh"
        Frmorder1.Show
    Case "jhcj"
        frmgeneralpartplan1.Show
End Select
End Sub

Function getPower(pow As String) As Integer
Dim sql As String, rs As New ADODB.Recordset
Dim mconn As New ADODB.Connection

Dim i As Integer
mconn.Open "DSN=dlrwdb;uid=scl"
sql = "select * from passwd where username='" & CurrentUser & "'"
rs.Open sql, mconn, adOpenKeyset, adLockPessimistic
If rs.RecordCount = 0 Then
    MsgBox "系统异常，联系系统管理员", vbOKOnly
    rs.Close
    getPower = 1
    Exit Function
End If
If InStr(1, rs("power"), pow, vbTextCompare) Then
    rs.Close
    getPower = 0
    Exit Function
End If
getPower = 1
Set mconn = Nothing
End Function