lzhy.bas

OA编程 源代码

End Function

Sub EnumerateUsers(ByVal SName As String, ByVal GName As String)
    Dim i As Integer
    Dim j As Integer
    Dim Deparment_c As String
    Dim User_c As String
    Dim Result As Long
    Dim BufPtr As Long
    Dim EntriesRead As Long
    Dim TotalEntries As Long
    Dim ResumeHandle As Long
    Dim BufLen As Long
    Dim dwLevel As Long
    Dim ptmpBuffer As Long
    Dim tmpBuffer As USER_INFO_3
    Dim SNArray() As Byte
    Dim GNArray() As Byte
    Dim UNArray(99) As Byte
    Dim UName As String
    Dim UNPtr As Long
    Dim TempPtr As MungeLong
    Dim TempStr As MungeInt
    Dim sComment As String
    Dim sByte() As Byte
    ReDim sByte(255)

    SNArray = SName & vbNullChar       ' Move to byte array
    GNArray = GName & vbNullChar       ' Move to Byte array
    BufLen = 255                       ' Buffer size
    ResumeHandle = 0                   ' Start with the first entry

    Do
        If GName = "" Then
            Result = NetUserEnum0(SNArray(0), 0, FILTER_NORMAL_ACCOUNT, _
                BufPtr, BufLen, EntriesRead, TotalEntries, ResumeHandle)
        Else
            Result = NetGroupEnumUsers0(SNArray(0), GNArray(0), 0, BufPtr, _
                BufLen, EntriesRead, TotalEntries, ResumeHandle)
        End If

        If Result <> 0 And Result <> 234 Then
            If Result = 2220 Then
                MsgBox "错误：" & Result & " '" & GName & "'不是全局组"
                Exit Sub
            End If
            MsgBox "错误：" & Result & " 列举用户 " & EntriesRead & " of " & TotalEntries
            Exit Sub
        End If
       
        For i = 1 To EntriesRead
            ' Get pointer to string from beginning of buffer
            ' Copy 4-byte block of memory in 2 steps
            Result = PtrToInt(TempStr.XLo, BufPtr + (i - 1) * 4, 2)
            Result = PtrToInt(TempStr.XHi, BufPtr + (i - 1) * 4 + 2, 2)
            LSet TempPtr = TempStr ' munge 2 integers into a Long
            ' Copy string to array
            Result = PtrToStr(UNArray(0), TempPtr.x)
            UName = Left(UNArray, Strlen(TempPtr.x))
            
            dwLevel = 3

            NetUserGetInfo SNArray(0), UNArray(0), dwLevel, ptmpBuffer

            CopyMemory tmpBuffer, ptmpBuffer, LenB(tmpBuffer)
            
            Result = PtrToStr(sByte(0), tmpBuffer.usri3_comment)
            'CopyMemory sByte(0), tmpBuffer.usri3_comment, 255
            
            sComment = sByte
            j = InStr(sComment, Chr(0))
            If j <= 1 Then
                sComment = ""
            Else
                sComment = Mid(sComment, 1, j - 1)
            End If
            'Now I get my user name back, it's VB string now'
            j = InStr(sComment, ",")
            If j <= 0 Then
                User_c = sComment
                Deparment_c = ""
            Else
                If j = 1 Then
                    User_c = ""
                    sComment = Mid(sComment, 2, Len(sComment) - 1)
                Else
                    User_c = Mid(sComment, 1, j - 1)
                    sComment = Mid(sComment, j + 1, Len(sComment) - j)
                End If
            
                j = InStr(sComment, ",")
                If j <= 0 Then
                    Deparment_c = sComment
                Else
                    If j = 1 Then
                        Deparment_c = ""
                    Else
                        Deparment_c = Mid(sComment, 1, j - 1)
                    End If
                End If
            End If
            
            sql = "INSERT INTO groupuser VALUES("
            sql = sql & "'" & Trim(GName) & "',"
            sql = sql & "'" & Trim(UName) & "',"
            sql = sql & "'" & Trim(Deparment_c) & "',"
            sql = sql & "'" & Trim(User_c) & "')"
            Return_Var = gclsDatabase.RDOInsert(sql)
        Next i
    Loop Until EntriesRead = TotalEntries

    Result = NetAPIBufferFree(BufPtr)         ' Don't leak memory
End Sub

Sub EnumerateGroups(ByVal SName As String, ByVal UName As String)
    Dim Result As Long
    Dim BufPtr As Long
    Dim EntriesRead As Long
    Dim TotalEntries As Long
    Dim ResumeHandle As Long
    Dim BufLen As Long
    Dim SNArray() As Byte
    Dim GNArray(99) As Byte
    Dim UNArray() As Byte
    Dim GName As String
    Dim i As Integer
    Dim UNPtr As Long
    Dim TempPtr As MungeLong
    Dim TempStr As MungeInt

    SNArray = SName & vbNullChar       ' Move to byte array
    UNArray = UName & vbNullChar       ' Move to Byte array
    BufLen = 255                       ' Buffer size
    ResumeHandle = 0                   ' Start with the first entry

    Do
        If Len(Trim(UName)) = 0 Then
            Result = NetGroupEnum0(SNArray(0), 0, BufPtr, BufLen, _
                EntriesRead, TotalEntries, ResumeHandle)
        Else
            Result = NetUserGetGroups0(SNArray(0), UNArray(0), 0, BufPtr, _
                BufLen, EntriesRead, TotalEntries)
        End If
       
        If Result <> 0 And Result <> 234 Then    ' 234 means multiple reads required
            MsgBox "错误：" & Result & " 列举组 " & EntriesRead & " of " & TotalEntries
            Exit Sub
        End If
        
        For i = 1 To EntriesRead
            ' Get pointer to string from beginning of buffer
            ' Copy 4 byte block of memory in 2 steps
            Result = PtrToInt(TempStr.XLo, BufPtr + (i - 1) * 4, 2)
            Result = PtrToInt(TempStr.XHi, BufPtr + (i - 1) * 4 + 2, 2)
            LSet TempPtr = TempStr ' munge 2 Integers to a Long
            ' Copy string to array and convert to a string
            Result = PtrToStr(GNArray(0), TempPtr.x)
            GName = Left(GNArray, Strlen(TempPtr.x))
            
            Call EnumerateUsers(SName, GName)
        Next i
    Loop Until EntriesRead = TotalEntries
   
    Result = NetAPIBufferFree(BufPtr)         ' Don't leak memory
End Sub

Function GetPrimaryDCName(ByVal MName As String, ByVal DName As String) As String
    '取得主域服务器的名称
    Dim Result As Long
    Dim DCName As String
    Dim DCNPtr As Long
    Dim DNArray() As Byte
    Dim MNArray() As Byte
    Dim DCNArray(100) As Byte
    
    MNArray = MName & vbNullChar
    DNArray = DName & vbNullChar
    Result = NetGetDCName(MNArray(0), DNArray(0), DCNPtr)
    
    If Result <> 0 Then
        MsgBox "错误：" & Result
        Exit Function
    End If
    
    Result = PtrToStr(DCNArray(0), DCNPtr)
    Result = NetAPIBufferFree(DCNPtr)
    DCName = DCNArray()
    DCName = Trim(Replace(DCName, Chr(0), Space(1)))
    DCName = Mid(DCName, 3)

    GetPrimaryDCName = DCName
End Function

Sub ManageLimit()
    Dim RSTBase As rdoResultset
    Dim RSTLimit As rdoResultset
    Dim RSTGroupUser As rdoResultset

    '----------treeno
    
    sql = "SELECT DISTINCT treeno FROM treelimit ORDER BY treeno"
    Set RSTLimit = gclsDatabase.RDOSelect(sql)
    
    If RSTLimit.RowCount > 0 Then
        Do While Not RSTLimit.EOF
            sql = "SELECT treeno,linkstate FROM treebase WHERE "
            sql = sql & "treeno='" & Trim(RSTLimit!TreeNo) & "'"
            Set RSTBase = gclsDatabase.RDOSelect(sql)
            
            If RSTBase.RowCount <= 0 Then
                sql = "DELETE FROM treelimit WHERE "
                sql = sql & "treeno='" & Trim(RSTLimit!TreeNo) & "'"
                Return_Var = gclsDatabase.RDODelete(sql)
            Else
                'If RSTBase!linkstate = 1 Then
                '    SQL = "DELETE FROM treelimit WHERE "
                '    SQL = SQL & "treeno='" & Trim(RSTLimit!treeno) & "'"
                '    Return_Var = gclsDatabase.RDODelete(SQL)
                'End If
            End If
            
            RSTLimit.MoveNext
        Loop
        
        RSTBase.Close
    End If

    RSTLimit.Close
    
    '----------groupname
    
    sql = "SELECT DISTINCT groupname FROM treelimit ORDER by groupname"
    Set RSTLimit = gclsDatabase.RDOSelect(sql)
    
    If RSTLimit.RowCount > 0 Then
        Do While Not RSTLimit.EOF
            sql = "SELECT groupname FROM groupuser WHERE "
            sql = sql & "groupname='" & Trim(RSTLimit!GroupName) & "'"
            Set RSTGroupUser = gclsDatabase.RDOSelect(sql)
            
            If RSTGroupUser.RowCount <= 0 Then
                sql = "DELETE FROM treelimit WHERE "
                sql = sql & "groupname='" & Trim(RSTLimit!GroupName) & "'"
                Return_Var = gclsDatabase.RDODelete(sql)
            End If
            
            RSTLimit.MoveNext
        Loop
        
        RSTGroupUser.Close
    End If

    RSTLimit.Close
    
    '----------username
    
    sql = "SELECT DISTINCT username FROM treelimit ORDER by username"
    Set RSTLimit = gclsDatabase.RDOSelect(sql)
    
    If RSTLimit.RowCount > 0 Then
        Do While Not RSTLimit.EOF
            sql = "SELECT username FROM groupuser WHERE "
            sql = sql & "username='" & Trim(RSTLimit!Username) & "'"
            Set RSTGroupUser = gclsDatabase.RDOSelect(sql)
            
            If RSTGroupUser.RowCount <= 0 Then
                sql = "DELETE FROM treelimit WHERE "
                sql = sql & "username='" & Trim(RSTLimit!Username) & "'"
                Return_Var = gclsDatabase.RDODelete(sql)
            End If
            
            RSTLimit.MoveNext
        Loop
        
        RSTGroupUser.Close
    End If

    RSTLimit.Close
End Sub

Function AddDirSep(strPathName As String)
    If Right(Trim(strPathName), Len(gstrSEP_URLDIR)) <> gstrSEP_URLDIR And _
       Right(Trim(strPathName), Len(gstrSEP_DIR)) <> gstrSEP_DIR Then
        strPathName = RTrim$(strPathName) & gstrSEP_DIR
        AddDirSep = strPathName
    Else
        AddDirSep = strPathName
    End If
End Function