www.pudn.com > VB-KAOQINXITONG.zip > frmPublicMain.frm
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{DB2B0BEC-4F23-11D7-910C-00000E55E64F}#5.0#0"; "BNToolbar.ocx"
Object = "{B9D938CE-50EE-40B2-9FA2-79A3112F4788}#4.2#0"; "BNCtrlGroup.ocx"
Object = "{47A3B823-A428-11CE-8FDC-524153480001}#3.0#0"; "MsgBlast.ocx"
Begin VB.Form frmMain
AutoRedraw = -1 'True
BackColor = &H00993F2F&
ClientHeight = 1965
ClientLeft = 540
ClientTop = 2250
ClientWidth = 3300
DrawStyle = 6 'Inside Solid
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "frmPublicMain.frx":0000
LinkTopic = "Form1"
ScaleHeight = 1965
ScaleWidth = 3300
WindowState = 2 'Maximized
Begin MessageBlaster.MsgBlaster MsgBlaster1
Left = 2610
OleObjectBlob = "frmPublicMain.frx":000C
Top = 630
End
Begin VB.Timer tmrExcute
Enabled = 0 'False
Interval = 1
Left = 1065
Top = 690
End
Begin VB.PictureBox Picture1
AutoRedraw = -1 'True
BackColor = &H00FFFFFF&
BorderStyle = 0 'None
FillColor = &H00FFFFFF&
BeginProperty Font
Name = "Times New Roman"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 6795
Left = 6105
ScaleHeight = 6795
ScaleWidth = 9060
TabIndex = 3
Top = 465
Width = 9060
Begin BNCtrlGroup.BNButton cmdHide
Height = 525
Left = 585
TabIndex = 6
ToolTipText = "隐蔽工具面板"
Top = 6225
Width = 495
_ExtentX = 0
_ExtentY = 0
CapAlign = 2
BackStyle = 2
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Mode = 0
Value = 0 'False
ImgAlign = 4
Image = "frmPublicMain.frx":1305
cBack = 10043183
End
Begin BNCtrlGroup.BNButton cmdAbout
Height = 525
Left = 45
TabIndex = 5
ToolTipText = "关于"
Top = 6225
Width = 495
_ExtentX = 0
_ExtentY = 0
CapAlign = 2
BackStyle = 2
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Mode = 0
Value = 0 'False
ImgAlign = 4
Image = "frmPublicMain.frx":1757
cBack = 10043183
End
Begin VB.CheckBox chkBoard
Appearance = 0 'Flat
BackColor = &H00DFA000&
Caption = "下次启动时不显示本面板"
BeginProperty Font
Name = "Times New Roman"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
Height = 285
Left = 5670
TabIndex = 4
Top = 6465
Width = 3015
End
Begin VB.Label lblReturn
Alignment = 2 'Center
AutoSize = -1 'True
BackColor = &H00DFA000&
BackStyle = 0 'Transparent
Caption = "出"
BeginProperty Font
Name = "楷体_GB2312"
Size = 18
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 330
Index = 1
Left = 8415
TabIndex = 10
Top = 5625
Width = 405
End
Begin VB.Label lblReturn
Alignment = 2 'Center
BackColor = &H00DFA000&
BackStyle = 0 'Transparent
Caption = "退"
BeginProperty Font
Name = "楷体_GB2312"
Size = 18
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 855
Index = 0
Left = 8400
TabIndex = 9
Top = 5175
Width = 405
End
Begin VB.Label lblMailto
Alignment = 1 'Right Justify
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "技术支持"
BeginProperty Font
Name = "Times New Roman"
Size = 12
Charset = 0
Weight = 400
Underline = -1 'True
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H000000FF&
Height = 285
Left = 6990
TabIndex = 8
Top = 6030
Width = 960
End
Begin VB.Label lblButton
Alignment = 2 'Center
BeginProperty Font
Name = "仿宋_GB2312"
Size = 15
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 345
Index = 1
Left = 1260
TabIndex = 7
Top = 1065
Width = 2055
End
End
Begin VB.PictureBox picMainTemp
AutoRedraw = -1 'True
AutoSize = -1 'True
Height = 360
Index = 0
Left = 1575
ScaleHeight = 20
ScaleMode = 3 'Pixel
ScaleWidth = 21
TabIndex = 2
Top = 750
Visible = 0 'False
Width = 375
End
Begin BNToolbarProj.BNToolbar BNToolbar1
Align = 1 'Align Top
Height = 435
Left = 0
Top = 0
Width = 3300
_ExtentX = 5821
_ExtentY = 767
BeginProperty ToolTipFont {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
BorderStyle = 3
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Appearance = 1
ButtonCount = 0
End
Begin MSComctlLib.StatusBar StatusBar1
Height = 300
Left = 150
TabIndex = 1
Top = 1470
Width = 2940
_ExtentX = 5186
_ExtentY = 529
_Version = 393216
BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
NumPanels = 3
BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
AutoSize = 1
Text = "系统状态:就绪"
TextSave = "系统状态:就绪"
EndProperty
BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628}
AutoSize = 2
EndProperty
BeginProperty Panel3 {8E3867AB-8586-11D1-B16A-00C0F0283628}
AutoSize = 2
EndProperty
EndProperty
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin VB.Timer tmrMonitor
Enabled = 0 'False
Left = 555
Top = 690
End
Begin VB.Timer tmrChecker
Enabled = 0 'False
Interval = 1000
Left = 45
Top = 690
End
Begin MSComctlLib.ProgressBar ProgressBar1
Height = 165
Left = 150
TabIndex = 0
Top = 1200
Visible = 0 'False
Width = 2940
_ExtentX = 5186
_ExtentY = 291
_Version = 393216
Appearance = 0
End
Begin MSComDlg.CommonDialog dlgCommonDialog
Left = 2040
Top = 630
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.Menu XXX
Caption = ""
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'主屏幕
Option Explicit
Dim mbFirstRun As Boolean
Dim madoMenuRS As ADODB.Recordset
Dim madoCtrlRS As ADODB.Recordset
Dim mbLoadFail As Boolean
Dim miIndex As Integer
Dim mlParentMenu As Long
Dim mbMove As Boolean
Dim mbResizeDis As Boolean
Dim mbCanExit As Boolean
Dim miPicIndex As Integer
Dim mbRelogin As Boolean
Dim mbClicking As Boolean
Dim mbNoVisible As Boolean
Dim mbIsLogin As Boolean
'如果不使用MESSAGEBLAST.OCX控件来调试子类，可以使用类cSubclass来调试避免死机
#If USERMESSAGEBLAST = 0 Then
Private WithEvents m_oSubclass As clsSubclass
Attribute m_oSubclass.VB_VarHelpID = -1
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
#End If
Private Sub Form_Load()
Dim i As Integer
Dim n As Integer
mbRelogin = False
mbNoVisible = True
mbIsLogin = False
If gbFirstLogin Then Exit Sub
If mbIsLogin Then Exit Sub
If gTAppLicInfo.SysDebugLevel = 10 Then _
gclsCommon.CBNSaveLogFile "用户成功登录:" & gclsCommon.CBNGetNow, True, True
SetIcon Me
If gclsInclude.MyFileExists(gTAppLicInfo.FilePicBoard) Then
Me.Picture1 = LoadPicture(gTAppLicInfo.FilePicBoard)
Else
gTAppLicInfo.CtrlBoardShow = False
End If
gclsCommon.MainHwnd = Me.hwnd
LoInitMenu
If UBound(gTMenuStruct) = 0 Then
MsgBox "本用户无菜单的操作权限,系统将退出", vbCritical
mbLoadFail = True
Unload Me
Exit Sub
End If
With gTAppLicInfo
StatusBar1.Panels(2).Text = "［" & .SoftCnName & "管理系统-" & .SoftLevel & "］"
StatusBar1.Panels(3).Text = " ［" & .SoftOwnerAlias & "一卡通" & "］"
ProgressBar1.Visible = False
Picture1.Visible = .CtrlBoardShow
chkBoard.BackColor = .SoftMainColor
Picture1.BackColor = .SoftMainColor
cmdAbout.BackColor = .SoftMainColor
cmdHide.BackColor = .SoftMainColor
chkBoard.Value = IIf(.CtrlBoardShow, 0, 1)
End With
BNToolbar1.DebugMode = False
lblMailto.MousePointer = vbCustom
lblMailto.ForeColor = vbBlue
Set lblMailto.MouseIcon = DFNLoadResPicture(101, vbResCursor)
cmdAbout.MousePointer = vbCustom
Set cmdHide.MouseIcon = DFNLoadResPicture(101, vbResCursor)
Set cmdAbout.MouseIcon = DFNLoadResPicture(101, vbResCursor)
cmdHide.MousePointer = vbCustom
For i = 0 To 1
lblReturn(i).MousePointer = vbCustom
Set lblReturn(i).MouseIcon = lblButton(1).MouseIcon
Next i
mbFirstRun = False
lblReturn(0).Tag = "Exit"
lblReturn(1).Tag = lblReturn(0).Tag
If gTAppLicInfo.CtrlAutoDownload Or gTAppLicInfo.CtrlAutoRight Then
Set madoCtrlRS = New ADODB.Recordset
madoCtrlRS.Open "SELECT * FROM T0105S001 WHERE W1027 ='" & gTAppLicInfo.SysClient & "'", _
gDBRecordConn, adOpenKeyset, adLockOptimistic
If madoCtrlRS.RecordCount > 0 Then
tmrMonitor.Interval = 400
tmrMonitor.Enabled = True
Else
MsgBox "本机未列入控制系统,请先做设置.详情常见操作手册", vbInformation
madoCtrlRS.Close
Set madoCtrlRS = Nothing
End If
End If
LoSetCaption
lblReturn(0).Enabled = mbCanExit
lblReturn(1).Enabled = lblReturn(0).Enabled
#If USERMESSAGEBLAST Then
With MsgBlaster1
If .hWndTarget = 0 Then
.hWndTarget = Me.hwnd
.AddMessage 691022, POSTPROCESS
.AddMessage WM_COMMAND, POSTPROCESS
End If
End With
#Else
' create an instance of the cSubclass object and call it's
' SubClass method to initiate the subclass for this form
If m_oSubclass Is Nothing Then
Set m_oSubclass = New clsSubclass
m_oSubclass.SubClass hwnd
End If
#End If
If mbLoadFail Then Exit Sub
gclsInclude.MySetHotBoot Not mbCanExit
LoMenuClick 0
If gTAppLicInfo.CtrlMenuBmp Then LoSetMenuBitmap
Unload frmSplash
Me.Show
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
Dim i As Integer
If gbFirstLogin Then Exit Sub
If mbCanExit Then
If Not mbLoadFail Then
If MsgBox("确实要退出系统吗?", vbYesNo + vbQuestion) = vbNo Then
Cancel = True
If Not tmrChecker.Enabled Then tmrChecker.Enabled = True
gTAppLicInfo.CtrlUnload = False
Exit Sub
End If
End If
Else
MsgBox "用户没有退出程序的权限,请向管理员申请", vbCritical
Cancel = True
Exit Sub
End If
mbIsLogin = True
mbResizeDis = True
#If USERMESSAGEBLAST Then
With MsgBlaster1
.Enabled = False
.hWndTarget = 0
.ClearMessageList
End With
#Else
Set m_oSubclass = Nothing
#End If
tmrChecker.Enabled = False
tmrMonitor.Enabled = False
If gTAppLicInfo.CtrlMenuBmp Then
gclsInclude.MyFreeMenus
For i = 1 To picMainTemp.UBound
Unload picMainTemp(i)
Next i
End If
SaveAllPickStruct
Erase gTMenuStruct
gclsInclude.MySetHotBoot False
If gclsInclude.MyFileExists(gTAppLicInfo.FilePicSplash) Then
frmSplash.Show
frmSplash.Refresh
End If
gclsCommon.CBNSaveEvents OET_EXIT_PROGRAM, _
gTAppLicInfo.SoftCnName & "(" & gTAppLicInfo.SoftLevel & ")"
If gTAppLicInfo.CtrlPapleCtrl Then gclsPntCtrl.PRN_ReSetOrientation 'This resets the printer to portrait.
If gTAppLicInfo.CtrlPapleCtrl Then Set gclsPntCtrl = Nothing
Set madoMenuRS = Nothing
Set madoCtrlRS = Nothing
Set gadoFldsRS = Nothing
Set gadoFldIndexRS = Nothing
Set gclsCommon.adoMemberRS = Nothing
gclsDBFunc.dbCloseConnect False
CloseOtherWindows , True
Set gDBRecordConn = Nothing
If gclsInclude.MyFileExists(gTAppLicInfo.FilePicSplash) Then Unload frmSplash
SaveAllPickStruct
' On Error Resume Next
gclsCommon.CommonConnect = Nothing
Set gclsCommon = Nothing
Set gclsInclude = Nothing
Set gclsDBFunc = Nothing
Set gclsTreeView = Nothing
End Sub
Private Sub Form_Activate()
If gbFirstLogin Then
Unload Me
Exit Sub
End If
If mbLoadFail Then
Unload Me
End
End If
LoDrawForm gTAppLicInfo.FilePicBG
tmrChecker.Enabled = True
End Sub
Private Sub Form_DblClick()
If Not gTAppLicInfo.CtrlBoardShow Then Exit Sub
If Picture1.Visible = False Then Picture1.Visible = True
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If mbMove Then
mbMove = False
If Picture1.Visible Then
lblMailto.ForeColor = vbBlue
lblMailto.Caption = "技术支持"
End If
End If
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
'UnloadMode 参数返回下列值:
'常数 值 描述
'vbFormControlMenu 0 用户从窗体上的“控件”菜单中选择“关闭”指令.
'vbFormCode 1 Unload 语句被代码调用.
'vbAppWindows 2 当前 Microsoft Windows 操作环境会话结束.
'vbAppTaskManager 3 Microsoft Windows 任务管理器正在关闭应用程序.
'vbFormMDIForm 4 MDI 子窗体正在关闭,因为 MDI 窗体正在关闭.
If gbFirstLogin Then Exit Sub
End Sub
Private Sub Form_Resize()
If gbFirstLogin Then Exit Sub
If mbResizeDis Then Exit Sub
With StatusBar1
.Width = Me.ScaleWidth
.Left = 0
.Top = Me.ScaleHeight - .Height
' DoEvents
gclsInclude.MyShowPbrInSbr ProgressBar1, .hwnd, 1
' DoEvents
.Panels(1).Text = "系统状态:正使用 " & IIf(gTAppLicInfo.SoftNetwork, gTAppLicInfo.SoftSQLServer & _
"\" & gTAppLicInfo.SoftSQLDBase, gTAppLicInfo.FileDBRecord) & " 数据库"
.Refresh
Picture1.Move (Me.Width - Picture1.Width) / 2, (Me.Height - Picture1.Height - .Height) / 2
End With
End Sub
Private Sub lblButton_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
lblButton(Index).BorderStyle = 1
End Sub
Private Sub lblButton_MouseMove(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
lblButton_MouseEnter Index
End Sub
Private Sub lblButton_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
lblButton_MouseExit Index
lblButton(Index).BorderStyle = 0
End Sub
Private Sub lblButton_Click(Index As Integer)
If lblButton(Index).Tag = "" Then Exit Sub
mbClicking = True
LoMenuClick lblButton(Index).Tag
mbClicking = False
End Sub
Private Sub lblButton_MouseEnter(Index As Integer)
lblButton(Index).Font.Underline = True
lblButton(Index).ForeColor = vbRed
miIndex = Index
End Sub
Private Sub lblButton_MouseExit(Index As Integer)
lblButton(Index).ForeColor = vbWhite
lblButton(Index).Font.Underline = False
End Sub
Private Sub lblMailto_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbLeftButton Then
Call ShellExecute(0&, vbNullString, "MailTo:" & gTAppLicInfo.SoftAuthorEmail, vbNullString, vbNullString, vbNormalFocus)
End If
End Sub
Private Sub lblMailto_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If Not mbMove Then
lblMailto.ForeColor = vbRed
lblMailto.Caption = "MailTo: " & gTAppLicInfo.SoftAuthorEmail
mbMove = True
End If
End Sub
Private Sub lblReturn_MouseMove(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
lblReturn(0).ForeColor = vbYellow
lblReturn(1).ForeColor = vbYellow
End Sub
Private Sub lblReturn_Click(Index As Integer)
Dim l As Long
mbClicking = True
Select Case lblReturn(Index).Tag
Case "Exit"
gTAppLicInfo.CtrlUnload = True
Exit Sub
Case Else
LoMenuClick lblReturn(Index).Tag
End Select
mbClicking = False
End Sub
Private Sub BNToolbar1_ButtonClick(ByVal ButtonIndex As Integer, ByVal ButtonKey As String)
LoClickMenuItem ButtonKey
End Sub
Private Sub tmrExcute_Timer()
tmrExcute.Enabled = False
If mbIsLogin Then Exit Sub
If gbBusy Then Exit Sub
DoMnuCommand CLng(tmrExcute.Tag)
End Sub
Private Sub tmrMonitor_Timer()
'W1027 上位机
'W1030 控制命令
'W1031 控制状态
'W1027 上位机表示本机的计算机名,如果有对应,表示可接受控制
Dim sStatus As String
Dim sControl As String
Dim bUpdate As Boolean
If gbBusy Then Exit Sub
With madoCtrlRS
If .RecordCount > 0 Then
.Requery
sControl = gclsInclude.MyNz(!W1030, "00000000")
sStatus = gclsInclude.MyNz(!W1031, "00000000")
'如果进入,先置标志表示本机已运行程序或在线
If Mid(sStatus, 3, 1) = "0" Then
gclsInclude.MyMid sStatus, 3, "1"
!W1031 = sStatus
.Update
End If
'第一位表示希望采集数据或下载名单
If Mid(sControl, 1, 1) = 1 Then
gclsInclude.MyMid sControl, 1, "0"
!W1030 = sControl
.Update
gclsCommon.CommonAutoExec = True
DoMnuCommand 0, "mnuPickData"
ElseIf Mid(sControl, 2, 1) = 1 Then
gclsInclude.MyMid sControl, 2, "0"
!W1030 = sControl
.Update
gclsCommon.CommonAutoExec = True
DoMnuCommand 0, "mnuDNWhite"
End If
End If
End With
End Sub
Private Sub Picture1_MouseMove(Button As Integer, _
Shift As Integer, _
x As Single, _
y As Single)
Dim i As Integer
If mbIsLogin Then Exit Sub
If mbClicking Then Exit Sub
If miIndex > 0 Then
miIndex = 0
tmrChecker_Timer
End If
For i = 0 To 1
lblReturn(i).ForeColor = vbWhite
Next i
If mbMove Then
lblMailto.ForeColor = vbBlue
lblMailto.Caption = "技术支持"
mbMove = False
End If
End Sub
Private Sub chkBoard_Click()
With gTAppLicInfo
.CtrlBoardShow = IIf(chkBoard.Value = 1, False, True)
gclsInclude.MySetINIData .FileINI, _
"System Settings", _
"BoardShow", _
IIf(.CtrlBoardShow, 1, 0)
End With
End Sub
Private Sub tmrChecker_Timer()
Dim i As Integer
Static n As Integer
Static DTime As Date
If gbBusy Then Exit Sub
If gTAppLicInfo.CtrlUnload Then
tmrChecker.Enabled = False
Unload Me
Exit Sub
End If
i = LoGetMenuIndex("mnuTime")
With gTMenuStruct(i)
If i <> -1 Then
If .bVisible Then
If DTime = 0 Then DTime = gclsCommon.CBNGetNow
If gclsInclude.MySecondDiff(DTime, gclsCommon.CBNGetNow) < 70 Then
.Caption = " " & gclsCommon.CBNGetNow & "(&T)"
gclsInclude.MySetMenuCaption Me.hwnd, .Child, .Caption, .wID
Else
n = n + 1
End If
'系统修改时间后,暂停5秒
If n > 5 Then
DTime = gclsCommon.CBNGetNow
n = 0
End If
End If
End If
End With
If Picture1.Visible Then
For i = 1 To lblButton.Count
If lblButton(i).Font.Underline Then
If i <> miIndex Then lblButton_MouseExit i
End If
Next i
End If
End Sub
#If USERMESSAGEBLAST Then
Private Sub Msgblaster1_Message(ByVal hwnd As Long, _
ByVal Msg As Long, _
wParam As Long, _
lParam As Long, _
nPassage As Integer, _
lReturnValue As Long)
If mbResizeDis Then Exit Sub
Select Case Msg
Case WM_DRAWITEM, WM_MEASUREITEM
gclsInclude.MyIconProc hwnd, Msg, wParam, lParam
Case 691022
If wParam = 163 Then
With frmPubSystemSetup
.psFocusControl = "txtUserName"
.piTab = 0
.Show IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
End With
End If
Case WM_COMMAND
DoMnuCommand wParam ', lParam, nPassage, lReturnValue
End Select
End Sub
#Else
Private Sub m_oSubclass_EVTSetSetup(fsDoWhat As String)
If mbIsLogin Then Exit Sub
With frmPubSystemSetup
If fsDoWhat = "USERNAME" Then
.psFocusControl = "txtUserName"
.piTab = 0
.Show IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
End If
End With
End Sub
Private Sub m_oSubclass_MenuClick(wParam As Long)
If mbIsLogin Then Exit Sub
If tmrChecker.Enabled Then
tmrExcute.Tag = wParam
tmrExcute.Enabled = True
End If
End Sub
#End If
Private Sub cmdAbout_Click()
DoMnuCommand 0, "mnuHelpAbout"
End Sub
Private Sub cmdHide_Click()
DoMnuCommand 0, "mnuShowTools"
End Sub
Private Function LoGetMenuIndex(fsMenuName As String) As Integer
Dim i As Integer
LoGetMenuIndex = -1
For i = 0 To UBound(gTMenuStruct)
If fsMenuName = gTMenuStruct(i).sVBName Then
LoGetMenuIndex = i
Exit For
End If
Next i
End Function
Private Sub LoSetMenuBitmap()
Dim i As Integer
Dim bEnabled As Boolean
Dim sCaption As String
For i = 0 To UBound(gTMenuStruct)
With gTMenuStruct(i)
If .bVisible And (.Parent <> "0") Then
If .sVBName = "mnuAttendCal" Then
.lTextColor = vbRed
.lSelectColor = vbRed
End If
If .sBmpKey <> "" Then
LoAddMenuBmp gTMenuStruct(i)
bEnabled = True
End If
End If
End With
Next i
If Not mbRelogin Then
#If USERMESSAGEBLAST Then
If bEnabled Then
With MsgBlaster1
.AddMessage WM_DRAWITEM, POSTPROCESS
.AddMessage WM_MEASUREITEM, POSTPROCESS
.AddMessage WM_NCLBUTTONDBLCLK, POSTPROCESS
.AddMessage WM_NCLBUTTONDOWN, POSTPROCESS
End With
End If
#End If
End If
Exit Sub
' **** 使用另一种方法加载图形菜单,可以尝试将以上的代码全部注释掉使用下列三行代码 ***
' Dim hwndPic As Long
' hwndPic = gclsInclude.MyGetMenuBmpHandle(Me, DFNLoadResPicture(101, vbResBitmap))
' Call gclsInclude.MySetMenuBmp(Me.hwnd, "6.3", hwndPic, hwndPic) '操作员管理
'**********
End Sub
Private Sub LoHideMenu(fsMenuName As String, Optional fbVisible As Boolean = False)
Dim i As Integer
i = LoGetMenuIndex(fsMenuName)
If i <> -1 Then
gTMenuStruct(i).bEnabled = fbVisible
gTMenuStruct(i).bVisible = fbVisible
End If
End Sub
Private Sub LoSetCaption()
Dim i As Integer
Dim n As Integer
Dim sTemp As String
' Dim oButton As MSComctlLib.Button
Caption = Trim(gTAppLicInfo.UserName) & gTAppLicInfo.SoftCnName
Caption = Caption & "(" & IIf(Not gTAppLicInfo.SoftNetwork, "单机", "网络") & "版)"
If gTAppLicInfo.SysLoginSA Then
Caption = Caption & " - 操作员:超级用户"
Else
Caption = Caption & " - 操作员:" & gTAppLicInfo.SysLoginUser
If gTAppLicInfo.SysLoginSYS Then
Caption = Caption & "(系统管理员)"
End If
End If
With gclsInclude
.MySetINIData gTAppLicInfo.FileINI, "Program Info", "Title", Caption
'对于客户D,要考虑计件工资的路径
If gTAppLicInfo.UserAlias = "客户D" Then
'看是否存在计件工资执行文件
If n > 0 Then
For i = 1 To n
If UCase(.MyFileName(gTAppLicInfo.FileExName(i))) = UCase("BNPayCount.exe") Then
If .MyFilePath(gTAppLicInfo.FileExName(i)) <> .MyFilePath(gTAppLicInfo.FileINI) Then
sTemp = .MyFilePath(gTAppLicInfo.FileExName(i)) & .MyFileName(gTAppLicInfo.FileINI)
If .MyFileExists(sTemp) Then
.MySetINIData sTemp, "Program Info", "Title", Caption
End If
End If
Exit For
End If
Next i
End If
End If
End With
End Sub
Private Sub LoSetMenuData(fsMenuItem, _
fiIndex As Integer, _
fsCaption As String, _
fsFile As String, _
bVisible As Boolean, _
bEnabled As Boolean)
Dim i As Integer
Dim lParent As Long
Dim bTemp As Boolean
'外挂程序将附加在工具栏的最下面，同时也附加在菜单信息的最后面
With madoMenuRS
.Filter = "W1126 ='mnuProgram'"
If .RecordCount = 0 Then
.Filter = "W1126 ='mnuTool'"
If .RecordCount = 0 Then Exit Sub
End If
lParent = !W0090
For i = 0 To UBound(gTMenuStruct)
If gTMenuStruct(i).sVBName = fsMenuItem & fiIndex Then
bTemp = True
Exit Sub
End If
Next i
End With
If Not bTemp Then
ReDim Preserve gTMenuStruct(i)
With gTMenuStruct(i)
.sVBName = fsMenuItem & fiIndex
.bEnabled = bEnabled
.bVisible = bVisible
.ButtonCaption = fsCaption
.Caption = fsCaption
.Child = madoMenuRS!W1125
.lParent = madoMenuRS!W0090
.lID = gTMenuStruct(i - 1).lID + 1
.lTextColor = vbBlack
.Parent = gclsInclude.MyGetMenuParentStr(.Child)
.wID = gTMenuStruct(i - 1).wID + 1
.ButtonCaption = fsFile
' .lPos =
End With
End If
End Sub
Public Sub LoDrawForm(Optional fFileBG As String)
If gclsInclude.MyFileExists(fFileBG) Then
If Me.Width > Me.Picture.Width - 7730 Then
Me.PaintPicture LoadPicture(fFileBG), 0, 0, ScaleWidth, ScaleHeight
End If
Else
gclsInclude.MyFillForm Me, gTAppLicInfo.SoftMainColor
End If
End Sub
Private Sub LoMenuClick(ByVal lSelfID As Long)
Dim i As Integer
Dim n As Integer
Dim k As Integer
With madoMenuRS
.Filter = "(W0090 = " & lSelfID & ") AND (W1124 = '1') AND (W1121<>'-')"
n = .RecordCount
If n > 0 Then
For i = 1 To lblButton.Count
lblButton(i).Visible = False
Next i
For i = 1 To n
If i < lblButton.Count + 1 Then
lblButton(i).Caption = !W1123
lblButton(i).Tag = !W1130
k = LoGetMenuIndex(!W1126)
If k = -1 Then
lblButton(i).Visible = False
Else
lblButton(i).Visible = gTMenuStruct(k).bEnabled
End If
lblButton(i).Enabled = lblButton(i).Visible
.MoveNext
End If
Next i
.MoveFirst
If lSelfID = 0 Then
lblReturn(0).Tag = "Exit"
lblReturn(1).Tag = "Exit"
lblReturn(0).Caption = "退"
lblReturn(1).Caption = "出"
Else
.Filter = "W1130 = '" & lSelfID & "'AND (W1121<>'-')"
lblReturn(0).Tag = !W0090
lblReturn(1).Tag = lblReturn(0).Tag
lblReturn(0).Caption = "返"
lblReturn(1).Caption = "回"
End If
ElseIf lSelfID = 0 Then
LoHideMenu "mnuShowTools"
Picture1.Visible = False
Else
.Filter = "(W1130 = '" & lSelfID & "') AND (W1124 = '1') AND (W1121<>'-')"
'执行该命令
If .RecordCount > 0 Then
LoClickMenuItem !W1126
End If
End If
End With
End Sub
Private Sub LoClickMenuItem(ByVal fsMenuName As String)
Dim i As Integer
On Error GoTo ErrLabel
For i = 0 To UBound(gTMenuStruct)
If fsMenuName = gTMenuStruct(i).sVBName Then
If gTMenuStruct(i).wID > 0 Then
SendMessage Me.hwnd, WM_COMMAND, gTMenuStruct(i).wID, 0
Exit Sub
End If
End If
Next i
ErrLabel:
End Sub
Private Sub LoAddMenuBmp(fTMenuStruct As MenuStruct)
If miPicIndex > 0 Then
Load picMainTemp(miPicIndex)
End If
With picMainTemp(miPicIndex)
.Picture = gclsCommon.CBNGetImageList.ListImages(fTMenuStruct.sBmpKey).Picture
'要对 picMainTemp(miPicIndex) 的背景颜色进行处理，而该图形 _
的背景色为按纽表面的颜色，因为在WinXP下必须为菜单的 _
背景色，但是如果将菜单的背景色处理为按纽表面的颜色， _
则所有的未注册菜单都要处理
gclsInclude.MyReplacePicColor .hDC, _
.Width, _
.Height, _
vbButtonFace, _
vbMenuBar
End With
With fTMenuStruct
gclsInclude.MyRegisterMenu .hParent, _
.lPos, _
.bEnabled, _
Me.hwnd, _
.Caption, _
.wID, _
picMainTemp(miPicIndex), _
.lSelectColor, _
.lTextColor
miPicIndex = miPicIndex + 1
End With
End Sub
Private Sub DoMnuCommand(wParam As Long, Optional fsMenu As String)
Dim i As Integer
Dim n As Integer
Dim lRet As Long
Dim sFileName As String
Dim TSetupForm As SetupForm
Dim sFields As String
Dim iRet As Integer
Dim sRet As String
Dim bCanExit As Boolean
If fsMenu = "" Then
For i = 0 To UBound(gTMenuStruct)
If gTMenuStruct(i).wID = wParam Then
fsMenu = gTMenuStruct(i).sVBName
Exit For
End If
Next i
If fsMenu = "" Then Exit Sub
End If
Select Case fsMenu
#If APPLICATION_TYPE = 3 Then '巡更
Case "mnuDispPatrol"
' frmPatrolNodeSetup.Show IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
With TSetupForm
.sCaption = "巡更员卡设置"
.sTable = "T3003A001"
.sFields = "A0189,A0199"
.bHaveID = True
CloseOtherWindows "frmPubData"
If gclsCommon.CBNShowPubData(TSetupForm, vbModal) Then
End If
End With
Case "mnuPatrolNodeSetup"
' frmPatrolNodeSetup.Show IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
With TSetupForm
.sCaption = "巡更网点设置"
.sTable = "T3001S001"
.sFields = "W1026,W3001,W3002"
.bHaveID = True
CloseOtherWindows "frmPubData"
If gclsCommon.CBNShowPubData(TSetupForm, vbModal) Then
End If
End With
Case "mnuPatrolClassTime"
With TSetupForm
' frmPatrolNodeSetup.Show IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
.sCaption = "巡更班次设置"
.sTable = "T3002S001"
.sFields = "W0011,W0021,W3003"
.bHaveID = True
CloseOtherWindows "frmPubData"
If gclsCommon.CBNShowPubData(TSetupForm, vbModal) Then
End If
End With
Case "mnuPatrolCalculate"
frmPubCalculate.Show IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
Case "mnuPatrolDispose"
frmPatrolTask.Show IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
Case "mnuDeviceSetup"
If gclsCommon.CBNIsJSType(gTAppLicInfo.DevMainType) Then
frmPubCommTest.Show IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
End If
Case "mnuPatrolRecord" '巡更提取记录程序
LoRunExtend
Case "mnuPatrolRecordReport" '巡更日报表
LoShowRptSelect RPT_DAY1
Case "mnuPatrolClassPlan" '巡更班次安排
frmPatrolClassPlan.Show IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
#ElseIf APPLICATION_TYPE = 1 Then '考勤
Case "mnuDNWhite"
If gTAppLicInfo.DevMainType = DEV_SYRIS_CONTROL Or gTAppLicInfo.DevMainType = DEV_DAS_ATTEND Or _
gTAppLicInfo.DevMainType = DEV_DAS_GATE Then
CloseOtherWindows "frmPubDNName"
gclsCommon.CBNShowDNName IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
Else
CloseOtherWindows "frmPubDownloadName"
gclsCommon.CBNShowDownloadName IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
End If
Case "mnuRemoveControl"
If gclsDBFunc.dbRecordCounts("T0105S001", gDBRecordConn, "W1032='" & gTAppLicInfo.SysClient & "'") = 0 Then
MsgBox "系统找不到上位机信息,请先添加上位机设备", vbExclamation
Else
frmPubRemoveControl.Show IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
End If
Case "mnuDeviceSetup"
If gclsCommon.CBNIsJSType(gTAppLicInfo.DevMainType) Then
Else
CloseOtherWindows "frmPubDeviceSet"
gclsCommon.CBNShowDeviceSet IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
End If
Case "mnuCardManage"
CloseOtherWindows "frmPubCardManage"
gclsCommon.CBNShowCardManage gTPickStruct.TempEmp, IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
Case "mnuPickData"
If gTAppLicInfo.DevMainType = DEV_DAS_ATTEND Or gTAppLicInfo.DevMainType = DEV_SYRIS_CONTROL Then
CloseOtherWindows "frmPubBNPickData"
gclsCommon.CBNShowBNPickData IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
Else
LoRunExtend
End If
Case "mnuCardDetail"
With frmPubCardDetail
.pbAttRptGroup = gTAttendCtl.AttRptGroup
.pbSpecCard = gTAttendCtl.SpecCard
.Show IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
End With
#ElseIf APPLICATION_TYPE = 11 Then '称重
Case "mnuMonitor"
frmMonitor.Show 'IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
Case "mnuInportOldData"
sFileName = gclsInclude.MyGetFileName(True, _
"旧数据库文件 (*.mdb)|*.mdb", _
"mdb", _
"", _
"打开旧数据库文件", _
Me.hwnd)
If sFileName = "" Then Exit Sub
UpdateFromOldDatabase sFileName
#ElseIf APPLICATION_TYPE = 13 Then '称重
Case "mnuMeterage"
frmAppMain.Show ' IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
Case "mnuClientControl" '显示控制客户端的设置
Call gclsCommon.CBNShowClient(gTAixSystemParament)
#End If
Case "mnuHistory"
CloseOtherWindows "frmHistory"
gclsCommon.CBNShowHistory
Case "mnuDeviceReport"
CloseOtherWindows
LoShowReport "rptPubDeviceReport", _
"SELECT * FROM QT0102S001_001", _
0
Case "mnuHostManager"
With TSetupForm
.sCaption = "上位机管理"
.sTable = "T0105S001"
.sFields = "W1027,W1032"
.bHaveID = True
CloseOtherWindows "frmPubData"
If gclsCommon.CBNShowPubData(TSetupForm, vbModal) Then
End If
End With
Case "mnuQuery"
If Not (gTAppLicInfo.SysLoginSA Or gTAppLicInfo.SysLoginSYS) Then
If gTOperRight.QueryTables = "" Then
MsgBox "用户没有操作此查询的权限!请向管理员申请", vbCritical
Exit Sub
End If
End If
CloseOtherWindows "frmPubHighQuery"
gclsCommon.CBNShowHighQuery
Case "mnuReLogin"
tmrChecker.Enabled = False
mbIsLogin = True
#If USERMESSAGEBLAST Then
MsgBlaster1.Enabled = False
#End If
sRet = ShowLogin()
If sRet = "1" Then
DoEvents
If gTAppLicInfo.CtrlMenuBmp Then gclsInclude.MyFreeMenus
Form_Load
ElseIf sRet = "0" Then
MsgBox "身份验证错误", vbCritical
End If
#If USERMESSAGEBLAST Then
MsgBlaster1.Enabled = True
#End If
tmrChecker.Enabled = True
mbIsLogin = False
Case "mnuSystemSetup"
frmPubSystemSetup.Show IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
Case "mnuTime"
If (gTAppLicInfo.SoftSQLServer = gTAppLicInfo.SoftHostName) Or Not gTAppLicInfo.SoftNetwork Then
If MsgBox(" 注意:在修改了系统时间后,如果希望新的时间生效,须重新启动本程序!", vbInformation + vbOKCancel) = vbOK Then
gclsCommon.CBNControlPanels "timedate"
End If
Else
If gTAppLicInfo.SoftNetwork Then
MsgBox " 你无权修改服务器时间,如果时间错误,请联系系统管理员在服务器上修改!", vbCritical
End If
End If
Case "mnuUpdate"
sFileName = gclsInclude.MyGetFileName(True, _
"升级文件 (*.upt)|*.upt", _
"upt", _
gTAppLicInfo.FilePathApp & "Update.upt", _
"打开升级文件", _
Me.hwnd)
If sFileName <> "" Then
If gclsCommon.CBNDataUpdate(sFileName, gTAppLicInfo.SysDBRecordConn) Then
MsgBox "升级完毕,请重新启动系统"
gTAppLicInfo.CtrlUnload = True
Else
MsgBox "升级失败!", vbCritical
End If
' Else
' MsgBox "未发现升级文件", vbExclamation
End If
Case "mnuAppendData"
If gTAppLicInfo.SysLockCal And Not gTAppLicInfo.SysLoginSA Then
MsgBox "功能暂时锁定", vbCritical: Exit Sub
End If
gTAppLicInfo.CtrlOutSlow = True
Select Case gclsCommon.CBNResumeMilieu(True)
Case -1
MsgBox "恢复过程中,产生错误,详情参见LOG文件", vbInformation
Case 1
If MsgBox("系统数据已成功恢复,如果想使数据有效,请按确定退出本系统.", _
vbOKCancel, "数据恢复") = vbOK Then _
gTAppLicInfo.CtrlUnload = True
Case 3
MsgBox "恢复过程中被用户终止!", vbExclamation
Case 0
MsgBox "恢复失败!", vbCritical
End Select
Case "mnuResumeMilieu"
If gTAppLicInfo.SysLockCal And Not gTAppLicInfo.SysLoginSA Then
MsgBox "功能暂时锁定", vbCritical: Exit Sub
End If
gbErrLog = False
gTAppLicInfo.CtrlOutSlow = True
'1:成功恢复
'0:失败
'-1:有错误记录
'2:用户退出
'3:用户制止
Select Case gclsCommon.CBNResumeMilieu(False)
Case -1
MsgBox "恢复过程中,产生错误,详情参见LOG文件", vbInformation
Case 1
If MsgBox("系统数据已成功恢复,如果想使数据有效,请按确定退出本系统.", _
vbOKCancel, "数据恢复") = vbOK Then gTAppLicInfo.CtrlUnload = True
Case 3
MsgBox "恢复过程中被用户终止!", vbExclamation
Case 0
MsgBox "恢复失败!", vbCritical
End Select
Case "mnuSaveDelete"
If MsgBox("本操作将在保存数据后删除库中数据,可能会造成系统无法运行,按取消退出!", _
vbOKCancel + vbExclamation) = vbCancel Then Exit Sub
gTAppLicInfo.CtrlOutSlow = True
CloseOtherWindows "frmPubBackup"
Select Case gclsCommon.CBNShowBackup(True)
Case -1
MsgBox "备份过程中,产生错误,详情参见LOG文件", vbInformation
Case 1
MsgBox "系统数据已成功备份!", vbInformation
Case 3
MsgBox "备份过程中被用户终止!", vbExclamation
Case 0
MsgBox "备份失败!", vbCritical
End Select
Case "mnuSaveMilieu"
'1:成功恢复
'0:失败
'-1:有错误记录
'2:用户退出
'3:用户制止
gTAppLicInfo.CtrlOutSlow = True
CloseOtherWindows "frmPubBackup"
Select Case gclsCommon.CBNShowBackup(False)
Case -1
MsgBox "备份过程中,产生错误,详情参见LOG文件", vbInformation
Case 1
MsgBox "系统数据已成功备份!", vbInformation
Case 3
MsgBox "备份过程中被用户终止!", vbExclamation
Case 0
MsgBox "备份失败!", vbCritical
End Select
Case "mnuShowTools"
i = LoGetMenuIndex("mnuShowTools")
If i <> -1 Then
gTMenuStruct(i).bChecked = Not gTMenuStruct(i).bChecked
gclsInclude.MySetMenuChecked Me.hwnd, gTMenuStruct(i).Child, gTMenuStruct(i).bChecked, gTMenuStruct(i).wID
End If
Picture1.Visible = gTMenuStruct(i).bChecked
Case "mnuDevManage"
' 置鼠标忙标志
Screen.MousePointer = vbHourglass
ReDim TGridFormat(9) As GridFormat
TGridFormat(0).sField = "W1007"
TGridFormat(1).sField = "W1003"
TGridFormat(2).sField = "W1001"
TGridFormat(3).sField = "W1020"
TGridFormat(4).sField = "W1000"
TGridFormat(5).sField = "W1022"
TGridFormat(6).sField = "W1025"
TGridFormat(7).sField = "W1026"
TGridFormat(8).sField = "W1023"
TGridFormat(9).sField = "W1024"
TGridFormat(1).sFormat = "Boolean,禁用,-,-"
TGridFormat(3).sFormat = "Format,>COM"
CloseOtherWindows "frmPubDevice"
gclsCommon.CBNShowDeviceForm TGridFormat
Screen.MousePointer = vbDefault
Case "mnuDeptEmp"
If gTOperRight.DeptRight = "" And Not (gTAppLicInfo.SysLoginSA Or gTAppLicInfo.SysLoginSYS) Then
MsgBox "用户没有部门管理的权限!请向管理员申请", vbCritical
Exit Sub
End If
#If APPLICATION_TYPE = 11 Then '称重
'0195, edbText, 1 '是否发卡
'0197, edbText, 1 '是否黑名单
'0199, edbText, 20 '卡管理号
'0101, edbText, 30 '车辆名称
'0189, edbText '车号,相当于A0189
'0190, edbText '车辆卡号
'0111, edbDate '车辆生产日期
'0177, edbText, 18 '驾驶证号
'0188, edbText, 1 '是否报废
'W1119, edbText, 1 '是否选择
'W4025, edbText '车类
'W8201, edbSingle '自重
'W8204, edbSingle '最大载重
ReDim TGridFormat(4) As GridFormat
TGridFormat(0).sField = "P0189"
TGridFormat(1).sField = "P0190"
TGridFormat(2).sField = "W4025"
TGridFormat(3).sField = "W8201"
TGridFormat(4).sField = "W8204"
With gTAppManageType
.Code = "P0189" '工号
.Dept = "E0122" '部门(小类管理)
.DeptCode = "UM"
.DeptTable = "T0015S002"
.Desc = "车辆"
.InnerCode = "P0100"
.Kind = "P001"
.Name = "P0101"
.Type = "P001"
.Unit = "B0110"
.UnitCode = "UN"
End With
#Else
ReDim TGridFormat(7) As GridFormat
TGridFormat(0).sField = "A0189"
TGridFormat(1).sField = "A0101"
TGridFormat(2).sField = "A0195"
TGridFormat(3).sField = "A0107" '性别代码
TGridFormat(4).sField = "A0111"
TGridFormat(5).sField = "A0177"
TGridFormat(6).sField = "A0199"
TGridFormat(7).sField = "A0187"
With gTAppManageType
.Code = "A0189" '工号
.Dept = "E0122" '部门(小类管理)
.DeptCode = "UM"
.DeptTable = "T0015S001"
.Desc = "人员"
.InnerCode = "A0100"
.Kind = "A001" '人员管理
.Name = "A0101" '相对于Code的名称
.Type = "A001" '在职人员
.Unit = "B0110" '单位(大类管理)
.UnitCode = "UN"
End With
#End If
CloseOtherWindows "frmDeptSetup"
gclsCommon.CommonAppManageType = gTAppManageType
gclsCommon.CBNShowDeptForm TGridFormat, True
Case "mnuHelpAbout"
gclsInclude.MyShowAbout gTAppLicInfo
Case "mnuExit"
Unload Me
Case "mnuChangePwd"
CloseOtherWindows "frmChangePwd"
gclsCommon.CBNShowChangePwd
Case "mnuOperManage"
CloseOtherWindows "frmOperator"
gclsCommon.CBNShowOperator True
'************************************ 考勤特有部分 **************************************
'*
#If APPLICATION_TYPE = 1 Then '考勤
Case "mnuEmpSpecCard"
LoShowRptSelect RPT_SPECCARD
Case "mnuAttendRetouch"
If gTAppLicInfo.SysLockCal And Not gTAppLicInfo.SysLoginSA Then
MsgBox "功能暂时锁定", vbCritical: Exit Sub
End If
frmWkTmRetouch.Show IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
Case "mnuAttendObnormal"
If gTAppLicInfo.SysLockCal And Not gTAppLicInfo.SysLoginSA Then
MsgBox "功能暂时锁定", vbCritical: Exit Sub
End If
frmWkTmCalcute.pbFlag = True
frmWkTmCalcute.Show IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
Case "mnuAttendCal"
If gTAppLicInfo.SysLockCal And Not gTAppLicInfo.SysLoginSA Then
MsgBox "功能暂时锁定", vbCritical: Exit Sub
End If
frmWkTmCalcute.pbFlag = False
frmWkTmCalcute.Show IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
Case "mnuCardTotal"
If gTAppLicInfo.SysLockCal And Not gTAppLicInfo.SysLoginSA Then
MsgBox "功能暂时锁定", vbCritical: Exit Sub
End If
frmCardTotal.Show IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
Case "mnuCheckData"
If gTAppLicInfo.SysLockCal And Not gTAppLicInfo.SysLoginSA Then
MsgBox "功能暂时锁定", vbCritical: Exit Sub
End If
frmPubCheckData.Show IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
Case "mnuDeptAdjust"
LoShowAttendSetup DEPT_ADJUST
Case "mnuWorkAddPlan"
LoShowAttendSetup ADD_PLAN
Case "mnuWorkAdjust"
LoShowAttendSetup WORK_ADJUST
Case "mnuClassPlan"
gTClassDef = gclsCommon.CBNGetValidClass(gTAttendCtl.Use1CardRange)
If gclsCommon.CBNIsEmpty(VarPtrArray(gTClassDef)) Then
If MsgBox(" 系统未定义任何班次,在排班之前,请首先定义班次." & vbCrLf & "是否进行班次设置？", _
vbQuestion + vbDefaultButton2 + vbYesNo) = vbYes Then
DoMnuCommand 0, "mnuWkTmSet"
End If
Else
CloseOtherWindows "frmPlanClass"
gclsCommon.CBNShowPlanClass gTPickStruct.TempNameLists, _
gTPickStruct.TempNumberLists, _
IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
End If
Case "mnuHoliday"
frmRestSetup.Show IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
Case "mnuEmpWkTm"
LoShowRptSelect RPT_ATTEND
Case "mnuHolidayRpt"
LoShowRptSelect RPT_HOLIDAY
Case "mnuClassSwitch"
LoShowRptSelect RPT_SWITCH
Case "mnuMonth1"
LoShowRptSelect RPT_DAY1
Case "mnuEmpWkTmSet"
' If gclsDBFunc.dbRecordCounts("T6651S001", gDBRecordConn, "W0090 <> 'WC') = 0 Then
gTClassDef = gclsCommon.CBNGetValidClass(gTAttendCtl.Use1CardRange)
If gclsCommon.CBNIsEmpty(VarPtrArray(gTClassDef)) Then
If MsgBox(" 系统未定义任何班次,在排班之前,请首先定义班次." & vbCrLf & "是否进行班次设置？", _
vbQuestion + vbDefaultButton2 + vbYesNo) = vbYes Then
DoMnuCommand 0, "mnuWkTmSet"
End If
Else
LoShowAttendSetup CLASS_PLAN '排班
End If
Case "mnuHolidayInput"
LoShowAttendSetup HOLIDAY_PLAN '请假
Case "mnuSignCard"
LoShowAttendSetup SIGN_CARD '手工签卡
Case "mnuClassChange"
LoShowAttendSetup CLASS_SWITCH '班次调换
Case "mnuAssignAttend"
LoShowAttendSetup ASSIGN_ATTEND '指定考勤
Case "mnuDevRight"
LoShowAttendSetup DEVICE_RIGHT '人员打卡权限
Case "mnuEmpWkTmQuery"
frmEmpWkTmQuery.Show IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
Case "mnuHoliSystem"
With TSetupForm
.sCaption = "假类管理"
.sTreeGroupStr = "W6673=0-无工时假,1-有工时假" '分组标志
.sTreeSortStr = "W6671"
.sTreeDescStr = "DESC=W6676,KEY=W6671"
.sTable = "T0118S001"
'假类代码,排假索引,是否有工时,工时比率,最大请假时数,请假描述,排班颜色,排班代码
.sFields = "W6670,W6671,W6672,W6673,W6674,W6675,W6676,W6680,W6681"
.sModify = ",1,1,,,,,,1"
.sCtrlType = "CHKBOX,,,CHKBOX,,,,COLOR,"
.bHaveID = True
CloseOtherWindows "frmPubSetup"
If gclsCommon.CBNShowPubSetup(TSetupForm, vbModal) Then '如果发生改变
gTHoliSystem = gclsCommon.CBNGetHolidayInfo(True And (giUpdate > 0))
gclsCommon.CBNSaveEvents OET_MDF_HOLIDAYKIND
End If
End With
Case "mnuSystem"
frmAttendSystem.Show IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
Case "mnuWkTmSet"
If Not (gTAppLicInfo.SysLoginSA Or gTAppLicInfo.SysLoginSYS) Then
If Len(gTOperRight.ClassRange) = 0 Then
MsgBox "本操作员无此项操作权限,请向管理员申请", vbCritical
Exit Sub
End If
End If
frmWorkTimeSet.Show IIf(gTAppLicInfo.CtrlRunSingle, vbModal, vbModeless)
#End If
'*
'************************************ 考勤特有部分结束 **************************************
Case Else
If fsMenu Like "mnuProgram#" Or fsMenu Like "mnuProgram##" Then
If gclsInclude.MyFileExists(gTMenuStruct(i).ButtonCaption) Then
If gclsInclude.MyRunProgram(gTMenuStruct(i).ButtonCaption) < 100 Then
MsgBox "程序" & gclsInclude.MyFileName(gTMenuStruct(i).ButtonCaption) & "运行失败", vbCritical
End If
Else
MsgBox "程序" & gclsInclude.MyFileName(gTMenuStruct(i).ButtonCaption) & "不存在", vbCritical
End If
End If
End Select
End Sub
'******************************* 考勤专用开始 ***********************************
'*
#If APPLICATION_TYPE = 1 Then
Private Sub LoShowAttendSetup(fiMode As RUN_MODE)
Dim frmTemp As Form
If gTAppLicInfo.CtrlRunSingle Then
frmEmpAttendSetup.piMode = fiMode
frmEmpAttendSetup.Show vbModal
Else
If LoTheFormIsRun("frmEmpAttendSetup", fiMode) Then
MsgBox "本窗体已运行!"
Exit Sub
End If
Set frmTemp = New frmEmpAttendSetup
frmTemp.piMode = fiMode
frmTemp.Show
End If
End Sub
#End If
'*
'***************************** 考勤专用结束 ***********************************
#If APPLICATION_TYPE = 1 Or APPLICATION_TYPE = 3 Then '考勤或巡更
Private Sub LoShowRptSelect(fiMode As RUN_MODE)
Dim frmTemp As Form
If gTAppLicInfo.CtrlRunSingle Then
frmRptSelect.piMode = fiMode
frmRptSelect.Show vbModal
Else
If LoTheFormIsRun("frmRptSelect", fiMode) Then
MsgBox "本窗体已运行!"
Exit Sub
End If
Set frmTemp = New frmRptSelect
frmTemp.piMode = fiMode
frmTemp.Show
End If
End Sub
#End If
Private Function LoTheFormIsRun(fsForm As String, Optional fiMode As RUN_MODE) As Boolean
Dim frmTemp As Form
For Each frmTemp In Forms
With frmTemp
If UCase(.Name) = UCase(fsForm) Then
If (UCase(.Name) = UCase("frmEmpAttendSetup")) Or _
(UCase(.Name) = UCase("frmRptSelect")) Then
If .piMode = fiMode Then
LoTheFormIsRun = True
Exit Function
End If
Else
LoTheFormIsRun = True
End If
End If
End With
Next
End Function
Private Sub LoRunExtend()
Dim sFileName As String
If gclsInclude.MyIsRun(gTAppLicInfo.DevMainName & "记录提取") Then
MsgBox "自动提取程序正在运行", vbCritical
Exit Sub
Else
sFileName = gTAppLicInfo.FilePathApp & "AutoDownload.exe"
End If
If gclsInclude.MyFileExists(sFileName) Then
sFileName = sFileName & "|" & gTAppLicInfo.SoftSQLServer & "," & gTAppLicInfo.SysLoginUser & "," & gTAppLicInfo.SysLoginPwd
If gclsInclude.MyRunProgram(sFileName) Then
MsgBox "自动提取程序已经打开,请双击右下角图标设置运行参数", vbExclamation
Else
MsgBox "自动提取程序运行失败", vbCritical
End If
Else
MsgBox "未发现自动提取程序,请从安装盘上重新安装该程序.", vbExclamation
End If
End Sub
Private Sub LoInitMenu()
Dim i As Integer
Dim n As Integer
Dim sSQL As String
Dim bTemp As Boolean
mbResizeDis = True
If Not gclsCommon.CBNIsEmpty(VarPtrArray(gTMenuStruct)) Then
gclsInclude.MyDeleteAllMenu Me.hwnd
Erase gTMenuStruct
End If
For i = 2 To lblButton.UBound
Unload lblButton(i)
Next i
miPicIndex = 0
For i = 1 To picMainTemp.UBound
Unload picMainTemp(i)
Next i
With gTAppLicInfo
If .CtrlMenuBmp Then gclsInclude.MyFreeMenus
Set madoMenuRS = gclsCommon.CBNLoadMenuInfo(gTMenuStruct, mbNoVisible)
i = LoGetMenuIndex("mnuShowTools")
If i <> -1 Then gTMenuStruct(i).bChecked = .CtrlBoardShow
If (.DevMainType = DEV_SYRIS_CONTROL) Or _
(.DevMainType = DEV_DAS_GATE) Or _
(.DevMainType = DEV_DAS_ATTEND) Then
Else
LoHideMenu "mnuDNWhite"
End If
LoHideMenu "mnuProgram"
If .DevMainType <> DEV_DAS_ATTEND And .DevMainType <> DEV_DAS_GATE Then
LoHideMenu "mnuDevRight"
End If
If Not .CtrlNeedHelp Then
LoHideMenu "mnuHelp"
cmdAbout.Visible = False
lblMailto.Visible = False
End If
If Not gclsInclude.MyFileExists(.FilePicBoard) Then
LoHideMenu "mnuShowTools"
End If
If .DevMainType = DEV_DWCF_ATTEND Then LoHideMenu "mnuDeviceSetup"
#If APPLICATION_TYPE = 1 Then '考勤
If Not gTAttendCtl.SpecCard Then
LoHideMenu "mnuEmpSpecCard"
End If
#End If
'加入外挂程序清单
n = 0
i = funcGetINIData("System Settings", "CountPrograms", 0)
If i > 0 Then
ReDim .FileExName(1 To i)
ReDim .FileExDesc(1 To i)
For i = 1 To UBound(.FileExName)
.FileExName(i) = funcGetINIData("System Settings", "Program" & i, "")
.FileExDesc(i) = funcGetINIData("System Settings", "ProgramDesc" & i, "")
If .FileExName(i) <> "" Then
If UCase(gclsInclude.MyFileName(.FileExName(i))) <> UCase(App.EXEName) Then
If gclsInclude.MyFileExists(.FileExName(i)) Then
n = n + 1
LoSetMenuData "mnuProgram", _
n, _
IIf(.FileExDesc(i) = "", "外挂程序" & n, .FileExDesc(i)), _
.FileExName(i), _
True, _
True
End If
End If
End If
Next i
End If
gclsInclude.MyGetValidMenuStruct gTMenuStruct
gclsCommon.CBNInitToolbar BNToolbar1, gTMenuStruct
For i = 0 To UBound(gTMenuStruct)
If gTMenuStruct(i).wID <> -1 Then
gTMenuStruct(i).wID = glMsgAdd + gTMenuStruct(i).wID
End If
Next i
Me.Controls("XXX").Visible = False
gclsInclude.MyCreateMenu Me.hwnd, gTMenuStruct
i = LoGetMenuIndex("mnuExit")
If i = -1 Then
mbCanExit = False
Else
mbCanExit = gTMenuStruct(i).bEnabled
End If
'加载按纽
With lblButton(1)
.MousePointer = vbCustom
.BackColor = gTAppLicInfo.SoftMainColor
.ForeColor = vbWhite
Set .MouseIcon = DFNLoadResPicture(101, vbResCursor)
End With
Set madoCtrlRS = New ADODB.Recordset
madoCtrlRS.Open "SELECT COUNT(W0090) AS COUNT_W0090 FROM T0114S001 WHERE (W1124 = '1') AND (W1121 <> '-') AND (W1158 = " & _
.SysAppType & ") GROUP BY W0090 ORDER BY COUNT(W0090)", _
gDBRecordConn, adOpenForwardOnly, adLockReadOnly
With madoCtrlRS
If .RecordCount > 0 Then
.MoveLast
n = !COUNT_W0090
n = (4855 - lblButton(1).Top + lblButton(1).Height) \ n
If n < lblButton(1).Height + 20 Then n = lblButton(1).Height + 20
If !COUNT_W0090 > 1 Then
For i = 2 To !COUNT_W0090
Load lblButton(i)
lblButton(i).Move lblButton(1).Left, lblButton(i - 1).Top + n
Next i
End If
End If
.Close
End With
'如果需要图形菜单
If .CtrlMenuBmp Then
For i = 0 To UBound(gTMenuStruct)
If gTMenuStruct(i).sBmpKey <> "" Then
bTemp = False
For n = 1 To gclsCommon.CBNGetImageList.ListImages.Count
If gclsCommon.CBNGetImageList.ListImages(n).Key = gTMenuStruct(i).sBmpKey Then
bTemp = True
Exit For
End If
Next n
If Not bTemp Then
gTMenuStruct(n).sBmpKey = ""
End If
End If
Next i
End If
End With
mbResizeDis = False
End Sub
Private Sub LoShowReport(fsRptName As String, _
fsSQL As String, _
PaplePos As Integer, _
Optional fsCaption As String, _
Optional fsTimeRange As String, _
Optional RS As ADODB.Recordset, _
Optional fbPrintDirect As Boolean)
Dim adoTempRS As ADODB.Recordset
Dim l As Long
Dim rRpt
If fsSQL <> "" Then
Set adoTempRS = New ADODB.Recordset
adoTempRS.Open fsSQL, _
gDBRecordConn, _
adOpenForwardOnly, _
adLockReadOnly
Else
Set adoTempRS = RS
End If
If adoTempRS.RecordCount = 0 Then
MsgBox "库中无记录", vbInformation, Me.Caption
Screen.MousePointer = vbDefault
GoTo ExitSub
End If
If Not SetPrintPaple(PaplePos) Then Exit Sub
Select Case fsRptName
#If APPLICATION_TYPE = 4 Then '停车
Case "rptCarInReport"
Set rRpt = New rptCarInReport
Set rptCarInReport = Nothing
Case "rptCarReport"
Set rRpt = New rptCarReport
Set rptCarReport = Nothing
Case "rptMoneyReport"
Set rRpt = New rptMoneyReport
Set rptMoneyReport = Nothing
Case "rptChargeReport"
Set rRpt = New rptChargeReport
Set rptChargeReport = Nothing
Case "rptMoneyMonthReport"
Set rRpt = New rptMoneyMonthReport
Set rptMoneyMonthReport = Nothing
Case "rptPubManReport"
Set rRpt = New rptPubManReport
Set rptPubManReport = Nothing
Case "rptPubOtherReport"
Set rRpt = rptPubOtherReport
Set rptPubOtherReport = Nothing
Case "rptUserReport"
Set rRpt = New rptUserReport
Set rptUserReport = Nothing
#End If
Case "rptPubDeviceReport"
Set rRpt = New rptPubDeviceReport
Set rptPubDeviceReport = Nothing
End Select
With rRpt
Set .DataSource = adoTempRS
If fsTimeRange <> "" Then
.Sections(2).Controls("lblDate").Caption = fsTimeRange
End If
If fsCaption <> "" Then .Sections("ReportHeader").Controls("lblCaption").Caption = fsCaption
For l = 1 To 10: DoEvents: Next l
.Hide
For l = 1 To 10: DoEvents: Next l
.Show
For l = 1 To 10: DoEvents: Next l
If fbPrintDirect Then .PrintReport
End With
ExitSub:
' Set adoTempRS = Nothing
End Sub