www.pudn.com > VB-KAOQINXITONG.zip > modMain.bas
Attribute VB_Name = "modMain"
'表示变量数据类型的前缀
'-----------------------------------------------------------
'数据类型 前缀 举例
'-----------------------------------------------------------
'Boolean(布尔值) b bLoggedIn
'Currency(货币) c cSalary
'Control(控件) ctr ctrLastControl
'Double(双精度实数) dbl dblMiles
'ErrObject(错误对象) err errLastError
'Single(单精度实数) sng sngYears
'Handle(句柄) hwnd hwndPicture
'Long(长整型数) l lOnHand
'Object(对象) o oUserTable
'Integer(整型数) i iAge
'String(字符串) s sName
'Use-definedtype(用户定义的类型) udt udtEmployee
'Variant(变码,包括日期) v vDateHired
'Array(数组) a asEmployees
'用作变量作用域的前缀
'-----------------------------------------------
'前缀 描述 举例
'-----------------------------------------------
'g 全局变量 gsSavePath
'm 模块或窗体的局部变量 mbDataChanged
'st 静态变量 stInHere
'(无前缀) 过程的非静态局部变量 iIndex
'用于标准控件的前缀
'--------------------------------------------------------------------
'控件 前缀 举例 | 控件 前缀 举例
'--------------------------------------------------------------------
'复选框 chk chkPrint | 线条 lne lneVertical
'组合框 cbo cboTitle | 列表框 lst lstResultCodes
'命令按钮 cmd cmdCancel | MDI子窗体 mdi mdiContact
'数据 dat datBiblio | 菜单 mun munFileOpen
'目录列表框 dir dirSource | OLE容器 ole olePhoto
'驱动器列表框 drv drvTarget | 选项按钮 opt optSpanish
'文件列表框 fil filSource | 面板 pnl pnlSettings
'图文框 fra fraLanguage | 图片框 pic picDiskSpace
'窗体 frm frmMain | 剪贴图 clp clpToolbar
'组按钮 gpb gpbChannel | 形状 shp shpCircle
'水平滚动条 hsb hsbVolume | 文本框 txt txtAddress
'图象 img imgIcon | 计时器 tmr tmrAlarm
'标注 lbl lblHelpMessage | 垂直滚动条 vsb vsbRate
'用于ActiveX控件的前缀
'------------------------------------------
'控件 前缀 举例
'------------------------------------------
'常用对话框 dlg dlgFileOpen
'通信 com comFax
'与数据关联的组合框 dbc dbcContacts
'网格 grd grdInventory
'与数据关联的网格 dbg dbgPrices
'与数据关联的列表框 dbl dblSalesCode
'列表视图 Ivw IvwFiles
'MAPI消息 mpm mpmSentMessage
'MAPI会话 mps mpsSession
'MCI mci mciVideo
'大纲 out outOrgChart
'报表 rpt rptQtr1Earnings
'微调控件 spn spnPages
'树状视图 tre treFolders
'用于数据库对象的前缀
'------------------------------------------
'对象 前缀 举例
'------------------------------------------
'数据库 db dbCustomers
'域(对象或对象集合) fld fldLastName
'索引(对象或对象集合) idx idxAge
'查询定义 qry qrySalesByRegion
'记录集 rst rstSalesByRegion
'报表 rpt rptAnnualSales
'表格定义 tbl tblCustomer
Option Explicit
'BE25E2CED4FEAC04
Public gbLoginSuccess As Boolean '是否成功登录系统的标志
Public gTMenuStruct() As MenuStruct '保存主控制表单中菜单的结构,该菜单数据可有数据库进行控制
Public gDNullTime As Date '对于系统来说,有的时间是无效的,系统对待这个时间便将之作为空时间处理
Public gbTemp As Boolean '临时的变量
Public gbAutoRun As Boolean '系统是否不用敲入用户名称和口令便自动登录
Public giUpdate As Integer '系统升级状态,见下面的说明.
'说明:
'Update为强制升级
'当Update=1时,只对数据库的结构进行添加,如有新的表格或字段被定义时,自动添加进旧的数据库
'当Update=2时,根据文件 Update.upt 中说明的字段进行升级
'当Update=3时,重新建立 Access 数据库,并删除旧的数据库
'当Update=4时,重新建立 SQL SERVER 数据库,并删除旧的数据库
Public gDBRecordConn As ADODB.Connection '用于全部的数据库连接
Public gadoFldsRS As ADODB.Recordset '全局的记录集
Public gadoFldIndexRS As ADODB.Recordset '全局的索引记录集
Public gadoTempRS As ADODB.Recordset '全局的临时记录集
Public gbFirstLogin As Boolean '是否第一次登录系统
Public gbNoteShow As Boolean '是否显示提示
Public gbConnectOK As Boolean
Public gbIsServer As Boolean '如果本程序用在服务端,则为TRUE
Public gbBusy As Boolean
Public gDCanUpdate As Date '可以规定一个时间界限,只要发现当前的时间超过这个界限,就升级到新的程序
Public glErrPatrol As Long '巡更的容差时间
Public glMsgAdd As Long 'WINDOWS消息的增加量,当自定义的消息ID和系统冲突时,可修改这个数值
Public gbEventMask(EVENT_END) As Boolean '事件屏蔽标志
'gclsDBFunc 涉及到对数据库的操作全部封装在该库中
Public gclsDBFunc As BNDBFuncProj.clsBNDBFunc
'对TREE控件的操作全部封装在gclsTreeView中
Public gclsTreeView As BNIncludeProj.clsBNTreeView
Public gbFirstRun As Boolean '系统是否首次运行,如果是,则需要进行一些初始化的工作,如发行系统卡
Public glRunTypeOld As Long
Public Enum RUN_MODE
CLASS_PLAN '排班
SIGN_CARD '手工签卡
HOLIDAY_PLAN '排假
CLASS_SWITCH '班次调换
ASSIGN_ATTEND '指定考勤规则如迟到,早退,旷工等.当指定时,可不考虑打卡情况.
RPT_HOLIDAY '请假查询报表
RPT_SPECCARD '特卡报表
RPT_ATTEND '考勤报表
RPT_SWITCH '换班报表
RPT_DAY1 '日报表1
DEVICE_RIGHT '人员打卡权限
DEPT_ADJUST '部门调整
WORK_ADJUST '工时调整
ADD_PLAN '加班单安排
End Enum
Public gTPickStruct As PickStruct
Public giAppUser As Integer
Public giMaxRecord As Integer '每页最大记录数
Public gsCopyFromFile As String
Public gsMyDllPath As String
Public gsVendorCode As String
Public m_hModBNInclude As Long
Public m_hModBNTreeView As Long
Public m_hModBNCommon As Long
Public m_hModBNDBFunc As Long
Public gTAppManageType As AppManageType
'Public gCtrlDBShell
Public Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public 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
Public Sub Main()
'gTAppLicInfo.CtrlNeedMonitor = True
Dim sMsg As String
Dim sLoginPwd As String
Dim sTemp As String
Dim sSysInfo() As String
Dim adoTempRS As ADODB.Recordset
Dim iTemp As Integer
Dim iPos As Integer
Dim bFlag As Boolean
Dim sSplit
'本常数用来限制ADO的最低版本,如果操作系统低于这个版本,要么系统安装新的版本,要么不允许运行
'因为ADO的版本不对时,可能造成数据存取方面的错误
10 Const VER_ADODB = "2.50.4403.9"
20 On Error GoTo ErrLabel
' 本程序已经运行,退出
30 If App.PrevInstance Then
40 MsgBox "本程序已经运行,请按<确定>退出.", vbExclamation
50 End
60 End If
'当处于设计环境时使用
70 If InIDE Then
80 gsMyDllPath = "D:\Zbin backup\Install\Support\My Register Dlls"
90 Else
100 gsMyDllPath = App.Path
110 End If
120 gsMyDllPath = gsMyDllPath & "\"
'自动加载DLL的优势在于:
'在同一线程中使用DLL而不用对它进行注册,这样不必依赖注册表加载DLL,同时避免的版本冲突
'
' If InIDE Then
130 Set gclsInclude = New BNIncludeProj.clsBNInclude
140 Set gclsDBFunc = New BNDBFuncProj.clsBNDBFunc
150 Set gclsCommon = New BNCommonProj.clsBNCommon
160 Set gclsTreeView = New BNIncludeProj.clsBNTreeView
'被屏蔽的部分可以自动加载指定的DLL而不需要对这些DLL进行注册
' Else
' Set gclsInclude = CreateDllItem(gsMyDllPath & "BNInclude.dll", "clsBNInclude", m_hModBNInclude)
' Set gclsTreeView = CreateDllItem(gsMyDllPath & "BNInclude.dll", "clsBNTreeView", m_hModBNTreeView)
' Set gclsCommon = CreateDllItem(gsMyDllPath & "BNCommon.dll", "clsBNCommon", m_hModBNCommon)
' Set gclsDBFunc = CreateDllItem(gsMyDllPath & "BNDBFunc.dll", "clsBNDBFunc", m_hModBNDBFunc)
' End If
' gbNoteShow = True
'1-客户A V4_20_010_S
'2-客户B V4_20_011_N
'3-客户C V4_20_012_S
'4-客户D V4_20_013_SN
'5-客户E V4_20_014_SN
'6-客户F V4_20_015_N
'7-客户G V4_20_016_SN
'8-客户H V4_20_017_S
'20-客户I汽车
'21-客户J
'22-客户I摩托
'23-客户H巡更
'24-客户H门禁
'25-客户H考勤
'27-客户B门禁 V4_20_011_N
'28-客户B巡更 V4_20_011_N
'40-客户K衡重程序(蕴藻浜) V4_20_040_SN
'55-VMS- V4_20_055_SN
'57-超限收费- V4_20_057_SN
#If COMP_APPUSER = 1 Then '1-客户A V4_20_010_S
170 giAppUser = 1
#ElseIf COMP_APPUSER = 2 Then '2-客户B V4_20_011_N
180 giAppUser = 2
#ElseIf COMP_APPUSER = 3 Then '3-客户C V4_20_012_S
190 giAppUser = 3
#ElseIf COMP_APPUSER = 4 Then '4-客户D V4_20_013_SN
200 giAppUser = 4
#ElseIf COMP_APPUSER = 5 Then '5-客户E V4_20_014_SN
210 giAppUser = 5
#ElseIf COMP_APPUSER = 6 Then '6-客户F V4_20_015_N
220 giAppUser = 6
#ElseIf COMP_APPUSER = 7 Then '7-客户G V4_20_016_SN
230 giAppUser = 7
#ElseIf COMP_APPUSER = 8 Then '8-客户H V4_20_017_S
240 giAppUser = 8
#ElseIf COMP_APPUSER = 20 Then '20-客户I汽车
250 giAppUser = 20
#ElseIf COMP_APPUSER = 21 Then '21-客户J
260 giAppUser = 21
#ElseIf COMP_APPUSER = 22 Then '22-客户I摩托
270 giAppUser = 22
#ElseIf COMP_APPUSER = 23 Then '23-客户H巡更
280 giAppUser = 23
#ElseIf COMP_APPUSER = 24 Then '24-客户H门禁
290 giAppUser = 24
#ElseIf COMP_APPUSER = 25 Then '25-客户H考勤
300 giAppUser = 25
#ElseIf COMP_APPUSER = 27 Then '27-客户B门禁 V4_20_011_N
310 giAppUser = 27
#ElseIf COMP_APPUSER = 28 Then '28-客户B巡更 V4_20_011_N
320 giAppUser = 28
#ElseIf COMP_APPUSER = 29 Then '29-客户B自动采集 V4_20_011_N
330 giAppUser = 29
#ElseIf COMP_APPUSER = 40 Then '40-客户K衡重程序(蕴藻浜) V4_20_040_SN
340 giAppUser = 40
#ElseIf COMP_APPUSER = 55 Then '55-VMS V4_20_055_SN
350 giAppUser = 55
#ElseIf COMP_APPUSER = 57 Then '57-超限收费- V4_20_057_SN
360 giAppUser = 57
#ElseIf COMP_APPUSER = 80 Then '80-观察存储过程
365 giAppUser = 80
#End If
'对动态库 BNInclude.DLL 进行身份认证,在IDE的环境下,如果认证未通过,将不能进行调试.
370 If Not gclsInclude.MyLicence(INCLUDE_PWD_USER & App.hInstance & "123", App) Then GoTo EndLabel
380 With gclsCommon
'gclsCommon中也会使用到gclsInclude的,为了避免重复加载浪费系统资源,这里将已经实例化以后的gclsInclude赋值给gclsCommon
390 .SetInclude gclsInclude
'同上所述
400 .SetDBFunc gclsDBFunc
'gclsCommon自己也会调用自己类中间包含的函数,因此,在gclsCommon内部就不再初始化gclsCommon了
410 .SetCommon gclsCommon
'对动态库 BNCommon.DLL 进行身份认证,
420 .CBNLicence "ZHAOBIN"
#If IS_RUN Then
'程序
#Else
'调试,本程序可能会用到Cell32.ocx和MsgBlast.ocx,我在这里对其进行了解密,这样才不受版权限制
'由于Cell32.ocx，ASPACK.EXE，MsgBlast.ocx是一个商业版本，因此在使用时需要对其进行解密
430 .CBNKillSupport 1 'Cell32.ocx
440 .CBNKillSupport 2 'ASPACK.EXE V2.1
450 .CBNKillSupport 3 'MsgBlast.ocx
#End If
460 End With
'系统允许在主菜单上外挂一些程序,以方便调用.
470 ReDim gTAppLicInfo.FileExName(0) '外挂程序的位置
480 ReDim gTAppLicInfo.FileExDesc(0) '外挂程序的描述
'程序启动时,先自动地加载一个缺省的应用程序信息,在后面的过程中再对其进行修改
490 gTAppLicInfo = DFNGetDefaultValue(giAppUser, gclsInclude.MyGetAppVersion(App))
'根据应用程序的需要对gTAppLicInfo进行修改
500 With gTAppLicInfo
'部门编码的字段长度为20
510 .OthDptFieldLen = 20
520 gbFirstLogin = True
'得到临时文件名称,该文件一般用来存储重要的操作例如下载数据\更改设备的时间等
'当系统出现争议时,可在这个文件中找到线索,之所以用临时文件,是为了给我们留个后门,
'避免操作员擅自毁灭证据.
530 .FileTemp = gclsInclude.MyTempPath & "_Bntmp0.dir\~bn1022y69.tmp"
If giAppUser = 80 Then
.SoftSQLDBase = "Pubs"
Else
540 .SoftSQLDBase = DEFAULT_SQL_DBASE '加载SQL表名,为了避免和金益康形成版权冲突,因此使用GPMM2000
End If
550 .SysSoundCard = gclsInclude.MyGetWaveDevs > 0 '如果系统有声卡
'如果分辨率小于800*600,窗体自动调整大小
560 .CtrlNeedResize = gclsInclude.MyGetResolution.x < 800
' sTemp = UCase(gclsInclude.MyGetLShortDFormat)
' If sTemp <> "YYYY-MM-DD" And sTemp <> "MM/DD/YYYY" And sTemp <> "YYYY-M-D" Then
' If MsgBox("系统的短时间格式不支持2000年,是否做调整?", vbQuestion + vbOKCancel) = vbOK Then
' If Not gclsInclude.MySetLShortDFormat("yyyy-MM-dd") Then
' If Not gclsInclude.MySetLShortDFormat("mm/dd/yyyy") Then
' MsgBox "短时间格式设置失败!"
' End If
' End If
' End If
' End If
'将版权放在 BNDBaseInfo.dll 的资源中便于直接使用一些资源修改工具对应用程序的资源进行修改
If giAppUser = 80 Then
gTAppLicInfo.CtrlDatabaseLogin = True
End If
570 .SoftOwnerAlias = DFNLoadResString(108) '开发单位简称
580 .SoftOwnerName = DFNLoadResString(110) '开发单位
590 .SoftPlatform = DFNLoadResString(105) '运行环境
600 .SoftOwnerAddr = DFNLoadResString(102) '开发公司地址
610 .SoftOwnerTele = DFNLoadResString(103) '开发公司电话
620 .SoftAuthorEmail = DFNLoadResString(107) '作者EMAIL
630 .SoftAuthorQQ = DFNLoadResString(116) '作者QQ
640 .SoftCopyRight = DFNLoadResString(106) & " " & .SoftOwnerAlias '版权信息
650 .SoftName = .SoftCnName & "管理系统" '软件名称
660 App.Title = .SoftName '当系统出现提示时,标题为软件名称
'当程序新升级后，请在GetInstallTips中填写升级声明
#If APPLICATION_TYPE = 1 Then '考勤
670 .SysAppType = eDevAttend
680 .SoftLevel = 75
690 .DevAPPType = APP_MIFARE_ATTEND
700 .SoftIconKey = "IMG075"
710 gTAppLicInfo.SoftNumber = "66"
720 ReDim gsValidClass(5)
730 gsValidClass(0) = "A"
740 gsValidClass(1) = "B"
750 gsValidClass(2) = "C"
760 gsValidClass(3) = "D"
770 gsValidClass(4) = "E"
780 gsValidClass(5) = "Z"
790 gclsCommon.CommonValidClass = gsValidClass
#ElseIf APPLICATION_TYPE = 2 Then '门禁
800 .SysAppType = eDevGate
810 .SoftLevel = 62
820 .DevAPPType = APP_MIFARE_GATE
830 .SoftIconKey = "IMG075"
840 ReDim .FileVoice(1 To 3)
850 ReDim .CtrlVoice(1 To 3)
860 gTAppLicInfo.SoftNumber = "50"
#ElseIf APPLICATION_TYPE = 3 Then '巡更
870 .SoftLevel = 3
880 .SysAppType = eDevPatrol
890 .SoftIconKey = "IMG078"
900 gTAppLicInfo.SoftNumber = "30"
#ElseIf APPLICATION_TYPE = 4 Then '停车
910 .SoftLevel = 1
920 .SysAppType = eDevParking
930 .SoftIconKey = "IMG079"
940 .SoftNumber = "40"
#ElseIf APPLICATION_TYPE = 5 Then '售饭
950 .SoftLevel = 1
960 .SysAppType = eDevMeal
970 .SoftIconKey = "IMG078"
980 .SoftNumber = "60"
#ElseIf APPLICATION_TYPE = 6 Then '消费
990 .SoftLevel = 1
1000 .SysAppType = eDevConsume
1010 .SoftIconKey = "IMG078"
1020 .SoftNumber = "70"
#ElseIf APPLICATION_TYPE = 7 Then '发卡
1030 .SoftLevel = 1
1040 .SoftIconKey = "IMG077"
1050 .SysAppType = eDevHR
1060 .SoftNumber = "80"
#ElseIf APPLICATION_TYPE = 8 Then '自动采集
1070 .SoftLevel = 1
1080 .SoftIconKey = "IMG076"
1090 .SysAppType = eAutoDownload
1100 .SoftNumber = "90"
#ElseIf APPLICATION_TYPE = 10 Then '工资系统(查询)
1110 .SoftLevel = 1
1120 .SoftIconKey = "IMG081"
1130 .SysAppType = eDevHR
1140 .SoftNumber = "58"
#ElseIf APPLICATION_TYPE = 11 Then '衡重
1150 .SoftLevel = 1
1160 .SoftIconKey = "IMG079"
1170 .SysAppType = eDevWeighting
1180 .SoftNumber = "82"
#ElseIf APPLICATION_TYPE = 12 Then 'VMS
1190 .SoftLevel = 1
1200 .SoftIconKey = "IMG079"
1210 .SysAppType = eDevERP
1220 .SoftNumber = "55"
1230 .CtrlCompanyLogin = True
#ElseIf APPLICATION_TYPE = 13 Then '超限收费
1240 .SoftLevel = 1
1250 .SoftIconKey = "IMG079"
1260 .SysAppType = eDevERP
1270 .SoftNumber = "57"
1280 .CtrlCompanyLogin = False
#End If
'寻找低版本的MSADO15.DLL文件并删除
' If Not gclsCommon.CBNAdodbVersion(VER_ADODB) Then GoTo EndLabel
1290 .SoftDBBckPasswd = "Backup"
'对gclsDBFunc中出现的提示信息也统一为.SoftName
1300 gclsDBFunc.dbSetAppTitle .SoftName
'同上
1310 gclsCommon.CBNSetAppTitle .SoftName
'同上
1320 gclsInclude.MySetAppTitle .SoftName
'先假定一个缺省INI配置文件
1330 .FileINI = gclsInclude.MyAddBackslash(App.Path) & "BN" & .SoftEnName & ".ini"
#If IS_RUN Then
'进行身份认证,如果用户非法,将不再运行程序
' If Not gclsCommon.CBNRegisteredUser(.SoftPassword, _
.SoftOwnerAlias & .SoftName, _
gclsInclude.MyGetAppVersion(App), _
.SoftCode) Then GoTo EndLabel
#End If
1350 .FilePathApp = gclsInclude.MyAddBackslash(App.Path)
1360 .SoftHostName = gclsInclude.MyGetHostName
1370 .FilePathWindows = gclsInclude.MyWindowsPath
1380 .SysLocalIP = gclsCommon.CBNGetIPAddr
1390 If Not gclsInclude.MyFileExists(.FileINI) Then ' 系统配置文件遗失
'传递gTAppLicInfo的信息到gclsCommon中
1400 gclsCommon.CBNSetAppInfo gTAppLicInfo
'自动生成系统配置INI文件
1410 Call DFNMakeIniFile(gTAppLicInfo)
1420 .SoftNetwork = False '第一次使用时，使用单机版
1430 End If
' .FileINI = gclsInclude.MyFileRelatPath(.FilePathApp, .FileINI)
1440 .SoftMainColor = funcGetSystemData("MainColor", &HDFA000)
1450 .CtrlRunSingle = funcGetSystemData("RunSingle", "1")
1460 gbAutoRun = funcGetSystemData("AutoRun", "0")
1470 .CtrlNeedMonitor = funcGetSystemData("ErrMonitor", 0)
1480 .OthCardLen = funcGetINIData("Device Parameter", "Card_Len", "14")
1490 .DevCardNumLen = funcGetINIData("Device Parameter", "Card_Cut_Len", "5")
1500 .OthMaxCardLen = funcGetSystemData("MaxCardLen", "4")
1510 giMaxRecord = funcGetSystemData("Max Record", "20")
1515 gTAixSystemParament.RunType = funcGetSystemData("RunType", "2")
glRunTypeOld = gTAixSystemParament.RunType
1520 .CtrlButtonStyle = funcGetSystemData("ButtonStyle", "1")
1530 If .CtrlButtonStyle > 5 Then .CtrlButtonStyle = 1
1540 .CtrlBoardShow = funcGetSystemData("BoardShow", "1")
1550 .SysDebugLevel = funcGetSystemData("Debug", "0")
1560 .SysSystemDebug = .SysDebugLevel > 0
1570 .CtrlAutoIssue = funcGetSystemData("AutoIssue", "0")
1580 .CtrlUseColor = funcGetSystemData("UseColor", "1")
1590 .CtrlPapleCtrl = funcGetSystemData("PapleCtrl", 1)
1600 .CtrlMenuBmp = funcGetSystemData("MenuBmp", 1)
1610 sTemp = funcGetSystemData("AppPath", App.Path)
'如果得到的是相对路径，就要计算出他的绝对路径
1620 If sTemp <> "" Then
1630 sTemp = gclsInclude.MyAddBackslash(sTemp)
1640 sTemp = gclsInclude.MyAbsPath(.FilePathApp, sTemp)
1650 .FilePathApp = sTemp
1660 End If
1670 .FilePathApp = gclsInclude.MyAddBackslash(.FilePathApp)
#If APPLICATION_TYPE = 12 Then 'VMS
1680 gsCopyFromFile = .FilePathApp & "VMS_CopyFrom.ini"
#End If
1690 .FileLog = .FilePathApp & "Log\Events.log"
.FileNote = .FilePathApp & "Log\Note.log"
1700 .CtrlWindowRunMode = funcGetSystemData("RunMode", 0)
1710 If Left(.FilePathApp, 2) <> "\\" Then
'得到盘符
1720 sTemp = Left(.FilePathApp, InStr(.FilePathApp, ":") - 1)
1730 iTemp = gclsInclude.MyGetDriveType(sTemp)
1740 If iTemp <> DRIVE_FIXED And iTemp <> DRIVE_REMOVABLE Then
1750 MsgBox " 数据库路径" & .FilePathApp & "为不可读写存储器,请修改配置文件:" & .FileINI & _
" 中的“AppPath”值指向正确的程序运行路径后重新运行程序!", vbInformation
1760 GoTo EndLabel
1770 End If
1780 End If
1790 If Not gclsInclude.MyPathExists(gclsInclude.MyRemoveBackslash(.FilePathApp)) Then _
gclsInclude.MyMkDir .FilePathApp
1800 .DevMainType = funcGetINIData("Device Parameter", "DeviceType", .DevMainType)
1810 .DevDevicePort = funcGetINIData("Device Parameter", "DevicePort", 2)
1820 gTAppLicInfo.DevIssuePort = funcGetINIData("Device Parameter", "IssuePort", 1)
If giAppUser = 80 Then
.SoftSQLDBase = funcGetINIData("SQL SERVER", "DATABASE", "Pubs")
Else
1830 .SoftSQLDBase = funcGetINIData("SQL SERVER", "DATABASE", DEFAULT_SQL_DBASE)
End If
1840 .SoftSQLServer = funcGetINIData("SQL SERVER", "SERVER_HOST", gclsInclude.MyGetHostName)
1850 .SysLocalIP = funcGetINIData("SQL SERVER", "CLIENT_IP", .SysLocalIP)
1860 .SysClient = funcGetINIData("SQL SERVER", "CLIENT_HOST", gclsInclude.MyGetHostName)
1870 giUpdate = funcGetSystemData("Update", "0")
1880 .CtrlAutoDownload = funcGetINIData("Remote Control", "AutoDownload", 0)
1890 .CtrlAutoRight = funcGetINIData("Remote Control", "AutoRight", 0)
1900 .DevMainName = gclsInclude.MyGetDevName(.DevMainType)
1910 .FileEncrypt = .FilePathApp & "Tecsun.dat"
1920 .SoftNetwork = IIf(funcGetINIData("Run Mode", "Run_Mode", "0") = "0", False, True)
1930 If .SoftDBaseType = 1 Then '单机版
1940 .SoftNetwork = False
1950 ElseIf .SoftDBaseType = 2 Then '网络版
1960 .SoftNetwork = True
1970 End If
If giAppUser = 80 Then
Else
1980 If .SoftNetwork Then
1990 Select Case UCase(.SoftSQLDBase)
Case UCase("master"), UCase("model"), UCase("msdb"), _
UCase("Northwind"), UCase("pubs"), UCase("tempdb")
2010 MsgBox "数据库名与SQL系统数据库冲突", vbCritical
2020 GoTo EndLabel
Case ""
2030 MsgBox "无数据库名错误,请修改INI文件.", vbCritical
2040 GoTo EndLabel
2050 End Select
2060 End If
End If
2070 .FilePicBG = funcGetSystemData("BackgroundFile", .FilePathWindows & "Media\YK.gif")
2080 If Not gclsInclude.MyFileExists(.FilePicBG) Then
2090 .FilePicBG = .FilePathWindows & "Media\YK.gif"
2100 End If
2110 .FilePicSplash = funcGetSystemData("SplashFile", .FilePathWindows & "Media\" & .SoftEnName & "Splash.gif")
2120 If Not gclsInclude.MyFileExists(.FilePicSplash) Then
2130 .FilePicSplash = .FilePathWindows & "Media\YK.gif"
2140 End If
2150 .FilePicBoard = funcGetSystemData("BoardFile", .FilePathWindows & "Media\Board.gif")
2160 If Not gclsInclude.MyFileExists(.FilePicBoard) Then
2170 .FilePicBoard = .FilePathWindows & "Media\Board.gif"
2180 End If
If giAppUser <> 80 Then
'下述代码自动将系统缺少的目录建立起来
2190 If Not gclsInclude.MyPathExists(.FilePathApp & "Report") Then _
gclsInclude.MyMkDir .FilePathApp & "Report"
2200 If Not gclsInclude.MyPathExists(.FilePathApp & "DBase") Then _
gclsInclude.MyMkDir .FilePathApp & "DBase"
2210 If Not gclsInclude.MyPathExists(.FilePathApp & "Backup") Then _
gclsInclude.MyMkDir .FilePathApp & "Backup"
2220 If Not gclsInclude.MyPathExists(.FilePathApp & "Shell") Then _
gclsInclude.MyMkDir .FilePathApp & "Shell"
2230 If Not gclsInclude.MyPathExists(.FilePathWindows & "Media") Then _
gclsInclude.MyMkDir .FilePathWindows & "Media"
2235 If Not gclsInclude.MyPathExists(.FilePathApp & "Wave") Then _
gclsInclude.MyMkDir .FilePathApp & "Wave"
2240 If Not gclsInclude.MyPathExists(.FilePathApp & "Log") Then _
gclsInclude.MyMkDir .FilePathApp & "Log"
2250 If Not gclsInclude.MyPathExists(gclsInclude.MyTempPath & "_Bntmp0.dir") Then _
gclsInclude.MyMkDir gclsInclude.MyTempPath & "_Bntmp0.dir"
End If
2260 gDNullTime = CDate("23:59:59")
2270 .FileDBRestore = funcGetINIData("SQL SERVER", _
"BackupDatabase", _
.FilePathApp & "Backup\" & .SoftSQLDBase & ".BAK")
2280 .FileDBBackup = .FilePathApp & "DBase\dbBN_Backup.mdb"
2290 sTemp = Command() '命令行参数
' sTemp = "Localhost,sa,"
2300 If sTemp <> "" Then
' MsgBox sTemp
2310 sSplit = Split(sTemp, ",")
2320 iTemp = UBound(sSplit)
2330 If iTemp >= 0 Then .SoftSQLServer = sSplit(0)
2340 If iTemp >= 2 Then sLoginPwd = sSplit(2)
2350 If iTemp >= 1 Then
2360 If sSplit(1) <> "" Then
2370 .SysLoginUser = sSplit(1)
2380 gbLoginSuccess = True
2390 GoTo PassLogin
2400 End If
2410 End If
2420 End If
2430 End With
ReLogin:
'显示登录画面
2440 If gbAutoRun Then
2450 gTAppLicInfo.SysLoginUser = "SA"
2460 Else
2470 If ShowLogin(sLoginPwd) = "" Then
2480 Unload frmSplash
2490 GoTo EndLabel
2500 End If
2510 End If
PassLogin:
2520 With gTAppLicInfo
2530 .SysLoginSA = UCase(.SysLoginUser) = "SA"
2540 If gclsInclude.MyFileExists(.FilePicSplash) Then
2550 frmSplash.Show
2560 frmSplash.Refresh
2570 End If
2580 .FileDBRecord = funcGetSystemData("DataBase", .FilePathApp & "DBase\" & "dbBN_Single.mdb")
2590 .FileDBRecord = gclsInclude.MyAbsPath(.FilePathApp, .FileDBRecord)
2600 .FileDBStatus = funcGetSystemData("StatusDBase", .FilePathApp & "Shell\" & "dbStatus.mdb")
2610 If Right(.FileDBRecord, 1) = "\" Then
2620 .FileDBRecord = .FileDBRecord & "dbBN_Single.mdb"
2630 End If
'这里应该考虑远程计算机
2640 .FileSQL = .FilePathApp & "DBase\" & "dbBN_SQL.mdf"
2650 If Not gTAppLicInfo.SoftNetwork Then
2660 .SysDBRecordConn = gclsCommon.CBNGetAccessConnect(.FileDBRecord, _
.SoftDBaseVer, _
.SoftDBPasswd, _
True)
'由于ADO的版本已经强制为2.5了,所以Jet的版本应该为4.0
2670 .SysDBRecordConn = Replace(.SysDBRecordConn, "3.51", "4.0")
2680 Else
2690 If .SoftSQLServer = "" Then
2700 .SoftSQLServer = funcGetINIData("SQL SERVER", _
"SERVER_HOST", _
gclsInclude.MyGetHostName)
2710 End If
2720 .SysDBRecordConn = gclsDBFunc.dbGetSQLConnect(.SysLoginUser, _
.SoftSQLDBase, _
sLoginPwd, _
.SoftSQLServer, _
IIf(giAppUser = 80, False, True), , _
1)
2730 End If
2740 gclsCommon.CBNSplashShow
2750 gclsCommon.CBNSplashSetMessage "正在登录系统"
2760 DoEvents
If giAppUser = 80 Then
GoTo LoadProgramm
End If
#If COMP_APPUSER = 29 Then '29-客户B自动采集 V4_20_011_N
2770 .SysAppType = eDevPatrol + 1
#End If
2780 End With
2790 With gTAppLicInfo
'建立备份数据库
2800 If Not gclsInclude.MyFileExists(.FileDBBackup) Then ' 记录数据库文件遗失
2810 Screen.MousePointer = vbDefault
2820 sTemp = gclsInclude.MyFilePath(.FileDBBackup)
2830 If sTemp <> "" Then
2840 If Not gclsInclude.MyPathExists(sTemp) Then
2850 gclsInclude.MyMkDir sTemp
2860 End If
2870 If gclsInclude.MyPathExists(sTemp) Then
2880 DoEvents
2890 gclsCommon.CBNSplashSetMessage "正在生成备份数据库"
2900 DoEvents
' sTemp = CreateBackupDB
'建立一个备份数据库以便对用户的图象等数据以及对用户的打卡数据进行备份 _
在服务器上的数据库发生故障时可以用本机上的数据库进行恢复
2920 CreateBackupDB .FileDBBackup, .SoftDBBckPasswd
2930 .SoftDBBckVer = "97"
2940 Else
2950 MsgBox "无法建立路径:" & sTemp & ",备份数据库建立失败!", vbCritical
2960 End If
2970 End If
2980 Else
2990 sTemp = ""
'无论用户的数据库密码怎么变，该函数可以根据数据库的版本自动找出密码
3000 sTemp = gclsInclude.MyGetAccessPwd(.FileDBBackup, .SoftDBBckVer)
3010 If sTemp <> "" Then .SoftDBBckPasswd = sTemp
3020 End If
#If APPLICATION_TYPE = 11 Then '衡重
3030 If Not gclsInclude.MyFileExists(gTAppLicInfo.FileDBStatus) Then ' 记录数据库文件遗失
3040 sTemp = gTAppLicInfo.FilePathApp & "Shell\dbStatus.mdb"
3050 Else
3060 sTemp = gTAppLicInfo.FileDBStatus
3070 End If
3080 If Not gclsInclude.MyFileExists(sTemp) Then ' 记录数据库文件遗失
3090 DoEvents
3100 gclsCommon.CBNSplashSetMessage "正在生成状态数据库"
3110 DoEvents
3120 CreateStatusDB sTemp, ""
3130 Else
' gclsInclude.MySetShell gclsInclude.MyFilePath(gTAppLicInfo.FileDBStatus), "Shell", 3, "状态数据库"
3140 End If
#End If
3150 On Error Resume Next
3160 If Not .SysLoginSA Then giUpdate = 0
3170 End With
3180 gclsCommon.CommonAppInfo = gTAppLicInfo
3190 If gTAppLicInfo.SoftNetwork Then '对于SQL数据库
'1.建立SQL数据库的ADO连接
BuiltDatabaseLabel:
3200 If giUpdate = 4 Then
3210 gclsCommon.CBNSaveLogFile gTAppLicInfo.SysLoginUser & _
"用户创建数据库:" & _
gTAppLicInfo.SoftSQLDBase & "," & _
gclsCommon.CBNGetStandTime(gclsCommon.CBNGetNow), _
True, True
3220 gclsInclude.MyAppendToFile gTAppLicInfo.FileTemp, _
gTAppLicInfo.SysLoginUser & _
"用户升级数据库:" & _
gclsCommon.CBNGetStandTime(gclsCommon.CBNGetNow)
3230 Screen.MousePointer = vbDefault
3240 DoEvents
3250 gclsCommon.CBNSplashSetMessage "正在创建数据库" & gTAppLicInfo.SoftSQLDBase
3260 DoEvents
'执行到此。表明该服务器存在SQL SERVER
'如果服务器就是本机，则要在本机上建立一个 SQL 数据库文件
3270 If CreateSQLDBase(gTAppLicInfo.FileSQL, sLoginPwd) Then
3280 Screen.MousePointer = vbDefault
3290 DoEvents
3300 gclsCommon.CBNSplashUnload
3310 DoEvents
3320 MsgBox "数据库建立成功!请重新启动本程序."
3330 gclsCommon.CBNSaveLogFile gTAppLicInfo.SysLoginUser & _
"用户数据库建立成功:" & _
gclsCommon.CBNGetStandTime(gclsCommon.CBNGetNow), _
True, True
3340 gclsInclude.MyAppendToFile gTAppLicInfo.FileTemp, _
gTAppLicInfo.SysLoginUser & _
"用户数据库建立成功:" & _
gclsCommon.CBNGetStandTime(gclsCommon.CBNGetNow)
3350 Else
3360 Screen.MousePointer = vbDefault
3370 DoEvents
3380 gclsCommon.CBNSplashUnload
3390 DoEvents
3400 MsgBox "数据库未成功建立!请重新启动本程序.", vbExclamation
3410 gclsCommon.CBNSaveLogFile gTAppLicInfo.SysLoginUser & "用户数据库建立失败:" & _
gclsCommon.CBNGetStandTime(gclsCommon.CBNGetNow), _
True, True
3420 gclsCommon.CBNSaveLogFile gclsDBFunc.dbGetLastError.Number & "," & _
gclsDBFunc.dbGetLastError.Description, _
True, True
3430 gclsInclude.MyAppendToFile gTAppLicInfo.FileTemp, _
gTAppLicInfo.SysLoginUser & "用户数据库建立失败:" & _
gclsCommon.CBNGetStandTime(gclsCommon.CBNGetNow)
3440 gclsInclude.MyAppendToFile gTAppLicInfo.FileTemp, _
gclsDBFunc.dbGetLastError.Number & "," & _
gclsDBFunc.dbGetLastError.Description
3450 End If
3460 If giUpdate > 0 Then
3470 giUpdate = 0
3480 funcSetSystemData "Update", "0"
3490 End If
3500 gclsDBFunc.dbCloseConnect False
3510 gclsDBFunc.dbCloseConnect True
3520 GoTo EndLabel
3530 Else
' 置鼠标忙标志
3540 Screen.MousePointer = vbHourglass
3550 DoEvents
3560 gclsCommon.CBNSplashSetMessage "正在建立数据库连接"
3570 DoEvents
' gTAppLicInfo.SysDBRecordConn = Replace(gTAppLicInfo.SysDBRecordConn, "SA", "AAA")
3580 gclsDBFunc.dbClearError
3590 iTemp = 0
ReConnect:
3600 iTemp = iTemp + 1
3610 If gclsDBFunc.dbSetConnect(gTAppLicInfo.SysDBRecordConn, False, adUseClient) Then
3620 Set gDBRecordConn = gclsDBFunc.dbGetConnect(False)
3630 Else
3640 If iTemp = 1 Then
3650 gclsCommon.CBNSplashSetMessage "正试图重新建立数据库连接"
3660 GoTo ReConnect
3670 End If
3680 gclsCommon.CBNWriteOperLog gclsDBFunc.dbGetLastError.Description
3690 Screen.MousePointer = vbDefault
3700 DoEvents
3710 gclsCommon.CBNSplashUnload
3720 DoEvents
'2002-8-9日发现,当数据库不存在以及网络连接不通时,返回的错误代码都是-2147467259
3730 If gTAppLicInfo.SysLoginSA And (gclsDBFunc.dbGetLastError.Number = -2147467259) Then
'本处应该使用Pubs数据库登录来判断是否存在要求的数据库，但为了简便，使用错误描述
3740 sMsg = UCase(gclsDBFunc.dbGetLastError.Description)
3750 sTemp = " '" & gTAppLicInfo.SoftSQLDBase & "'"
3760 If InStr(sMsg, "LOGIN" & sTemp) Or InStr(sMsg, "登录" & sTemp) Then
3770 If MsgBox("SQL数据库 " & gTAppLicInfo.SoftSQLDBase & _
" 不存在，是否由本程序自动建立？", vbQuestion + vbOKCancel) = vbOK Then
3780 giUpdate = 4
3790 GoTo BuiltDatabaseLabel
3800 ElseIf MsgBox("SQL数据库 " & gTAppLicInfo.SoftSQLDBase & _
" 不存在，是否从备份文件恢复？", vbQuestion + vbOKCancel) = vbOK Then
3810 If gclsCommon.CBNRestoreDatabase Then
3820 MsgBox "数据库恢复成功!"
3830 Else
3840 MsgBox "数据库恢复失败!"
3850 End If
3860 GoTo EndLabel
3870 Else
3880 giUpdate = 0
3890 MsgBox "请修改配置文件：" & gTAppLicInfo.FileINI & " 以正确指定数据库"
3900 End If
3910 Else
3920 MsgBox "SQL数据库连接失败,请重新键入登录信息或配置SQL数据库", vbExclamation
3930 End If
3940 Else
3950 MsgBox "SQL数据库连接失败,请重新键入登录信息或配置SQL数据库", vbExclamation
3960 End If
3970 GoTo ReLogin
3980 End If
3990 End If
'2.检查SQL库是否存在改动
4000 If Not gclsDBFunc.dbTableExists("T0101S001", gDBRecordConn) Then '如果SQL数据库未升级
4010 If gclsDBFunc.dbGetLastError.Number = -2147217911 Then
4020 MsgBox "操作员 " & gTAppLicInfo.SysLoginUser & " 没数据库的访问权限,请联系管理人员!", vbCritical
4030 GoTo EndLabel
4040 ElseIf gclsDBFunc.dbGetLastError.Number = -2147217887 Then
4050 MsgBox " 可能数据组件安装错误,请重新安装,如还有故障,请联系程序供应商." & vbCrLf & _
"访问表T0101S001时有其他错误,错误号为:-2147217887,错误描述为:" & _
gclsDBFunc.dbGetLastError.Description
4060 GoTo EndLabel
4070 End If
4080 If gTAppLicInfo.SysLoginSA Then
4090 If MsgBox("SQL数据库未升级,请按<确定>升级SQL数据库,按<取消>退出系统.", _
vbOKCancel, "升级SQL数据库") = vbOK Then
UpdateSQL:
#If APPLICATION_TYPE = 1 Then '考勤
4100 gTHoliSystem = gclsCommon.CBNGetHolidayInfo(True And (giUpdate > 0))
#End If
4110 If CreateSQLDBase Then
4120 MsgBox "数据库升级成功!", vbExclamation
4130 If giUpdate > 0 Then
4140 giUpdate = False
4150 funcSetSystemData "Update", "0"
4160 End If
4170 Else
4180 MsgBox "数据库升级失败!", vbExclamation
4190 End If
4200 GoTo EndLabel
4210 Else
4220 GoTo EndLabel
4230 End If
4240 Else
4250 MsgBox "数据库连接失败!", vbExclamation
4260 GoTo EndLabel
4270 End If
4280 End If
4290 Else
4300 If Not gclsInclude.MyFileExists(gTAppLicInfo.FileDBRecord) Then ' 系统数据库文件遗失
4310 sTemp = gclsInclude.MyFilePath(gTAppLicInfo.FileDBRecord)
4320 If sTemp <> "" Then
4330 If Not gclsInclude.MyPathExists(sTemp) Then
4340 If Not gclsInclude.MyMkDir(sTemp) Then
4350 MsgBox "无法建立路径:" & sTemp & ",程序运行失败!", vbCritical
4360 GoTo EndLabel
4370 End If
4380 End If
4390 Else
4400 MsgBox gTAppLicInfo.FileINI & "文件中,数据库路径指定错误,程序运行失败!", vbCritical
4410 GoTo EndLabel
4420 End If
4430 sMsg = gTAppLicInfo.FileDBRecord & _
" 系统数据库文件遗失,请按<确定>建立一个空数据库,按<取消>退出系统."
4440 If MsgBox(sMsg, vbOKCancel, "文件遗失") = vbOK Then
4450 giUpdate = 4
4460 Screen.MousePointer = vbDefault
4470 DoEvents
4480 gclsCommon.CBNSplashSetMessage "正在创建数据库"
4490 DoEvents
UpdateDBase:
#If APPLICATION_TYPE = 1 Then '考勤
4500 gTHoliSystem = gclsCommon.CBNGetHolidayInfo(True And (giUpdate > 0))
#End If
4510 If gTAppLicInfo.SoftDBaseVer = "" Then gTAppLicInfo.SoftDBaseVer = "97"
'由于ADO的版本已经强制为2.5了,所以Jet的版本应该为4.0
4520 gTAppLicInfo.SysDBRecordConn = gclsDBFunc.dbGetJetConnect(gTAppLicInfo.FileDBRecord, _
gTAppLicInfo.SoftDBPasswd, _
True, _
"4.0")
'gTAppLicInfo.SysDBRecordConn = gclsDBFunc.dbGetJetConnect(gTAppLicInfo.FileDBRecord, _
gTAppLicInfo.SoftDBPasswd, _
True, _
IIf(gTAppLicInfo.SoftDBaseVer = "97", "3.51", "4.0"))
' if gclsInclude.MyFilePath(gTAppLicInfo.FileDBRecord)
4540 If CreateDB(gTAppLicInfo.FileDBRecord, gTAppLicInfo.SoftDBPasswd) Then
4550 Screen.MousePointer = vbDefault
4560 DoEvents
4570 gclsCommon.CBNSplashUnload
4580 DoEvents
4590 If giUpdate > 0 Then
4600 giUpdate = 0
4610 funcSetSystemData "Update", "0"
4620 End If
4630 MsgBox "数据库建立成功!请重新启动本程序."
4640 Else
4650 Screen.MousePointer = vbDefault
4660 DoEvents
4670 gclsCommon.CBNSplashUnload
4680 DoEvents
4690 MsgBox "数据库建立失败!请找供应商寻求帮助.", vbExclamation
4700 If gclsInclude.MyFileExists(gTAppLicInfo.FileDBRecord) Then Kill gTAppLicInfo.FileDBRecord
4710 End If
4720 gclsDBFunc.dbCloseConnect False
4730 gclsDBFunc.dbCloseConnect True
4740 GoTo EndLabel
4750 Else
4760 GoTo EndLabel
4770 End If
4780 Else
4790 If giUpdate = 3 Then
4800 gclsCommon.CBNSaveLogFile gTAppLicInfo.SysLoginUser & _
"用户升级数据库:" & _
gclsCommon.CBNGetStandTime(gclsCommon.CBNGetNow), _
True, True
4810 gclsInclude.MyAppendToFile gTAppLicInfo.FileTemp, _
gTAppLicInfo.SysLoginUser & _
"用户升级数据库:" & _
gclsCommon.CBNGetStandTime(gclsCommon.CBNGetNow)
4820 sMsg = "系统将建立新的" & gTAppLicInfo.FileDBRecord & "数据库,继续吗?" & vbCrLf & _
"注意:此操作将删除现有的数据库,在进行之前,请先备份数据!"
4830 If MsgBox(sMsg, vbOKCancel + vbQuestion + vbDefaultButton2) = vbOK Then
4840 Kill gTAppLicInfo.FileDBRecord
4850 GoTo UpdateDBase
4860 End If
4870 GoTo EndLabel
4880 End If
4890 End If
4900 End If
LoadProgramm:
4910 If gDBRecordConn Is Nothing Then
4920 Screen.MousePointer = vbDefault
4930 DoEvents
4940 gclsCommon.CBNSplashSetMessage "正在连接数据库"
4950 DoEvents
4960 Set gDBRecordConn = New ADODB.Connection
4970 gDBRecordConn.CursorLocation = adUseClient
On Error Resume Next
4980 gDBRecordConn.Open gTAppLicInfo.SysDBRecordConn
If Err <> 0 Then
Set gDBRecordConn = Nothing
gclsCommon.CBNSplashUnload
MsgBox Error
GoTo ReLogin
End If
On Error GoTo ErrLabel
4990 gclsCommon.CommonAppInfo = gTAppLicInfo
5000 End If
5010 gclsCommon.CommonConnect = gDBRecordConn
If giAppUser = 80 Then
gclsCommon.CBNSplashUnload
Unload frmSplash
GoTo LoadSQLLabel
End If
5020 If giUpdate > 0 Then
5030 If MsgBox("数据库将升级为新的结构,是否继续?", vbOKCancel + vbQuestion) = vbOK Then
5040 Screen.MousePointer = vbDefault
5050 DoEvents
5060 gclsCommon.CBNSplashSetMessage "正在升级数据库"
5070 DoEvents
5080 If Not gTAppLicInfo.SoftNetwork Then
5090 GoTo UpdateDBase
5100 Else
5110 GoTo UpdateSQL
5120 End If
5130 End If
5140 End If
5150 Screen.MousePointer = vbDefault
5160 DoEvents
5170 gclsCommon.CBNSplashUnload
5180 DoEvents
5190 Err.Clear
'2001/9/19客户H增加,因为偶尔出现adoTempRS为Nothing的情况
5200 Set adoTempRS = New ADODB.Recordset
5210 With adoTempRS
5220 .Open "SELECT * FROM T0006S001", gDBRecordConn, adOpenStatic, adLockOptimistic
5230 If Err = -2147217887 Then
5240 ElseIf Err Then
5250 MsgBox Error & vbCrLf & "数据库未升级,退出系统后并重新运行程序以升级数据库!", vbExclamation
5260 funcSetSystemData "Update", 1
5270 GoTo EndLabel
5280 End If
5290 If .RecordCount = 0 Then
5300 MsgBox "数据库未建立成功!,退出系统后并重新运行程序以升级数据库!", vbExclamation
5310 funcSetSystemData "Update", 1
5320 If gclsInclude.MyFileExists(gTAppLicInfo.FilePicSplash) Then Unload frmSplash
5330 GoTo EndLabel
5340 End If
5350 .Filter = "W1182 = '" & gTAppLicInfo.SysLoginUser & "'"
5360 If Not .EOF Then
5370 If Not gTAppLicInfo.SoftNetwork Then
'如果为单机用户,则需要验证口令
5380 If UCase(gclsInclude.MyNz(!W1104, "")) <> _
gclsInclude.MySwitchDEC(sLoginPwd, _
gTAppLicInfo.SysLoginUser, 0) Then
5390 MsgBox "登录身份验证错误,请重新录入!", vbExclamation
5400 GoTo ReLogin
5410 !W1104 = ""
5420 .Update
5430 End If
5440 End If
5450 Else
5460 MsgBox "该用户名不存在,请重新录入", vbExclamation
5470 GoTo ReLogin
5480 End If
5490 gbLoginSuccess = True
5500 If gTAppLicInfo.SysDebugLevel = 10 Then gclsCommon.CBNSaveLogFile "登录成功."
5510 gclsCommon.CBNSetAppInfo gTAppLicInfo
5520 .Filter = 0
5530 .Close
5540 End With
5550 If Not InitParament Then GoTo EndLabel
5560 If gbFirstRun Then
5570 gclsCommon.CBNShowRegistSysCard vbModal
5580 GoTo EndLabel
5590 End If
' gclsCommon.CBNSaveEvents OET_LOGIN, _
IIf(gTAppLicInfo.NeedSwitch, "交接班", _
gTAppLicInfo.SoftCnName & "(" & gTAppLicInfo.SoftLevel & ")"), , _
gTAppLicInfo.SysLoginUser
5610 gclsCommon.CBNSaveEvents OET_LOGIN, _
gTAppLicInfo.SoftCnName & "(" & gTAppLicInfo.SoftLevel & ")"
5620 gTOperRight = gclsCommon.CBNGetOperatorRight(gDBRecordConn, gTAppLicInfo.SysLoginUser)
5630 If gTAppLicInfo.SysDebugLevel = 10 Then _
gclsCommon.CBNSaveLogFile "准备卸载Splash Form."
5640 If gclsInclude.MyFileExists(gTAppLicInfo.FilePicSplash) Then Unload frmSplash
5650 If gTAppLicInfo.SysDebugLevel = 10 Then _
gclsCommon.CBNSaveLogFile "初始化成功,准备加载主程序."
5660 If gTAppLicInfo.SoftNetwork Then
5670 gclsInclude.MySetINIData gTAppLicInfo.FileINI, _
"SQL SERVER", _
"SERVER_HOST", _
gTAppLicInfo.SoftSQLServer
5680 End If
5690 If Not gTAppLicInfo.SysLoginSA Then gTAppLicInfo.SysLoginDebug = False
5700 If gTAppLicInfo.SysLoginDebug Then
5710 gclsCommon.CBNSaveEvents OET_LOGIN_DEBUG
5720 End If
5730 If Not gclsCommon.CBNHavePrinter Then
5740 gTAppLicInfo.CtrlPapleCtrl = False
5750 End If
5760 If gTAppLicInfo.CtrlPapleCtrl Then Set gclsPntCtrl = New BNIncludeProj.clsBNPrinterCtrl
#If APPLICATION_TYPE = 1 Then '考勤
5770 gTHoliSystem = gclsCommon.CBNGetHolidayInfo(True And (giUpdate > 0))
5780 gTPickStruct.TDateRange.DStart = funcGetINIData("Other", _
"INI0302", _
gclsCommon.CBNGetFirstDay(gTAttendCtl.BeginAttendDay))
#Else
5790 gTPickStruct.TDateRange.DStart = funcGetINIData("Other", _
"INI0302", _
gclsCommon.CBNGetFirstDay(1))
#End If
5800 If gTPickStruct.TDateRange.DStart = 0 Then
5810 gTPickStruct.TDateRange.DStart = gclsCommon.CBNGetFirstDay(1)
5820 gTPickStruct.TDateRange.DEnd = gclsInclude.MyDateOf(gclsCommon.CBNGetNow)
5830 End If
5840 gTPickStruct.TempEmp = funcGetINIData("Other", "INI0301", "")
5850 gTPickStruct.TDateRange.DEnd = funcGetINIData("Other", _
"INI0303", _
gclsInclude.MyDateOf(gclsCommon.CBNGetNow))
5860 gclsCommon.CBNSetRegConnect gTAppLicInfo.SoftSQLServer & _
SPLIT_SYMBOL & _
gTAppLicInfo.SysLoginUser & _
SPLIT_SYMBOL & _
sLoginPwd
5870 gclsCommon.CommonOpertorRights = gTOperRight
5880 gclsCommon.CommonAppInfo = gTAppLicInfo
5890 gTAppLicInfo.SoftVersion = gTAppLicInfo.SoftVersion & "(" & gTAppLicInfo.UserAlias & ")"
5900 gTPickStruct.TempNameLists = funcGetINIData("Other", "INI0304", "")
5910 gTPickStruct.TempNumberLists = funcGetINIData("Other", "INI0305", gTPickStruct.TempEmp)
5920 If gTPickStruct.TempNumberLists = "" Then gTPickStruct.TempNumberLists = gTPickStruct.TempEmp
If giAppUser <> 80 Then
5924 Call gclsCommon.CBNSetEventsMask(gbEventMask, giAppUser)
End If
5930 gbFirstLogin = False
'5932 InitVBoost
LoadSQLLabel:
If gTAppLicInfo.CtrlDatabaseLogin Then
Call funcSetINIData("SQL SERVER", "DATABASE", gTAppLicInfo.SoftSQLDBase)
End If
#If APPLICATION_TYPE = 13 Then '超限收费
'gTAixSystemParament.RunType为程序运行方式
'1=计重管理程序
'2=计重主程序
'5934 If gTAixSystemParament.RunType = 2 Then
5940 Load frmAppMain
' Else
'5936 Load frmMain '
'5946 End If
#ElseIf APPLICATION_TYPE = 80 Then
Load frmSQLProcedure
#Else
5948 Load frmMain
#End If
' Load frmMonitor
' If gTAppLicInfo.SysLoginDebug Then
' Else
' Load frmMainDNNew
' Load frmAppClient '
' End If
5950 Exit Sub
ErrLabel:
5960 If Err = -2147217865 Then
5970 MsgBox "SQL数据库已改变,请先删除本系统数据库,然后重新运行本程序"
5980 GoTo EndLabel
5990 ElseIf Err = -2147467259 Then
6000 MsgBox Error
6010 GoTo EndLabel
6020 ElseIf Err = 429 And iPos = 1 Then
6030 MsgBox "程序支持库未升级,请联系软件开发商", vbInformation
ElseIf Err = -2147217843 Then
MsgBox Error
GoTo EndLabel
6040 Else
#If Not IS_RUN Then
6050 Debug.Print Err.Description
#End If
6060 If gTAppLicInfo.SysSystemDebug Then _
MsgBox "错误号:" & Err.Number & ",描述:" & Err.Description & ",Modal:Main" & ",位置=" & Erl
6070 If Not gclsCommon Is Nothing Then _
gclsCommon.CBNSaveLogFile "Err:" & Err.Description & " Modal:Main" & ",位置=" & Erl
6080 Resume Next
6090 End If
6100 Exit Sub
EndLabel:
6110 On Error Resume Next
6120 DoEvents
6130 gclsCommon.CBNSplashSetMessage "正在退出程序"
6140 Screen.MousePointer = vbDefault
6150 DoEvents
If gDBRecordConn.State <> 0 Then
6160 gDBRecordConn.Close
End If
6170 Set gDBRecordConn = Nothing
#If APPLICATION_TYPE = 1 Then '考勤
6180 Erase gTHoliSystem
#End If
6190 gbFirstLogin = True
6200 gclsCommon.CBNUnloadForm "frmMain", Forms
6210 Set gclsDBFunc = Nothing
6220 Set gclsTreeView = Nothing
6230 gclsCommon.CBNSplashUnload
6240 Unload frmSplash
6250 Set frmSplash = Nothing
6260 Set gclsInclude = Nothing
6270 gclsCommon.SetCommon Nothing
6280 Set gclsCommon = Nothing
End Sub
Public Function funcGetINIData(fsINISelect As String, _
fsINIEntry As String, _
Optional ByVal fsDefault As String) As String
funcGetINIData = gclsInclude.MyGetINIData(gTAppLicInfo.FileINI, _
fsINISelect, _
fsINIEntry, _
fsDefault)
End Function
Public Function funcSetINIData(fsINISelect As String, _
fsINIEntry As String, _
Optional ByVal fsDefault As String) As String
gclsInclude.MySetINIData gTAppLicInfo.FileINI, _
fsINISelect, _
fsINIEntry, _
fsDefault
End Function
Public Function funcGetSystemData(fsINIEntry As String, _
Optional ByVal fsDefault As String) As String
funcGetSystemData = gclsInclude.MyGetINIData(gTAppLicInfo.FileINI, _
"System Settings", _
fsINIEntry, _
fsDefault)
End Function
Public Sub funcSetSystemData(ffsINIEntry As String, _
Optional ByVal fsDefault As String)
gclsInclude.MySetINIData gTAppLicInfo.FileINI, _
"System Settings", _
ffsINIEntry, _
fsDefault
End Sub
Public Sub SQL_FUNCTION()
Dim sSQL As String
'得到数据库名,当前用户的数据库用户名,当前用户的系统登录名
sSQL = "SELECT 'database' = db_name(),'user' = user_name(),'login' = suser_name()"
'Lower=LCase;Upper=UCase;SubString=Mid;GetDate=gclsCommon.CBNGetStandTime(gclsCommon.CBNGetNow),
End Sub
Public Sub List_Checked(fList As Control, ByVal fbFlag As Boolean)
Dim i As Integer
For i = 1 To fList.ListCount
fList.Selected(i - 1) = fbFlag
Next i
fList.Refresh
fList.ListIndex = 0
End Sub
Public Sub ShowSplash(fsMsg As String, Optional fsNote As String)
DoEvents
With gclsCommon
.CBNSplashShow
.CBNSplashSetMessage fsMsg
.CBNSplashSetNotes fsNote
End With
DoEvents
End Sub
Public Sub HideSplash(Optional fbShow As Boolean = True)
Dim oForm As Form
gclsCommon.CBNSplashUnload
DoEvents
' If fbShow Then
' For Each oForm In Forms
' If oForm.WindowState = 0 Then
' oForm.Show
' End If
' Next
' End If
End Sub
Public Function ModifyRight(fsField As String, _
fsValue As String, _
feActionEnum As ActionEnum, _
Optional fsOld As String)
Select Case feActionEnum
Case ACT_INC
Case ACT_DEC
Case ACT_SET
End Select
End Function
Public Function IsValidSQL(fsUnitList As String, _
fsDeptList As String, _
ByVal fsEmpNum As String, _
BeginDate As Date, _
EndDate As Date, _
flEmplyComboCount As Long) As Boolean
If Not (gTAppLicInfo.SysLoginSA Or gTAppLicInfo.SysLoginSYS) Then
If Len(gTOperRight.UnitList) + Len(gTOperRight.DeptList) = 0 Then
MsgBox "本用户没操作此功能之权限,请向管理员申请", vbCritical: Exit Function
End If
End If
If BeginDate > EndDate Then
MsgBox ("开始日期不能大于结束日期")
Exit Function
End If
fsEmpNum = gclsCommon.CBNGetFirstData(fsEmpNum)
If fsEmpNum <> VALUE_ALL_STR And fsEmpNum <> "" Then
If Not gclsCommon.CBNIsValidEmployee(fsEmpNum) Then
MsgBox "工号为:" & fsEmpNum & "的人员不存在,请重新选定", vbCritical
Exit Function
End If
ElseIf flEmplyComboCount < 2 Then
' 当人员列表中,个数小于或等于1时,表明可能只有个VALUE_ALL_STR或根本没有内容.
MsgBox "没有选择人员!", vbExclamation: Exit Function
' Else
' If Len(fsUnitList) + Len(fsDeptList) = 0 Then
' MsgBox "请选择有效的部门!", vbExclamation: Exit Function
' End If
End If
IsValidSQL = True
End Function
Public Sub SetAllTableRight(fiFlag As Integer) '设置Public的数据库权限
Dim sAllTables() As String
Dim i As Integer
If Not gTAppLicInfo.SoftNetwork Then Exit Sub
With gclsDBFunc
If fiFlag = 1 Or fiFlag = 3 Then
sAllTables = GetAllViews '对于所有的视图具有读的权限
For i = 0 To UBound(sAllTables)
.dbSetSQLDBRight gDBRecordConn, sAllTables(i), eSELECT
Next i
End If
If fiFlag = 2 Or fiFlag = 3 Then
sAllTables = GetAllTables '对于所有的视图具有读的权限
For i = 0 To UBound(sAllTables)
If UCase(Left(sAllTables(i), 2)) = "A0" Then
.dbSetSQLDBRight gDBRecordConn, sAllTables(i), eSELECT + eUPDATE
Else
.dbSetSQLDBRight gDBRecordConn, sAllTables(i), eSELECT + eDELETE + eINSERT + eUPDATE
End If
Next i
End If
End With
End Sub
Public Function ShowLogin(Optional fsLoginPwd As String) As String
Dim TLoginPara As LoginPara
Dim sPwd As String
Dim sSQL As String
Dim sTemp As String
Dim i As Integer
Dim n As Integer
With TLoginPara
.Caption = "欢迎使用" & gTAppLicInfo.SoftOwnerAlias & _
gTAppLicInfo.SoftName & _
gTAppLicInfo.SoftVersion
.bIsDebug = gTAppLicInfo.SysSystemDebug
.Server = gTAppLicInfo.SoftSQLServer
.User = funcGetSystemData("DefaultLogin", "SA")
.bNeedServer = gTAppLicInfo.SoftNetwork
.EvtTempFile = gTAppLicInfo.FileTemp
.bShowDatabase = gTAppLicInfo.CtrlDatabaseLogin '是否要显示数据库登录的信息
If gTAppLicInfo.CtrlCompanyLogin Then
n = funcGetINIData("Company List", "CompanyCounts", "0")
For i = 1 To n
sTemp = funcGetINIData("Company List", "Company" & i, "登录公司" & i)
.sCompanyList = .sCompanyList & sTemp & SPLIT_SYMBOL
Next i
If .sCompanyList = "" Then
.sCompanyList = "登录公司"
Else
.sCompanyList = Left(.sCompanyList, Len(.sCompanyList) - Len(SPLIT_SYMBOL))
End If
End If
.DebugCode = Left(gTAppLicInfo.SoftEnName, 1)
If gTAppLicInfo.CtrlDatabaseLogin Then
.bShowDatabase = True
.Database = gTAppLicInfo.SoftSQLDBase
End If
' .bNeedSwitch = True
gbLoginSuccess = gclsCommon.CBNShowLogin(TLoginPara)
If .User <> "" Then
If gDBRecordConn Is Nothing Then
ShowLogin = "2"
Else
fsLoginPwd = UCase(.Pwd)
sPwd = gclsInclude.MySwitchDEC(fsLoginPwd, UCase(.User), 0)
If gTAppLicInfo.SoftNetwork Then
sSQL = "SELECT * FROM T0006S001 WHERE W1182 = '" & UCase(.User) & "'"
Else
sSQL = "SELECT * FROM T0006S001 WHERE (W1104 ='" & sPwd & "'" & _
IIf(fsLoginPwd = "", " OR W1104 IS NULL", "") & ") AND (W1182 = '" & UCase(.User) & "')"
End If
If gDBRecordConn.Execute(sSQL).RecordCount > 0 Then
ShowLogin = "1"
gTOperRight = gclsCommon.CBNGetOperatorRight(gDBRecordConn, UCase(.User))
Else
' MsgBox "登录身份验证错误!", vbCritical
ShowLogin = "0"
End If
End If
Else
ShowLogin = ""
End If
'*****************加入供应商代码********************************
gsVendorCode = "123"
'***************************************************************
If ShowLogin <> "1" And ShowLogin <> "2" Then Exit Function
i = InStr(1, .sCompanyList, SPLIT_SYMBOL)
If i > 0 Then
gTAppLicInfo.SysLoginCompany = Left(.sCompanyList, i - 1)
End If
gTAppLicInfo.SysLoginUser = UCase(.User)
fsLoginPwd = UCase(.Pwd)
gTAppLicInfo.SoftSQLServer = UCase(.Server)
gTAppLicInfo.SysLoginDebug = .bDebugLogin
If gTAppLicInfo.CtrlDatabaseLogin Then
gTAppLicInfo.SoftSQLDBase = .Database
End If
With gTAppLicInfo
If .SysLoginDebug Then .SysSystemDebug = .SysLoginDebug
gclsDBFunc.dbSetDebug .SysSystemDebug
.SysLoginSYS = False
.SysLoginSA = False
Select Case UCase(.SysLoginUser)
Case "SA"
.SysLoginSA = True
Case "SYS"
.SysLoginSYS = True
Case Else
'程序内定的：基于SYS开头的用户全部具备SYS权限，例如SYS08
.SysLoginSYS = (UCase(.SysLoginUser) = "SYS") Or _
(UCase(.SysLoginUser) Like "SYS#") Or _
(UCase(.SysLoginUser) Like "SYS##") Or _
(UCase(.SysLoginUser) Like "SYS###")
End Select
End With
gclsCommon.CommonOpertorRights = gTOperRight
gclsCommon.CommonAppInfo = gTAppLicInfo
End With
End Function
Public Sub CloseOtherWindows(Optional fsForm As String, Optional fbUnload As Boolean)
Dim frmTemp As Form
If gTAppLicInfo.CtrlRunSingle Or fbUnload Then
For Each frmTemp In Forms
' If frmTemp.Visible Then
If frmTemp.Name <> "frmMain" Then
Unload frmTemp
End If
' End If
Next
If fsForm <> "" Then gclsCommon.CBNCloseAllForm fsForm
End If
End Sub
Public Sub SavePickStruct(fBNListTree1 As BNListTree, _
fTDateRange As DateRange, _
Optional fcobEmployee)
Dim i As Integer
With gTPickStruct
If Not IsMissing(fcobEmployee) Then
If fcobEmployee <> "" And fcobEmployee <> VALUE_ALL_STR Then
If fcobEmployee.ListCount > 0 Then
ReDim .Employee(fcobEmployee.ListCount - 1)
For i = 0 To fcobEmployee.ListCount - 1
.Employee(i) = fcobEmployee.List(i)
Next i
Else
ReDim .Employee(0)
End If
.TempEmp = fcobEmployee
End If
End If
If fTDateRange.DStart > 0 Then
.TDateRange.DStart = gclsInclude.MyDateOf(fTDateRange.DStart)
.TDateRange.DEnd = gclsInclude.MyDateOf(fTDateRange.DEnd)
End If
.UnitLists = fBNListTree1.UnitList
.DeptLists = fBNListTree1.DeptList
End With
End Sub
Public Sub LoadPickStruct(fBNListTree1 As BNListTree, _
fTDateRange As DateRange, _
Optional fcobEmployee)
With gTPickStruct
If Not IsMissing(fcobEmployee) Then
If .TempEmp <> VALUE_ALL_STR Then fcobEmployee = .TempEmp
End If
If .TDateRange.DStart > 0 Then
fTDateRange = .TDateRange
Else
#If APPLICATION_TYPE = 1 Then '考勤
.TDateRange.DStart = gclsCommon.CBNGetFirstDay(gTAttendCtl.BeginAttendDay)
#Else
.TDateRange.DStart = gclsCommon.CBNGetFirstDay(1)
#End If
.TDateRange.DEnd = gclsInclude.MyDateOf(gclsCommon.CBNGetNow)
fTDateRange = .TDateRange
End If
End With
End Sub
Public Function GetNote(ByVal fNoteType As WorkState, _
Optional fsNewNote As String) As String
If fNoteType = WK_CLASSCOMPOUND Then
GetNote = "有合成班"
ElseIf fNoteType = WK_NOCLASS Then
GetNote = "无班次"
ElseIf fNoteType = WK_SIGN Then
GetNote = "签卡" & fsNewNote
ElseIf fNoteType = WK_ABSENT Then
GetNote = "缺卡" & fsNewNote
ElseIf fNoteType = WK_REST Then
GetNote = "休日"
ElseIf fNoteType = WK_HOLIDAY Then
GetNote = fsNewNote
ElseIf fNoteType = WK_ADJUSTWORK Then
GetNote = IIf(gbNoteShow, "调整" & fsNewNote, "")
ElseIf fNoteType = WK_TOCLASS Then
GetNote = IIf(gbNoteShow, fsNewNote, "")
ElseIf fNoteType = WK_FROMCLASS Then
GetNote = IIf(gbNoteShow, fsNewNote, "")
ElseIf fNoteType = WK_OUTRANGE Then
GetNote = IIf(gbNoteShow, "超出范围", "")
End If
If GetNote <> "" Then GetNote = "," & GetNote
End Function
Public Function GetTblsInQuery(fsQryName As String) As String()
Dim sSQL As String
' Debug.Assert fsQryName <> "QT6621A001_001"
sSQL = GetQueriyItem(fsQryName)
If sSQL = "" Then
sSQL = gclsCommon.CBNGetQueriyItem(fsQryName)
End If
GetTblsInQuery = gclsCommon.CBNGetTblsInQuery(sSQL)
End Function
Public Sub SaveAllPickStruct()
With gclsInclude
.MySetINIData gTAppLicInfo.FileINI, "Other", "INI0301", gTPickStruct.TempEmp
.MySetINIData gTAppLicInfo.FileINI, "Other", "INI0302", gTPickStruct.TDateRange.DStart
.MySetINIData gTAppLicInfo.FileINI, "Other", "INI0303", gTPickStruct.TDateRange.DEnd
.MySetINIData gTAppLicInfo.FileINI, "Other", "INI0304", gTPickStruct.TempNameLists
.MySetINIData gTAppLicInfo.FileINI, "Other", "INI0305", gTPickStruct.TempNumberLists
End With
End Sub
Public Function UpdateVertion(fadoTempRS As ADODB.Recordset) As Boolean
Dim sTemp As String
Dim lNewSoftLevel As Long
With fadoTempRS
.Filter = "W1101 = 'W" & gTAppLicInfo.SoftNumber & "BA'"
If .EOF Then Exit Function
lNewSoftLevel = Val(!W1102)
If (gTAppLicInfo.SoftLevel < lNewSoftLevel) And (gclsCommon.CBNGetNow > gDCanUpdate) Then
If lNewSoftLevel - gTAppLicInfo.SoftLevel >= 10 Then
If gclsInclude.MyFileExists(gTAppLicInfo.FileInstall) Then
If MsgBox("本程序版本过期,请及时下载并使用新的程序!" & vbCrLf & _
gTAppLicInfo.SoftInstallTips, vbCritical + vbOKCancel) = vbOK Then
gclsInclude.MyRunProgram gTAppLicInfo.FileInstall
End If
Else
MsgBox "本程序版本过期,请及时下载并做更新!" & vbCrLf & _
gTAppLicInfo.SoftInstallTips, vbInformation
End If
UpdateVertion = True
Exit Function
Else
If gclsInclude.MyFileExists(gTAppLicInfo.FileInstall) Then
If MsgBox("本程序已有新的版本,请及时下载并做更新!更新请使用<确定>按纽." & _
vbCrLf & gTAppLicInfo.SoftInstallTips, vbInformation + vbOKCancel) = vbOK Then
gclsInclude.MyRunProgram gTAppLicInfo.FileInstall
UpdateVertion = True
Exit Function
End If
Else
MsgBox "本程序已有新的版本,请及时下载并做更新!" & vbCrLf & _
gTAppLicInfo.SoftInstallTips, vbInformation
End If
End If
ElseIf gTAppLicInfo.SoftLevel > lNewSoftLevel Then
If gTAppLicInfo.SysLoginSA Then
!W1102 = gTAppLicInfo.SoftLevel
.Update
sTemp = GetInstallTips(gTAppLicInfo.SoftLevel)
If sTemp <> "" Then
.Filter = "W1101 = 'W" & gTAppLicInfo.SoftNumber & "BH'" '更新安装提示 sTemp
!W1102 = sTemp
.Update
gTAppLicInfo.SoftInstallTips = sTemp
End If
End If
End If
End With
End Function
Public Function InitParament() As Boolean
Dim adoTempRS As ADODB.Recordset
Set adoTempRS = New ADODB.Recordset
InitParament = True
With adoTempRS
.Open "SELECT * FROM T0101S001", _
gDBRecordConn, _
adOpenStatic, _
IIf(gTAppLicInfo.SysLoginSA, adLockOptimistic, adLockReadOnly)
.Filter = "W1101 = 'W010A'"
If Not .EOF Then gTAppLicInfo.SoftCommPasswd = !W1102
If gTAppLicInfo.SoftCommPasswd = "" Then
gTAppLicInfo.SoftCommPasswd = gclsCommon.CBNGetCommPwd(gTAppLicInfo.FileEncrypt)
End If
.Filter = "W1101 = 'W010B'"
If Not .EOF Then
glMsgAdd = !W1102
Else
glMsgAdd = 10
End If
.Filter = "W1101 = 'W010C'"
If Not .EOF Then gTAppLicInfo.UserName = !W1102
.Filter = "W1101 = 'W030A'"
If Not .EOF Then
gTAppLicInfo.OthEmpNoLen = !W1102
Else
gTAppLicInfo.OthEmpNoLen = 8
End If
.Filter = "W1101 = 'W030B'"
If Not .EOF Then
gTAppLicInfo.OthDptNoLen = !W1102
Else
gTAppLicInfo.OthDptNoLen = 4
End If
.Filter = "W1101 = 'W030C'"
If Not .EOF Then gTAppLicInfo.OthDptUseTree = IIf(!W1102 = 1, True, False)
.Filter = "W1101 = 'W" & gTAppLicInfo.SoftNumber & "BB'"
If Not .EOF Then gTAppLicInfo.FileInstall = !W1102
.Filter = "W1101 = 'W" & gTAppLicInfo.SoftNumber & "BH'"
If Not .EOF Then gTAppLicInfo.SoftInstallTips = !W1102
If UpdateVertion(adoTempRS) Then
InitParament = False
Exit Function
End If
.Filter = "W1101 = 'W" & gTAppLicInfo.SoftNumber & "BC'"
If .EOF Then
If gTAppLicInfo.SysLoginSA Then
.AddNew
!W1101 = "W" & gTAppLicInfo.SoftNumber & "BC"
!W1102 = gTAppLicInfo.SoftVersion
.Update
End If
Else
#If IS_RUN Then
If Not gTAppLicInfo.SysLoginDebug Then
If gTAppLicInfo.SoftVersion <> !W1102 Then
MsgBox "应用程序和数据库的版本不一致,请使用正确的版本!", vbCritical
InitParament = False
Exit Function
!W1102 = gTAppLicInfo.SoftVersion
.Update
End If
End If
#End If
End If
.Filter = "W1101 = 'W" & gTAppLicInfo.SoftNumber & "BD'"
If Not .EOF Then
If !W1102 = "0" Then
gbFirstRun = True
Else
gbFirstRun = False
End If
End If
.Filter = "W1101 = 'W" & gTAppLicInfo.SoftNumber & "BE'"
If Not .EOF Then gDCanUpdate = !W1102
.Filter = "W1101 = 'W" & gTAppLicInfo.SoftNumber & "BG'"
If Not .EOF Then gTAppLicInfo.SysLockCal = IIf(!W1102 = 1, True, False)
'******************************* 考勤专用开始 ***********************************
'*
#If APPLICATION_TYPE = 1 Then
.Filter = "W1101 = 'W660A'"
If Not .EOF Then gTAttendCtl.Need30Rnd = IIf(!W1102 = 1, True, False)
.Filter = "W1101 = 'W660B'"
If Not .EOF Then gTAttendCtl.BeginAttendDay = !W1102
If (gTAttendCtl.BeginAttendDay < 1) Or (gTAttendCtl.BeginAttendDay > 31) Then _
gTAttendCtl.BeginAttendDay = 1
.Filter = "W1101 = 'W660C'"
If Not .EOF Then gTAttendCtl.HaveAbsent = IIf(!W1102 = "1", True, False)
.Filter = "W1101 = 'W660D'"
If Not .EOF Then gTAttendCtl.HaveLate = IIf(!W1102 = "1", True, False)
.Filter = "W1101 = 'W660E'"
If Not .EOF Then gTAttendCtl.MorningTimePot = !W1102
.Filter = "W1101 = 'W660F'"
If Not .EOF Then gTAttendCtl.NightTimePot = !W1102
.Filter = "W1101 = 'W660G'"
If Not .EOF Then gTAttendCtl.ELStandard = IIf(!W1102 = "1", True, False)
.Filter = "W1101 = 'W660H'"
If Not .EOF Then gTAttendCtl.FeastEquNormal = IIf(!W1102, True, False)
.Filter = "W1101 = 'W660I'"
If Not .EOF Then gTAttendCtl.Use1CardRange = IIf(!W1102, True, False)
.Filter = "W1101 = 'W660J'"
If Not .EOF Then gTAttendCtl.MustAddTime = !W1102
.Filter = "W1101 = 'W660K'"
If Not .EOF Then gTAttendCtl.NightWorkTimePot = !W1102
.Filter = "W1101 = 'W660L'"
If Not .EOF Then gTAttendCtl.FeastRestToDay = IIf(!W1102, True, False)
.Filter = "W1101 = 'W660M'"
If Not .EOF Then gTAttendCtl.HaveAdd = IIf(!W1102 = "1", True, False)
.Filter = "W1101 = 'W660N'"
If Not .EOF Then gTAttendCtl.NeedAddSheet = IIf(!W1102 = "1", True, False)
.Filter = "W1101 = 'W660O'"
If Not .EOF Then gTAttendCtl.MustOver8 = IIf(!W1102 = "1", True, False)
.Filter = "W1101 = 'W660P'"
If Not .EOF Then gTAttendCtl.AttRptGroup = IIf(!W1102 = "1", True, False)
.Filter = "W1101 = 'W660Q'"
If Not .EOF Then gTAttendCtl.SpecCard = IIf(!W1102 = "1", True, False)
.Filter = "W1101 = 'W660R'"
If Not .EOF Then gTAttendCtl.AddLater = IIf(!W1102 = "1", True, False)
.Filter = "W1101 = 'W" & gTAppLicInfo.SoftNumber & "BF'"
If Not .EOF Then gTAttendCtl.DistinctCard = IIf(!W1102 = "1", True, False)
'*
'******************************* 考勤专用结束 ***********************************
#ElseIf APPLICATION_TYPE = 3 Then '巡更
.Filter = "W1101 = 'W300A'"
If Not .EOF Then
glErrPatrol = !W1102
Else
glErrPatrol = 5
End If
#End If
If gTAppLicInfo.SysDebugLevel = 10 Then gclsCommon.CBNSaveLogFile "准备关闭临时变量."
.Close
End With
If gTAppLicInfo.SysDebugLevel = 10 Then gclsCommon.CBNSaveLogFile "准备卸载临时变量."
Set adoTempRS = Nothing
End Function
'针对每个版本的修改提示
Public Function GetInstallTips(flVerLevel As Long) As String
Dim DDate As Date
#If APPLICATION_TYPE = 1 Then '考勤
Select Case flVerLevel
Case 72
DDate = #10/23/2002# '在客户B
GetInstallTips = "程序更新了一个打卡段班次中关于加班单控制的问题，同时增加了数据库恢复功能。"
Case 73
DDate = #10/23/2002# '在客户B
GetInstallTips = "修改了在报表预览中选择一个人员时显示全部的错误，同时增加了数据库备份功能。"
Case 74
DDate = #12/3/2002# '在客户B
GetInstallTips = "修改了周日加班单问题，同时修改了巡更班次设置和排班功能。"
Case 75
DDate = #1/15/2003# '在家
GetInstallTips = "增加了第5个周六（指标为E6613）加班制度，同时修改了“职日”班次加班问题。"
End Select
#ElseIf APPLICATION_TYPE = 3 Then '巡更
Select Case flVerLevel
Case 3
DDate = #12/5/2002# '在客户B
GetInstallTips = "程序更新了菜单权限控制问题，同时对发行巡更卡的BUG进行了修改。"
End Select
#End If
GetInstallTips = " " & GetInstallTips & vbCrLf & String(40, " ") & DDate
End Function
Public Sub ShowMyError(fsModule As String, fsProcedure As String, _
flErrorNumber As Long, fsErrorDescription As String)
On Error GoTo PROC_ERR
Dim sMessage As String
Dim sCaption As String
sMessage = "Error: " & fsErrorDescription & vbCrLf & vbCrLf & _
"Module: " & fsModule & vbCrLf & _
"Procedure: " & fsProcedure & vbCrLf & vbCrLf & _
"Please notify My Software's tech suppor " & _
"at " & gTAppLicInfo.SoftAuthorPhone & " about this issue." & vbCrLf & _
"Please provide the support technician with " & _
"information shown in " & vbCrLf & "this dialog " & _
"box as well as an explanation of what you " & _
"were" & vbCrLf & "doing when this " & _
"error occurred."
sCaption = "Unexpected Error! Version: " & gTAppLicInfo.SoftVersion
MsgBox sMessage, vbCritical, sCaption
PROC_EXIT:
Exit Sub
PROC_ERR:
Resume Next
End Sub
Public Sub FuncSaveEvents(fsEvents As OptionEvent, _
Optional fsData1 As String, _
Optional fsData2 As String, _
Optional LoginUser As String)
Dim sCmd As String
If LoginUser = "" Then LoginUser = gTAppLicInfo.SysLoginUser
gclsCommon.CBNSaveEvents fsEvents, fsData1, fsData2, LoginUser
If gbIsServer Then Exit Sub '服务器并不保存自身做过的数据
If gTAppLicInfo.CtrlDBaseSync And gbConnectOK Then
' If gCtrlDBShell Is Nothing Then Exit Sub
'' sCmd = "AD" & eUP_SaveEvents & ":" & fsEvents & SPLIT_SYMBOL & fsData1 & SPLIT_SYMBOL & fsData2 & SPLIT_SYMBOL & LoginUser
' sCmd = gclsInclude.MyCmdCodeSendStr(sCmd)
' gCtrlDBShell.BoardcastMessage sCmd
End If
End Sub
Public Function CreateDllItem(RelPath As String, _
fsItem As String, _
hRetMode As Long) As IUnknown
Dim pCF As IClassFactory 'ObjCreate.olb
Dim strclsID As String
Dim udtclsID As clsID 'VBoostTypes6.olb
If hRetMode = 0 Then
strclsID = LoGetDllGUID(RelPath, fsItem) '
If strclsID = "" Then
MsgBox "加载" & RelPath & "错误,请检查!", vbCritical
Exit Function
End If
udtclsID = GUIDFromString(strclsID)
Set pCF = GetDllClassObject(RelPath, udtclsID, hRetMode) 'modCOMDllLoader.mod
Else
Set pCF = GetDllClassObject(RelPath, udtclsID, hRetMode)
End If
Set CreateDllItem = pCF.CreateInstance(Nothing, IID_IUnknown)
End Function
Public Sub UnloadDll()
TestUnloadDll m_hModBNInclude
TestUnloadDll m_hModBNTreeView
TestUnloadDll m_hModBNCommon
TestUnloadDll m_hModBNDBFunc
End Sub
Public Function InIDE() As Boolean
'当程序被编译后,Debug.Assert将忽略,所以利用这个特性来指示目前是在VB的设计环境还是在自动运行的环境中.
Debug.Assert Not LoTestIDE(InIDE)
End Function
Private Function LoTestIDE(Test As Boolean) As Boolean
Test = True
End Function
Private Function LoGetDllGUID(fsFile As String, fsItem As String) As String
On Error Resume Next
If fsFile <> vbNullString Then
LoGetDllGUID = TLI.TypeLibInfoFromFile(fsFile).TypeInfos.NamedItem(fsItem).Guid
End If
End Function
Public Function HelpTable(fsTable As String) As String
HelpTable = gclsCommon.CBNGetTblStructNote(fsTable, 4, True, , , True)
End Function
Public Sub WriteSysLogFile(Optional ByVal fsData As String, _
Optional ByVal fbAddTime As Boolean)
' If Not gTAppLicInfo.CtrlNeedMonitor Then Exit Sub
gclsInclude.MyWriteLogFile fsData & IIf(fbAddTime, "," & gclsCommon.CBNGetNow, ""), fbAddTime, gTAppLicInfo.FilePathApp & "Log\" & gTAppLicInfo.SoftEnName & "_" & Format(gclsCommon.CBNGetNow, "YYMMDDHHMMSS") & ".log"
End Sub