global.bas

客户管理crm xitong ,希望能给你带来帮助

Attribute VB_Name = "global"
Public method As String
Public user_id As String
Public pwd As String
Public database As String
Public servername As String
Public bordercolorlight As String
Public bordercolordark As String

Public response As response
Public request As request
Public application As application
Public server As server
Public session As session

Private Const BITS_TO_A_BYTE = 8
Private Const BYTES_TO_A_WORD = 4
Private Const BITS_TO_A_WORD = 32

Private m_lOnBits(30)
Private m_l2Power(30)
Public p_status(6)

Sub Main()
    p_status(0) = "未开始"
    p_status(1) = "进行中"
    p_status(2) = "已完成"
    p_status(3) = "正在等待其他人"
    p_status(3) = "已推迟"
End Sub

Public Sub connect(conn As ADODB.Connection)
    'On Error Resume Next
    '初始化参数
    getPara
    
    
    'strfilepath = request.ServerVariables("SCRIPT_NAME")
    
    'If InStr(strfilepath, "loginindex.asp") > 0 Or InStr(strfilepath, "register.asp") > 0 Then
    'Else
    '    checkloginindex
    'End If
    
   
    If method = "sqlserver" Then
        conn.Provider = "sqloledb"
        ConnStr = "driver={SQL server};server=" & session("servername") & ";uid=" & session("user_id") & ";pwd=" & session("pwd") & ";database=" & session("database")
    Else
        ConnStr = "DRIVER={Microsoft Access Driver (*.mdb)}; DBQ=" & server.MapPath("/") & "\data\" & session("database") & ";DriverId=25;FIL=MS Access;UID=" & session("user_id") & "; PWD=" & session("pwd")                             '数据库所在路径
    End If
    'response.Write ConnStr
    'response.End
    conn.Open ConnStr
    
    '记录访问日志
    Refer = request.ServerVariables("URL") & "?" & request.ServerVariables("QUERY_STRING")
    strServer = request.ServerVariables("REMOTE_ADDR")
    strsql = "insert into logs(log_url,log_ip,log_user) values('"
    strsql = strsql & Refer & "','"
     strsql = strsql & strServer & "','"
    strsql = strsql & session("loginuser") & "')"
    conn.Execute strsql
End Sub

Public Sub disconnect(conn As ADODB.Connection)
    conn.Close
    Set conn = Nothing
End Sub

Public Sub getPara()
    Dim allPara(7)
    i = 0
    strpath = "/"
    parafile = server.MapPath(strpath) & "\data\para.txt"
    'response.Write parafile
    'response.End

    Set MyPara = server.CreateObject("Scripting.FileSystemObject")
    Set Myfile = MyPara.OpenTextFile(parafile)
    While Not Myfile.AtEndOfStream
        allPara(i) = Myfile.ReadLine
        'response.Write allPara(i) & "<br>"
        i = i + 1
    Wend
    
    method = Trim(allPara(0))
    user_id = Trim(allPara(1))
    pwd = Trim(allPara(2))
    database = Trim(allPara(3))
    servername = Trim(allPara(4))
    bordercolorlight = Trim(allPara(5))
    bordercolordark = Trim(allPara(6))
    
    If method = "" Then
        session("method") = "sqlserver"
    Else
        session("method") = method
    End If
    
    If servername = "" Then
        session("servername") = "."
    Else
        session("servername") = servername
    End If
    
    If user_id = "" Then
        user_id = "sa"
    Else
        session("user_id") = user_id
    End If
    
    session("pwd") = pwd
    
    If database = "" Then
        database = "workflow.mdb"
    Else
        session("database") = database
    End If
    
    If bordercolorlight <> "" Then
        session("bordercolorlight") = bordercolorlight
    Else
        session("bordercolorlight") = "#000000"
    End If
    
    If bordercolordark <> "" Then
        session("bordercolordark") = bordercolordark
    Else
        session("bordercolordark") = "#FFFFFF"
    End If
    
End Sub

Public Function getWenHao(Strget)
    If InStr(Strget, "?") >= 1 Then
        getWenHao = True
    Else
        getWenHao = False
    End If
End Function

Public Sub checkloginindex()
    If session("loginuser") = "" Or session("loginorlogout") <> True Then
        response.Redirect "/function/loginindex.asp"
        response.End
    End If
End Sub

Function getString(inString)
    getString = Replace(inString, "'", "''")
End Function

Public Sub ClearRecordset(rs)
    rs.Close
    Set rs = Nothing
End Sub

Public Sub PrnHis(strWanted, strReal) '修改下拉条
        Dim strHis
        If strWanted = strReal Then
            strHis = "<OPTION VALUE='" & strWanted & "'Selected>" & strWanted & "</OPTION>"
        Else
            strHis = "<OPTION VALUE='" & strWanted & "'>" & strWanted & "</OPTION>"
        End If
        response.Write strHis
End Sub

Public Sub PrnHisShow(strWanted, strReal, strshow) '修改下拉条
        Dim strHis
        If strWanted = strReal Then
            strHis = "<OPTION VALUE='" & strWanted & "'Selected>" & strshow & "</OPTION>"
        Else
            strHis = "<OPTION VALUE='" & strWanted & "'>" & strshow & "</OPTION>"
        End If
        response.Write strHis
End Sub

Public Sub PrnHisShowTxt(strWanted, strReal, strshow) '显示文本
        Dim strHis
        If strWanted = strReal Then
            strHis = strshow
        End If
        response.Write strHis
End Sub

Public Function Printbordercolor()
    Printbordercolor = "bordercolorlight='" & session("bordercolorlight") & "' bordercolordark='" & session("bordercolordark") & "'"
End Function

Public Function getInitLoop()
    strMD = request.ServerVariables("APPL_MD_PATH")
    strMDs = Split(strMD, "/")
    If UCase(strMDs(UBound(strMDs))) = "ROOT" Then
        getInitLoop = 1
    Else
        getInitLoop = 2
    End If
End Function

Public Function GetPath()
 Dim m_intLoop, m_strBaseDIr
 '如果有虚拟目录则m_intLoop = 2 反之m_intLoop = 1
 For m_intLoop = getInitLoop To UBound(Split(request.ServerVariables("SCRIPT_NAME"), "/")) - 1
  m_strBaseDIr = m_strBaseDIr + "..\"
 Next
 GetPath = m_strBaseDIr
End Function

Public Function GetPath1()
 Dim m_intLoop, m_strBaseDIr
 '如果有虚拟目录则m_intLoop = 2 反之m_intLoop = 1
 For m_intLoop = getInitLoop To UBound(Split(request.ServerVariables("SCRIPT_NAME"), "/")) - 1
  m_strBaseDIr = m_strBaseDIr + "../"
 Next
 GetPath1 = m_strBaseDIr
End Function


Public Function AmendToHtml(str)
    Dim array_string_ath
    Dim str_in_array_string
    Dim ath_i
    Dim ath_result
    ath_result = ""

    'str = Replace(str, "<", "&lt;")

    'str = Replace(str, ">", "&gt;")
    str = Replace(str, Chr(13) & Chr(10), "<br>")
    array_string_ath = Split(str, "<br>")
    For Each str_in_array_string In array_string_ath
        For ath_i = 1 To Len(str_in_array_string)
            If Mid(str_in_array_string, ath_i, 1) <> " " Then Exit For
        Next
        If ath_result = "" Then
            ath_result = ath_result & Replace(str_in_array_string, " ", "&nbsp;", 1, ath_i - 1)
        Else
            ath_result = ath_result & "<br>" & Replace(str_in_array_string, " ", "&nbsp;", 1, ath_i - 1)
        End If
    Next
    AmendToHtml = ath_result
End Function

Public Function AmendToJS(str)
    AmendToJS = Replace(str & "", "|", "\n")
End Function

Public Function GetStrPage(pagename)
    On Error Resume Next
    Set fso = CreateObject("Scripting.FileSystemObject")
    lpath = server.MapPath("./") & "\" & pagename
        If (fso.FileExists(lpath)) Then
            Set TextStream = fso.OpenTextFile(lpath, 1)
            Strcontent = TextStream.ReadAll
            GetStrPage = Strcontent
        Else
            fso.CreateTextFile lpath, 1
            GetStrPage = ""
        End If
     If Err Then
            GetStrPage = ""
     End If
End Function

Public Sub WritetoPage(Strget, Strpage)
    Set fso1 = CreateObject("Scripting.FileSystemObject")
    lpath = server.MapPath("/") & "\templete\templatepage\" & Strpage
    'response.write lpath
    'response.end
    If (fso1.FileExists(lpath)) Then
            Set f = fso1.OpenTextFile(lpath, 2, True)
            f.Write Strget
    Else
            fso1.CreateTextFile lpath, 1
            Set f = fso1.OpenTextFile(lpath, 2, True)
            f.Write Strget
    End If
End Sub

Public Function InsertIntoTable(StrInsertTable)
    On Error Resume Next
    Dim objConn As Connection
    Set objConn = server.CreateObject("ADODB.Connection")
    connect objConn
    
    Dim StrGetFormName, StrGetFormvalue, StrsqlInsert, InsertTable, StrInsertName, StrInsertValue
    InsertTable = StrInsertTable
    If InsertTable <> "" Then
        StrsqlInsert = "insert into " & InsertTable & "("
        For i = 1 To request.Form.Count
            StrGetFormName = request.Form.Key(i)
            StrGetFormvalue = getString(request.Form(i))
            If i = 1 Then
                StrInsertName = StrGetFormName
                StrInsertValue = StrGetFormvalue
            Else
                StrInsertName = StrInsertName & "," & StrGetFormName
                StrInsertValue = StrInsertValue & "','" & StrGetFormvalue
            End If
        Next
        StrsqlInsert = StrsqlInsert & StrInsertName & ") values('" & StrInsertValue & "')"
        objConn.Execute StrsqlInsert
        strsql = "select @@identity as GetId"
        Set objrs = server.CreateObject("adodb.recordset")
            objrs.Open strsql, objConn, 1, 1
            InsertIntoTable = objrs.Fields("GetId")
    Else
        InsertIntoTable = ""
        response.Write "<p align=center>请传入数据库名称！</p>"
        response.End
    End If

    If Err Then
        InsertIntoTable = ""
        response.Write "<p align=center>数据插入失败，请重试或者检查你的submit按钮的名称是否为空！</p>"
        response.End
    End If
    ClearRecordset objrs
    disconnect objConn
End Function

Public Function UpdateTable(InsertTable, ModifyIDName, ModifyID)
    InsertTable = InsertTable '要修改的表名
    ModifyID = ModifyID '要修改的记录的ID值
    ModifyIDName = ModifyIDName '要修改的记录的ID名称
    
    Dim objConn As Connection
    Set objConn = server.CreateObject("ADODB.Connection")
    connect objConn
    
    If ModifyID <> "" And ModifyIDName <> "" Then
        If InsertTable <> "" Then
            StrsqlInsert = "update " & InsertTable & " set "
            For i = 1 To request.Form.Count
                StrGetFormName = request.Form.Key(i)
                StrGetFormvalue = request.Form(i)
                StrInsert = StrInsert & StrGetFormName & "='" & StrGetFormvalue & "',"
            Next
                StrInsert = Left(StrInsert, Len(StrInsert) - 1)
            StrsqlInsert = StrsqlInsert & StrInsert & " where " & ModifyIDName & "=" & ModifyID
            'response.write StrsqlInsert
            'response.end
            objConn.Execute StrsqlInsert
            UpdateTable = ModifyID
        Else
            UpdateTable = ""
            response.Write "<p align=center>请传入数据库名称！</p>"
            response.End
        End If
    Else
        UpdateTable = ""
        response.Write "<p align=center>请传入要修改记录的参数！</p>"
        response.End
    End If
    If Err Then
        UpdateTable = ""
        response.Write "<p align=center>数据修改失败，请重试或者检查你的submit按钮的名称是否为空！</p>"
        response.End
    End If
    disconnect objConn
End Function

Function GetAutoNum(first, bit, strtable, strfield)
    Dim objConn As Connection
    Set objConn = server.CreateObject("ADODB.Connection")
    connect objConn
    
    getNum = ""
    If first = "" Then
        first = "Product"
    End If
    If bit = 0 Or Len(bit) = 0 Then
        bit = 4
    End If
    If datebase = "" Then
        datebase = "products"
    End If
    If strfield = "" Then
        strfield = "product_id"
    End If
    strsql = "select max(" & strfield & ") as allnum from " & strtable
    Set rs = server.CreateObject("adodb.recordset")
    rs.Open strsql, objConn, 1, 1
    If Not rs.EOF Then
            getNum = rs.Fields("allnum") & ""
    Else
        getNum = "0"
    End If
    If getNum = "" Then
        getNum = "0"
    End If
    If Len(getNum) < CInt(bit) Then
        CgetNum = CInt(getNum) + 1
        For i = 0 To CInt(bit) - Len(getNum)
            CgetNum = "0" & CgetNum
        Next
        GetAutoNum = first & CgetNum
    Else
        GetAutoNum = first & (CInt(getNum) + 1)
    End If
    ClearRecordset objrs
    disconnect objConn
End Function

Function FindCat(table, Scat_name, Sf_id_name, S_id, Sf_id, id, url)
    
    strsql = "select " & Scat_name & "," & S_id & "," & Sf_id_name & " from " & table & " where " & S_id & "=" & id
    Set objrs = server.CreateObject("adodb.recordset")
            objrs.Open strsql, objConn, 1, 1
            
        If Not objrs.EOF Then
                    session("FindCat") = "<a href='" & url & "?" & S_id & "=" & objrs.Fields(S_id) & "'>" & objrs.Fields(Scat_name) & "</a>>>" & session("FindCat")
                If objrs.Fields(Sf_id_name) = 0 Then
                    FindCat = "<a href='" & url & "?" & S_id & "=" & objrs.Fields(S_id) & "'>" & objrs.Fields(Scat_name) & "</a>>>"
                    Exit Function
                Else
                    FindCat table, Scat_name, Sf_id_name, S_id, S_id, objrs.Fields(Sf_id_name), url
                End If
            FindCat = session("FindCat")
        End If
End Function

Function ImageUp(intFormSize, intFormData)     '这个函数的功能是截取其中的图像部分
    'Dim bncrlf,divider,datastart,dataend,imageup
    bncrlf = ChrB(13) & ChrB(10)
    divider = LeftB(intFormData, InStrB(intFormData, bncrlf) - 1)
    datastart = InStrB(intFormData, bncrlf & bncrlf) + 4
    dataend = InStrB(datastart + 1, intFormData, divider) - datastart
    ImageUp = MidB(intFormData, datastart, dataend)
 End Function

Function convDate(strdate)
    If strdate <> "" Then
        If session("method") = "access" Then
            convDate = " cdate('" & strdate & "') "
        Else
            convDate = " convert(datetime,'" & strdate & "') "
        End If
    Else