📄 frmmain.frm
字号:
Interval = 100
Left = 9600
Top = 120
End
Begin VB.Frame Frame2
Caption = "Recent Deliveries:"
Height = 3135
Left = 4920
TabIndex = 0
Top = 1080
Width = 6735
Begin MSComctlLib.ListView lvDeliveries
Height = 2775
Left = 120
TabIndex = 1
Top = 240
Width = 6495
_ExtentX = 11456
_ExtentY = 4895
View = 3
LabelEdit = 1
LabelWrap = -1 'True
HideSelection = -1 'True
FullRowSelect = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
Appearance = 1
NumItems = 0
End
End
Begin MSComDlg.CommonDialog cDialog
Left = 10080
Top = 120
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.Frame frmTick
BackColor = &H00FF8080&
BorderStyle = 0 'None
Caption = "News:"
Height = 975
Left = 0
TabIndex = 6
Top = 0
Width = 9495
Begin VB.Label lblTicker
BackStyle = 0 'Transparent
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00E0E0E0&
Height = 615
Index = 0
Left = 120
TabIndex = 7
Top = 360
Width = 9255
WordWrap = -1 'True
End
End
Begin VB.Label lblWelcome
BackStyle = 0 'Transparent
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 255
Left = 240
TabIndex = 8
Top = 1200
Width = 3135
End
Begin VB.Shape bgWelcome
BackColor = &H00404040&
BackStyle = 1 'Opaque
BorderStyle = 0 'Transparent
Height = 4935
Left = 0
Top = 960
Width = 4815
End
Begin VB.Menu mnu_Main_Options
Caption = "&Options"
Begin VB.Menu mnu_Options_Refresh
Caption = "&Refresh Recent Deliveries"
Shortcut = {F5}
End
Begin VB.Menu mnu_Option_Password
Caption = "&Change Password"
End
Begin VB.Menu mnu_Bar_12
Caption = "-"
End
Begin VB.Menu mnu_Personal_Ticker
Caption = "&Add Personal Ticker"
End
Begin VB.Menu mnu_Manage_Ticker
Caption = "&Manage My Tickers..."
End
Begin VB.Menu mnu_Bar_05
Caption = "-"
End
Begin VB.Menu mnu_Options_Quit
Caption = "&Exit"
Shortcut = ^Q
End
End
Begin VB.Menu mnu_Main_Admin
Caption = "&Admin"
Begin VB.Menu mnu_Admin_Database
Caption = "&Database"
Begin VB.Menu mnu_Database_Backup
Caption = "&Backup"
End
Begin VB.Menu mnu_Database_Restore
Caption = "&Restore"
End
End
Begin VB.Menu mnu_Bar_02
Caption = "-"
End
Begin VB.Menu mnu_Admin_Users
Caption = "&Users"
Shortcut = ^U
End
Begin VB.Menu mnu_Bar_03
Caption = "-"
End
Begin VB.Menu mnu_Admin_Settings
Caption = "Se&ttings..."
End
Begin VB.Menu mnu_Admin_SQL
Caption = "&SQL Console"
End
Begin VB.Menu mnu_Admin_Logs
Caption = "&View Logs"
End
Begin VB.Menu mnu_Bar_11
Caption = "-"
End
Begin VB.Menu mnu_Add_PublicTicker
Caption = "&Add Public Ticker"
End
End
Begin VB.Menu mnu_Admin_Maintenance
Caption = "&Maintenance"
Begin VB.Menu mnu_Maintenance_Countries
Caption = "&Countries"
End
Begin VB.Menu mnu_Maintenance_States
Caption = "&States"
End
Begin VB.Menu mnu_Maintenance_Cities
Caption = "C&ities"
End
End
Begin VB.Menu mnu_Main_Receivable
Caption = "&Accounts Receivable"
Begin VB.Menu mnu_Receivable_Add
Caption = "&Add New Customer"
End
Begin VB.Menu mnu_Receivable_Customers
Caption = "&Customers..."
Shortcut = ^C
End
Begin VB.Menu mnu_Bar_01
Caption = "-"
End
Begin VB.Menu mnu_Receivable_View
Caption = "&View Delivery Orders"
End
End
Begin VB.Menu mnu_Main_Payable
Caption = "Accounts &Payable"
Begin VB.Menu mnu_Payable_Add
Caption = "&Add New Supplier"
End
Begin VB.Menu mnu_Payable_Suppliers
Caption = "&Suppliers..."
Shortcut = ^S
End
Begin VB.Menu mnu_Bar_06
Caption = "-"
End
Begin VB.Menu mnu_Payable_View
Caption = "&View Purchase Orders"
End
End
Begin VB.Menu mnu_Main_Employees
Caption = "&Human Resource"
Begin VB.Menu mnu_Human_Employees
Caption = "&Employees..."
Shortcut = ^E
End
Begin VB.Menu mnu_Bar_07
Caption = "-"
End
Begin VB.Menu mnu_Human_Payrol
Caption = "&New Payroll"
End
Begin VB.Menu mnu_Bar_08
Caption = "-"
End
Begin VB.Menu mnu_Human_Leave
Caption = "&Apply For Leave"
End
Begin VB.Menu mnu_Human_Browse
Caption = "&Browse Leaves"
End
End
Begin VB.Menu mnu_Main_Inventory
Caption = "&Inventory"
Begin VB.Menu mnu_Inventory_Browse
Caption = "&Browse Inventory"
Shortcut = ^I
End
Begin VB.Menu mnu_Bar_04
Caption = "-"
End
Begin VB.Menu mnu_Inventory_Categories
Caption = "Categories..."
End
Begin VB.Menu mnu_Bar_09
Caption = "-"
End
Begin VB.Menu mnu_Inventory_Contracts
Caption = "&Consignment Contracts"
End
Begin VB.Menu mnu_Inventory_View
Caption = "Browse Consignment Inventory..."
Begin VB.Menu mnu_Contracts
Caption = "--{NONE}--"
Index = 0
End
End
Begin VB.Menu mnu_Bar_13
Caption = "-"
End
Begin VB.Menu mnu_Receivable_Delivery
Caption = "&New Delivery Order"
Shortcut = ^D
End
Begin VB.Menu mnu_Payable_Order
Caption = "&New Purchase Order"
Shortcut = ^P
End
End
Begin VB.Menu mnu_Main_Invoice
Caption = "&Invoicing"
Begin VB.Menu mnu_Invoicing
Caption = "&DO Received..."
End
End
Begin VB.Menu mnu_Main_Report
Caption = "&Report"
Begin VB.Menu mnu_Report_Main
Caption = "&Main Report"
Shortcut = ^R
End
End
Begin VB.Menu mnu_Main_Help
Caption = "&Help"
Begin VB.Menu mnu_Help_Help
Caption = "Help..."
End
Begin VB.Menu mnu_Bar_14
Caption = "-"
End
Begin VB.Menu mnu_Help_About
Caption = "&About..."
Shortcut = ^A
End
End
Begin VB.Menu mnu_Main_Print
Caption = "P&rint"
Visible = 0 'False
Begin VB.Menu mnu_Print_Print
Caption = "&Print..."
End
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 c As Integer
Dim prevHour As Byte
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Sub loadTicker()
Dim tickSQL As String
tickSQL = " SELECT msgTitle,msgText FROM Ticker WHERE ((username='" & CurrentUser.strUsername & "' Or username='GENERAL') AND ((dateToBeShown Is Null) Or dateToBeShown='" & Format$(Now(), "dd/mm/yyyy") & "'));"
Dim tickRS As Recordset
RSOpen tickRS, tickSQL, dbOpenSnapshot
'First load an array of labels
Dim i As Integer
'Assign recordset to labels
i = 0
While Not tickRS.EOF
On Error Resume Next
lblTicker(i).Container = frmTick
lblTicker(i).Visible = False
lblTicker(i).Caption = tickRS("msgTitle") & vbCrLf & tickRS("msgText")
i = i + 1
Load lblTicker(i)
tickRS.MoveNext
Wend
tickRS.Close
Set tickRS = Nothing
tmrTicker.Enabled = True
c = 0
End Sub
Private Sub destroyTicker()
Dim i As Integer
For i = lblTicker.LBound To lblTicker.UBound
'Suppose to free memory
If i <> 0 Then
Unload lblTicker(i)
End If
Next i
End Sub
Private Sub tickerStart()
'Starts the news ticker
'Set the first ticker visible and position on top of frame
lblTicker(c).Visible = True
lblTicker(c).Top = frmTick.height
lblTicker(c).Left = 120
tmrTicker.Enabled = True
End Sub
Private Sub tickerStop()
'Stops the news ticker
tmrTicker.Enabled = False
destroyTicker
End Sub
Private Sub moveTicker(ByVal amt As Integer)
lblTicker(c).ZOrder vbBringToFront
lblTicker(c).Visible = True
lblTicker(c).Top = lblTicker(c).Top - amt
If lblTicker(c).Top < 0 - lblTicker(c).height Then
'hide the current lbl
lblTicker(c).Visible = False
c = c + 1
If c > lblTicker.UBound Then
c = 0
End If
tickerStart
End If
End Sub
Private Sub checkAccStatus() 'Checks user for password expiry
Dim expDuration As Long
Debug.Print "User last: " & CurrentUser.lastPassword
expDuration = DateDiff("d", Now(), Format$(CurrentUser.lastPassword, "mm/dd/yyyy"))
Debug.Print "Duration: " & expDuration
If CurrentUser.mustChange = True Then
InfoMsg "Your account password has expired. You are required to change your password now.", "Password expired"
Load frmPassword
frmPassword.setFormMode = force_Change
frmPassword.Show vbModal
DoEvents
Else
If expDuration < -60 Then
ValidMsg "Your password has expired. You will be required to change your password now.", "Password expired"
Load frmPassword
frmPassword.setFormMode = force_Change
frmPassword.Show vbModal
ElseIf ((expDuration < -45) And (expDuration > -61)) Then
If MsgBox("Your password is expiring in " & expDuration & " days. Do you wish to change your password now?", vbYesNo + vbQuestion, "Password expiring") = vbYes Then
Load frmPassword
frmPassword.Show vbModal
End If
End If
End If
End Sub
Private Sub implementSystemPolicy()
'Hides or show menus based on user's privileges
With CurrentUser
If .prvlgAdmin = True Then
mnu_Main_Admin.Visible = True
users.Visible = True
Image2(users.Tag).Visible = True
Else
mnu_Main_Admin.Visible = False
users.Visible = False
Image2(users.Tag).Visible = False
End If
If .prvlgAPS = True Then
mnu_Main_Payable.Visible = True
po.Visible = True
Image2(po.Tag).Visible = True
Else
mnu_Main_Payable.Visible = False
po.Visible = False
Image2(po.Tag).Visible = False
End If
If .prvlgARS = True Then
mnu_Main_Receivable.Visible = True
mnu_Main_Invoice.Visible = True
Else
mnu_Main_Receivable.Visible = False
mnu_Main_Invoice.Visible = False
End If
If .prvlgDOS = True Then
mnu_Receivable_Delivery.Visible = True
receivables.Visible = True
Image2(receivables.Tag).Visible = True
Else
mnu_Receivable_Delivery.Visible = False
receivables.Visible = False
Image2(receivables.Tag).Visible = False
End If
If .prvlgHRS = True Then
mnu_Main_Employees.Visible = True
human.Visible = True
Image2(human.Tag).Visible = True
Else
mnu_Main_Employees.Visible = False
human.Visible = False
Image2(human.Tag).Visible = False
End If
If .prvlgReport = True Then
mnu_Main_Report.Visible = True
Else
mnu_Main_Report.Visible = False
End If
End With
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -