系统_基本函数模块.bas

新世纪ERP设备管理源代码

        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!gnms) & "','" & "设备管理" & "','" & NTDomainUserName & "','进入')"
        Else
            Ssql = "insert into System_Log(GeginDate,userid,WorkstationName,WorkList,SystemName,NetUserName,State)" _
                & " values(getdate(),'" & UserCode & "','" & MachineName & "','" & Trim("" & aDo_gnbm!gnms) & "','" & "设备管理" & "','" & NTDomainUserName & "','完成')"
        End If
        Cw_DataEnvi.DataConnect.Execute Ssql
    End If
    aDo_gnbm.Close
    Set aDo_gnbm = Nothing
    
End Function
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 Function GetPY(a1 As String) As String                                   '返回拼音码字符串
    
    '输入参数:a1 输入字符串

    Dim jsqte As Long
    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 Item_Info()  '项目查询连接
    
    Dim aDo_Item As New Recordset
    Dim Ssql As String
    Set aDo_Item = Cw_DataEnvi.DataConnect.Execute("select * from DEV_item")
    
    With aDo_Item
        Do While Not .EOF
            If !yncode = 1 And Trim(aDo_Item!TableName) = "CorrelationList" Then
                If !YNRoot = 1 Then
                    Ssql = Ssql & ",N_" & !ItemFieldName & "=(select ListName from DEV_CorrelationList c where convert(varchar(18),c.ListCode)=b." & !ItemFieldName & ")"
                Else
                    Ssql = Ssql & ",N_" & !ItemFieldName & "=(select ListName from DEV_CorrelationList c where convert(varchar(18),c.ListCode)=a." & !ItemFieldName & ")"
                End If
                '-----------------
            Else
                If !yncode = 1 Then
                    If !YNRoot = 1 Then
                        Ssql = Ssql & ",N_" & !ItemFieldName & "=(select " & aDo_Item!CloumnName2 & " from " & aDo_Item!TableName & " c where c." & aDo_Item!CloumnName1 & "=b." & !ItemFieldName & ")"
                    Else
                        Ssql = Ssql & ",N_" & !ItemFieldName & "=(select " & aDo_Item!CloumnName2 & " from " & aDo_Item!TableName & " c where c." & aDo_Item!CloumnName1 & "=a." & !ItemFieldName & ")"
                    End If
                End If
            End If
            .MoveNext
        Loop
        Ssql = "select b.DEVID,b.DEVType,b.DEVSort,b.dname,b.Deptcode,b.Model,b.RejectFlag,b.RepairDate,b.RepairCyc,a.*,N_Lcode=(select isname from DEV_ItemSort c where convert(varchar(18),c.isid)=b.DEVSort)" & Ssql & " FROM DEV_RootInfo a,DEV_main b"
    End With
    Item_Info = Ssql

End Function

'====================单据编号格式化==============
Public Function BillCodeFormat(BillCode As String, Code As String) As String
    BillCode = Trim(BillCode): Code = Trim(Code)
    Dim Profix  As String       '前缀
    Dim Glida As Integer        '流水方式
    Dim CodeLen As Integer      '代码长度
    Dim aDo_re As New Recordset
    Set aDo_re = Cw_DataEnvi.DataConnect.Execute("select * from Gy_BillNumber where BillCode='" & Trim(BillCode) & "'")
    If aDo_re.RecordCount > 0 Then
        Profix = aDo_re!Profix
        Glida = aDo_re!Glida
        CodeLen = aDo_re!CodeLen
    Else
        BillCodeFormat = "": Exit Function
    End If
    aDo_re.Close
    If Len(Code) >= Len(Profix) + CodeLen Then BillCodeFormat = Code: Exit Function
    If Glida = 0 Then
       If Len(Code) >= Len(Profix) Then
          If Profix <> Mid(Code, 1, Len(Profix)) Then
             BillCodeFormat = Profix & String(CodeLen - Len(Code), "0") & Code
          Else
             If Len(Code) = Len(Profix) Then BillCodeFormat = Code: Exit Function
             BillCodeFormat = Profix & String(CodeLen - Len(Code), "0") & Mid(Code, Len(Profix) + 1, Len(Code))
          End If
       Else
          BillCodeFormat = Profix & String(CodeLen - Len(Code), "0") & Code: Exit Function
       End If
    Else
       If Len(Code) >= Len(Profix) Then
          If Profix <> Mid(Code, 1, Len(Profix)) Then
               BillCodeFormat = Profix & Code
             Else
               BillCodeFormat = Code
          End If
       End If
    End If


End Function

'====================单据ID处理==================
Public Function CreatBillID(BillCode As String) As Integer
    '参数说明： BillCode 单据编码
    Dim BillType As String
    Dim aDo_re As New Recordset
    Set aDo_re = Cw_DataEnvi.DataConnect.Execute("select * from Gy_BillNumber where BillCode='" & Trim(BillCode) & "'")
    If aDo_re.RecordCount > 0 Then
        CreatBillID = aDo_re!IDNow
        BillType = aDo_re!BillType
    End If
    aDo_re.Close
    Cw_DataEnvi.DataConnect.Execute "update  Gy_BillNumber set IDNow=IDNow+1 where BillType='" & Trim(BillType) & "'"
End Function

'====================单据编码处理==================
Public Function CreatBillCode(BillCode As String, Optional Add As Boolean = False, Optional KjYear As Integer, Optional Period As Integer, Optional WhCode As String) As String

    '参数说明： BillCode 单据编码，KjYear 会计年度，Period 会计期间，WhCode 仓库编码,Add 编号是累加(True 加，False,否)
    Dim BillCodeMode As Integer '编码方式
    Dim Profix  As String       '前缀
    Dim Glida As Integer        '流水方式
    Dim CodeLen As Integer      '代码长度
    Dim aDo_re As New Recordset
    Set aDo_re = Cw_DataEnvi.DataConnect.Execute("select * from Gy_BillNumber where BillCode='" & Trim(BillCode) & "'")
    With aDo_re
        If .RecordCount > 0 Then
            BillCodeMode = !BillCodeMode
            Profix = !Profix
            Glida = !Glida
            CodeLen = !CodeLen
            .Close
        Else
            Exit Function
        End If
    End With
    
    Select Case BillCodeMode
           Case 0 '单据方式
              '=============
              Select Case Glida
                     Case 0
                          Set aDo_re = Cw_DataEnvi.DataConnect.Execute("select * from Gy_Maxnum where BillCode='" & Trim(BillCode) & "'")
                          If aDo_re.RecordCount < 1 Then '当编号记录没有时
                              Cw_DataEnvi.DataConnect.Execute "insert into Gy_Maxnum(BillCode,NowNumber) VALUES ('" & Trim(BillCode) & "',1)"