?? 系統_基本函數模塊.bas
字號:
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) > 26 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 + -