📄 系统_基本函数模块.bas
字号:
xh1:
Do While j <= len_mje1 And Bz
ws1 = Int(Mid(Mje1, j, 1)) * 2 - 1
If ws1 > 0 Then
Name = Name + MidB(Name1, ws1, 2) + MidB(Name2, k, 2)
j = j + 1
k = k - 2
GoTo xh1
End If
m = 0
xh2:
Do While ws1 < 0
If len_mje1 >= 11 Then
If k < 21 Then
m = m + 1
End If
End If
If k = 5 Or (k = 13 And m <= 3) Or k = 21 Then
Name = Name + MidB(Name2, k, 2)
End If
If k = 1 Then
Name = Name + "整"
Bz = False
Exit Do
End If
j = j + 1
k = k - 2
ws1 = Int(Mid(Mje1, j, 1)) * 2 - 1
If ws1 < 0 Then
GoTo xh2
Else
If len_mje1 = 3 Then
Name = Name + "零"
Else
Name = Name + "零"
End If
End If
Loop
Loop
'去掉元和角之间零(1230.32)
wz1 = InStr(1, Name, "元")
wz2 = InStr(1, Name, "角")
If wz1 <> 0 And wz2 <> 0 Then
wz3 = InStr(wz1, Name, "零")
If wz3 <> 0 Then
Name = Mid(Name, 1, wz3 - 1) + Mid(Name, wz3 + 1, Len(Name))
End If
End If
Fun_Jezh = Name
End Function
Public Function GetPY(a1 As String) As String '返回拼音码字符串
'输入参数:a1 输入字符串
Dim jsqte As Integer
Dim t1 As String
GetPY = ""
If Len(Trim(a1)) = 0 Then
Exit Function
End If
For jsqte = 1 To Len(Trim(a1))
t1 = Mid(a1, jsqte, 1)
If Asc(t1) < 0 Then
If Asc(t1) < Asc("啊") Then
GetPY = GetPY + t1
GoTo L1
End If
If Asc(t1) >= Asc("啊") And Asc(t1) < Asc("芭") Then
GetPY = GetPY + "A"
GoTo L1
End If
If Asc(t1) >= Asc("芭") And Asc(t1) < Asc("擦") Then
GetPY = GetPY + "B"
GoTo L1
End If
If Asc(t1) >= Asc("擦") And Asc(t1) < Asc("搭") Then
GetPY = GetPY + "C"
GoTo L1
End If
If Asc(t1) >= Asc("搭") And Asc(t1) < Asc("蛾") Then
GetPY = GetPY + "D"
GoTo L1
End If
If Asc(t1) >= Asc("蛾") And Asc(t1) < Asc("发") Then
GetPY = GetPY + "E"
GoTo L1
End If
If Asc(t1) >= Asc("发") And Asc(t1) < Asc("噶") Then
GetPY = GetPY + "F"
GoTo L1
End If
If Asc(t1) >= Asc("噶") And Asc(t1) < Asc("哈") Then
GetPY = GetPY + "G"
GoTo L1
End If
If Asc(t1) >= Asc("哈") And Asc(t1) < Asc("击") Then
GetPY = GetPY + "H"
GoTo L1
End If
If Asc(t1) >= Asc("击") And Asc(t1) < Asc("喀") Then
GetPY = GetPY + "J"
GoTo L1
End If
If Asc(t1) >= Asc("喀") And Asc(t1) < Asc("垃") Then
GetPY = GetPY + "K"
GoTo L1
End If
If Asc(t1) >= Asc("垃") And Asc(t1) < Asc("妈") Then
GetPY = GetPY + "L"
GoTo L1
End If
If Asc(t1) >= Asc("妈") And Asc(t1) < Asc("拿") Then
GetPY = GetPY + "M"
GoTo L1
End If
If Asc(t1) >= Asc("拿") And Asc(t1) < Asc("哦") Then
GetPY = GetPY + "N"
GoTo L1
End If
If Asc(t1) >= Asc("哦") And Asc(t1) < Asc("啪") Then
GetPY = GetPY + "O"
GoTo L1
End If
If Asc(t1) >= Asc("啪") And Asc(t1) < Asc("期") Then
GetPY = GetPY + "P"
GoTo L1
End If
If Asc(t1) >= Asc("期") And Asc(t1) < Asc("然") Then
GetPY = GetPY + "Q"
GoTo L1
End If
If Asc(t1) >= Asc("然") And Asc(t1) < Asc("撒") Then
GetPY = GetPY + "R"
GoTo L1
End If
If Asc(t1) >= Asc("撒") And Asc(t1) < Asc("塌") Then
GetPY = GetPY + "S"
GoTo L1
End If
If Asc(t1) >= Asc("塌") And Asc(t1) < Asc("挖") Then
GetPY = GetPY + "T"
GoTo L1
End If
If Asc(t1) >= Asc("挖") And Asc(t1) < Asc("昔") Then
GetPY = GetPY + "W"
GoTo L1
End If
If Asc(t1) >= Asc("昔") And Asc(t1) < Asc("压") Then
GetPY = GetPY + "X"
GoTo L1
End If
If Asc(t1) >= Asc("压") And Asc(t1) < Asc("匝") Then
GetPY = GetPY + "Y"
GoTo L1
End If
If Asc(t1) >= Asc("匝") Then
GetPY = GetPY + "Z"
GoTo L1
End If
Else
If UCase(t1) <= "Z" And UCase(t1) >= "A" Then
GetPY = GetPY + UCase(t1)
Else
GetPY = t1
End If
End If
L1:
Next jsqte
End Function
'==============================================================================='
Public Function Xtxxts(xttsxx As String, xttslb As enumMsgType, Tbtslb As enumIcon) '系统信息提示
msgtitle = "宇迪光学/ERP2.00-库存管理系统"
Select Case xttslb
Case 0 '确定
Xtxxts = MsgBox(xttsxx, Tbtslb * 16, msgtitle)
Case 1 'YES/NO
Xtxxts = MsgBox(xttsxx, vbYesNo + Tbtslb * 16, msgtitle)
Case 2 '确定/取消
Xtxxts = MsgBox(xttsxx, vbOKCancel + Tbtslb * 16, msgtitle)
Case Else
Xtxxts = "9"
End Select
End Function
Public Sub Sub_SetOperStatus(Str_OperStatus As String) '显示系统操作状态
If Trim(Str_OperStatus) <> "" Then
XT_Main.StatusBar1.Panels("OperStatus") = Str_OperStatus
Else
XT_Main.StatusBar1.Panels("OperStatus") = "就绪"
End If
End Sub
Public Function MachineName() As String '取得当前工作站名
Dim sBuffer As String * 255
If GetComputerName(sBuffer, 255&) <> 0 Then
MachineName = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)
Else
MachineName = "(未知)"
End If
End Function
Public Function NTDomainUserName() As String '取得当前网络用户名
Dim strBuffer As String * 255
Dim lngBufferLength As Long
Dim lngRet As Long
Dim StrTemp As String
lngBufferLength = 255
lngRet = GetUserName(strBuffer, lngBufferLength)
StrTemp = UCase(Trim$(strBuffer))
NTDomainUserName = Left$(StrTemp, lngBufferLength - 1)
End Function
Public Sub Xtcsh() '系统主控制台及全局变量初始化
Dim Xtsjljc As String '系统数据连接串
Dim Xtrlrec As New Recordset
Dim czrq As String
ErpPassWord = "Gen13301481112"
'从注册表中取信息
Xtsjljc = GetSetting(Ebo_gsProductName, Ebo_gsPrjName, "Xtsjljc")
If Trim(Xtsjljc) = "" Then
Call Xtxxts("系统没有注册!", 0, 1)
End
End If
Xt_RoleCode = GetSetting(Ebo_gsProductName, Ebo_gsPrjName, "Xt_RoleCode")
Xtczy = GetSetting(Ebo_gsProductName, Ebo_gsPrjName, "Xtczy")
Xtczybm = GetSetting(Ebo_gsProductName, Ebo_gsPrjName, "Xtczybm")
Xtztbm = GetSetting(Ebo_gsProductName, Ebo_gsPrjName, "Xtztbm", "001")
Xtdwm = GetSetting(Ebo_gsProductName, Ebo_gsPrjName, "Xtdwm")
czrq = GetSetting(Ebo_gsProductName, Ebo_gsPrjName, "Xtrq") '业务操作日期
Xtrq = CDate(czrq) '业务操作日期
Xtyear = GetSetting(Ebo_gsProductName, Ebo_gsPrjName, "XtYear") '系统年度
ServerName = GetSetting(Ebo_gsProductName, Ebo_gsPrjName, "ServerName")
Xtkjqjgs = 12
'数据连接
If Cw_DataEnvi.DataConnect.State = 1 Then Cw_DataEnvi.DataConnect.Close
Cw_DataEnvi.DataConnect.Open Xtsjljc, "Ebodiy2008", ErpPassWord
'用户选择系统会计期间
Set Xtrlrec = Cw_DataEnvi.DataConnect.Execute("Select * From Gy_kjrlb where qsrq<='" + czrq + "' and zzrq>='" + czrq + "'")
If Not Xtrlrec.EOF Then
Xtmm = Xtrlrec.Fields("Period")
End If
'Call Drxtztcs '读入系统帐套参数
With XT_Main.StatusBar1
.Panels("OperStatus") = "就绪"
.Panels("zt").Text = Xtdwm
.Panels("czy").Text = Fun_PickMaker(Xtczy)
.Panels("rq").Text = "业务日期:" + Format(Xtrq, "yyyy-mm-dd")
.Panels("rjbb").Text = "【宇迪光学/ERP】"
End With
End Sub
Public Function Fun_PickMaker(sParam As String) As String 'xtczy 登陆用户
'取最后一个“.”后的字符串
Dim iPos As Integer
Dim sTmp As String
If Trim(sParam) = "" Then Exit Function
sTmp = Trim(sParam)
iPos = InStr(1, sTmp, ".", vbTextCompare)
While iPos <> 0
sTmp = Mid(sTmp, iPos + 1, Len(sTmp) - iPos)
iPos = 0
iPos = InStr(1, sTmp, ".", vbTextCompare)
Wend
Fun_PickMaker = sTmp
End Function
'===================以下为系统权限控制与上机日志控制函数======================'
Public Function Security_Log(gnsy As String, UserCode As String, Optional LogTF As Integer = 3, Optional State As Boolean = True, Optional Msg As Boolean = True) As Boolean '权限判断和日志
'Gnsy 功能索引 UserCode 用户编码
'LogTF (1、判断权限，写日志)、（2、只写日志）、（3、只判断权限）
'State 状态 (True 进入 false 完成)
'返回Security_Log=true表示有权限，Security_Log=false表示没有有权限
'Msg 没有权限时是否提示（True 提示 False不提示）
Dim Tsxx As String '系统信息提示
On Error Resume Next
Dim aDo_userGroup As New Recordset
Dim aDo_gnbm As New Recordset: Dim SSql As String
Set aDo_gnbm = Cw_DataEnvi.DataConnect.Execute("select * from Xt_xtgnb where gnsy='" & Trim(gnsy) & "'")
If LogTF = 1 Or LogTF = 3 Then
Set aDo_userGroup = Cw_DataEnvi.DataConnect.Execute("select * from Gy_Czygl where czybm='" & Trim(UserCode) & "'")
If Mid(aDo_userGroup!AuthorityID, aDo_gnbm!Id, 1) = "1" Then
Security_Log = True
Else
Security_Log = False
End If
aDo_userGroup.Close
Set aDo_userGroup = Nothing
If Security_Log = False Then
Set aDo_userGroup = Cw_DataEnvi.DataConnect.Execute("select * from System_UserGroupInfo a ,System_UserGroup b where a.groupid=b.groupid and a.userid='" & Trim(UserCode) & "'")
Do While Not aDo_userGroup.EOF
If Mid(aDo_userGroup!AuthorityID, aDo_gnbm!Id, 1) = "1" Then
Security_Log = True
Exit Do
Else
Security_Log = False
End If
aDo_userGroup.MoveNext
Loop
aDo_userGroup.Close
Set aDo_userGroup = Nothing
End If
If Security_Log = False Then
If Msg = True Then
Tsxx = "没有权限,请与管理员联系！ "
Call Xtxxts(Tsxx, 0, 4)
End If
End If
End If
'------------------------------------
If (LogTF = 1 And Security_Log = True) Or LogTF = 2 Then
If State = True Then
SSql = "insert into System_Log(GeginDate,userid,WorkstationName,WorkList,SystemName,NetUserName,State)" _
& " values(getdate(),'" & UserCode & "','" & MachineName & "','" & Trim("" & aDo_gnbm!gnmc) & "','" & "库存管理系统 " & " ','" & NTDomainUserName & "','进入')"
Else
SSql = "insert into System_Log(GeginDate,userid,WorkstationName,WorkList,SystemName,NetUserName,State)" _
& " values(getdate(),'" & UserCode & "','" & MachineName & "','" & Trim("" & aDo_gnbm!gnmc) & "','" & "库存管理系统 " & " ','" & NTDomainUserName & "','完成')"
End If
Cw_DataEnvi.DataConnect.Execute SSql
End If
aDo_gnbm.Close
Set aDo_gnbm = Nothing
End Function
'==============================================================================='
Public Function Gsdate() As Date '服务器系统日期函数
Dim RsGdate As ADODB.Recordset
Set RsGdate = New Recordset
RsGdate.Open "select getdate() as Gdate", Cw_DataEnvi.DataConnect, adOpenKeyset, adLockOptimistic
Gsdate = Year(RsGdate!Gdate) & "-" & Month(RsGdate!Gdate) & "-" & Day(RsGdate!Gdate)
RsGdate.Close
Set RsGdate = Nothing
End Function
Public Function GsdateT() As Date '服务器系统日期函数
Dim RsGdateT As ADODB.Recordset
Set RsGdateT = New Recordset
RsGdateT.Open "select getdate() as Gdate", Cw_DataEnvi.DataConnect, adOpenKeyset, adLockOptimistic
GsdateT = RsGdateT!Gdate
RsGdateT.Close
Set RsGdateT = Nothing
End Function
Public Function BoolDate(GCdate As Date) As Boolean '服务器系统日期与登陆日期对比函数
If Day(Gsdate) > 28 Then
If Year(Gsdate) = Year(GCdate) And Month(Gsdate) = Month(GCdate) And Day(GCdate) > 20 Then
BoolDate = True
Else
BoolDate = False
End If
Else
If Year(Gsdate) = Year(GCdate) And Month(Gsdate) = Month(GCdate) Then
BoolDate = True
ElseIf Year(Gsdate) = Year(GCdate) And Month(Gsdate) = Month(GCdate) + 1 And Day(GCdate) > 20 Then
BoolDate = True
ElseIf Year(Gsdate) = Year(GCdate) + 1 And Month(GCdate) = 12 And Day(GCdate) > 20 Then
BoolDate = True
End If
End If
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -