系统_基本函数模块.bas

新世纪ERP包装物管理源代码

                    End If
                End If
            Next Jsqte
            If Jsqte <= Bcgsgrid.Cols - 1 Then
                .Fields("ColId") = Jsqte - Qslzte + 1
                .Fields("ColWidth") = Bcgsgrid.ColWidth(Jsqte)
                .Update
            Else
                GoTo Swcwcl
            End If
            .MoveNext
        Loop
    End With
    Cw_DataEnvi.DataConnect.CommitTrans
    Tsxx = "表格格式保存完毕!"
    Call Xtxxts(Tsxx, 0, 4)
    Exit Sub
Swcwcl:
    Cw_DataEnvi.DataConnect.RollbackTrans
    Tsxx = "存盘过程中出现未知错误,程序自动恢复保存前状态!"
    Call Xtxxts(Tsxx, 0, 1)
    Exit Sub

End Sub

'===================以下为系统权限控制与上机日志控制函数======================'
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!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.dcode,b.tcode,b.lcode,b.dname,b.manage,b.dxh,b.mader,b.zflag,b.mlevel,b.pdate,b.state,b.dno,b.conno,a.*,N_Lcode=(select isname from DEV_ItemSort c where convert(varchar(18),c.isid)=b.lcode)" & 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
    '参数