lzhy.bas

OA编程 源代码

Attribute VB_Name = "lzhy"
Private Type USER_INFO_3
    usri3_name As Long                'LPWSTR in SDK
    usri3_password As Long            'LPWSTR in SDK
    usri3_password_age As Long        'DWORD in SDK
    usri3_priv As Long                'DWORD in SDK
    usri3_home_dir As Long            'LPWSTR in SDK
    usri3_comment As Long             'LPWSTR in SDK
    usri3_flags As Long               'DWORD in SDK
    usri3_script_path As Long         'LPWSTR in SDK
    usri3_auth_flags As Long          'DWORD in SDK
    usri3_full_name As Long           'LPWSTR in SDK
    usri3_usr_comment As Long         'LPWSTR in SDK
    usri3_parms As Long               'LPWSTR in SDK
    usri3_workstations As Long        'LPWSTR in SDK
    usri3_last_logon As Long          'DWORD in SDK
    usri3_last_logoff As Long         'DWORD in SDK
    usri3_acct_expires As Long        'DWORD in SDK
    usri3_max_storage As Long         'DWORD in SDK
    usri3_units_per_week As Long      'DWORD in SDK
    usri3_logon_hours As Long         'PBYTE in SDK
    usri3_bad_pw_count As Long        'DWORD in SDK
    usri3_num_logons As Long          'DWORD in SDK
    usri3_logon_server As Long        'LPWSTR in SDK
    usri3_country_code As Long        'DWORD in SDK
    usri3_code_page As Long           'DWORD in SDK
    usri3_user_id As Long             'DWORD in SDK
    usri3_primary_group_id As Long    'DWORD in SDK
    usri3_profile As Long             'LPWSTR in SDK
    usri3_home_dir_drive As Long      'LPWSTR in SDK
    usri3_password_expired As Long    'DWORD in SDK
End Type

Private Declare Function NetUserGetInfo Lib "netapi32.dll" (strServerName As Any, strUserName As Any, ByVal dwLevel As Long, pBuffer As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)

'Private Sub Command1_Click()
'    Dim pServer() As Byte, pUser() As Byte
'
'    'You need to change "Your_Domain_Logon_Name" in the next line
'    'to your valid NT domain logon name.
'    pUser = "Your_Domain_Logon_Name" & vbNullChar
'    pServer = "" & vbNullChar
'    'The above two lines convert VB string to Unicode string.
'
'    Dim dwLevel As Long
'    dwLevel = 3
'
'    Dim tmpBuffer As USER_INFO_3
'    Dim ptmpBuffer As Long
'
'    NetUserGetInfo pServer(0), pUser(0), dwLevel, ptmpBuffer
'    'As last param is dimmed as long, the pointer to ptmpBuffer is
'    'passed to dll, and the function returns a pointer to a pointer
'    'to our UDT. Therefore ptmpBuffer on return holds a pointer
'    'to our UDT.
'
'    'Deference it!!!
'    CopyMemory tmpBuffer, ptmpBuffer, LenB(tmpBuffer)
'
'    Dim sUser As String
'    Dim sByte() As Byte
'    ReDim sByte(255)
'
'    'Convert LPWSTR (Unicode string) to VB string.
'    CopyMemory sByte(0), tmpBuffer.usri3_name, 256
'    sUser = sByte
'    sUser = sUser & vbNullChar
'    MsgBox Trim$(sUser)
'          'Now I get my user name back, it's VB string now'
'End Sub

Public Declare Function GetCurrentDirectory Lib "kernel32" Alias "GetCurrentDirectoryA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Declare Function SetCurrentDirectory Lib "kernel32" Alias "SetCurrentDirectoryA" (ByVal lpPathName As String) As Long

Public Declare Function NetGetDCName Lib "netapi32.dll" (serverName As Byte, DomainName As Byte, DCNPtr As Long) As Long

Public Declare Function NetUserEnum0 Lib "netapi32.dll" Alias "NetUserEnum" (serverName As Byte, ByVal Level As Long, ByVal lFilter As Long, Buffer As Long, ByVal PrefMaxLen As Long, EntriesRead As Long, TotalEntries As Long, ResumeHandle As Long) As Long
Public Declare Function NetGroupEnumUsers0 Lib "netapi32.dll" Alias "NetGroupGetUsers" (serverName As Byte, GroupName As Byte, ByVal Level As Long, Buffer As Long, ByVal PrefMaxLen As Long, EntriesRead As Long, TotalEntries As Long, ResumeHandle As Long) As Long

Public Declare Function NetGroupEnum0 Lib "netapi32.dll" Alias "NetGroupEnum" (serverName As Byte, ByVal Level As Long, Buffer As Long, ByVal PrefMaxLen As Long, EntriesRead As Long, TotalEntries As Long, ResumeHandle As Long) As Long
Public Declare Function NetUserGetGroups0 Lib "netapi32.dll" Alias "NetUserGetGroups" (serverName As Byte, Username As Byte, ByVal Level As Long, Buffer As Long, ByVal PrefMaxLen As Long, EntriesRead As Long, TotalEntries As Long) As Long

Public Declare Function NetAPIBufferFree Lib "netapi32.dll" Alias "NetApiBufferFree" (ByVal Ptr As Long) As Long
Public Declare Function NetAPIBufferAllocate Lib "netapi32.dll" Alias "NetApiBufferAllocate" (ByVal ByteCount As Long, Ptr As Long) As Long
Public Declare Function PtrToStr Lib "kernel32" Alias "lstrcpyW" (RetVal As Byte, ByVal Ptr As Long) As Long
Public Declare Function StrToPtr Lib "kernel32" Alias "lstrcpyW" (ByVal Ptr As Long, Source As Byte) As Long
Public Declare Function PtrToInt Lib "kernel32" Alias "lstrcpynW" (RetVal As Any, ByVal Ptr As Long, ByVal nCharCount As Long) As Long
Public Declare Function Strlen Lib "kernel32" Alias "lstrlenW" (ByVal Ptr As Long) As Long
Public Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long



Type MungeLong
    x As Long
    Dummy As Integer
End Type

Type MungeInt
    XLo As Integer
    XHi As Integer
    Dummy As Integer
End Type

Type TUser0                    ' Level 0
    ptrName As Long
End Type

Type TUser1                    ' Level 1
    ptrName As Long
    ptrPassword As Long
    dwPasswordAge As Long
    dwPriv As Long
    ptrHomeDir As Long
    ptrComment As Long
    dwFlags As Long
    ptrScriptPath As Long
End Type

'
' for dwPriv
'
Const USER_PRIV_MASK = &H3
Const USER_PRIV_GUEST = &H0
Const USER_PRIV_USER = &H1
Const USER_PRIV_ADMIN = &H2

'
' for dwFlags
'
Const UF_SCRIPT = &H1
Const UF_ACCOUNTDISABLE = &H2
Const UF_HOMEDIR_REQUIRED = &H8
Const UF_LOCKOUT = &H10
Const UF_PASSWD_NOTREQD = &H20
Const UF_PASSWD_CANT_CHANGE = &H40
Const UF_NORMAL_ACCOUNT = &H200     ' Needs to be ORed with the
                                    ' other flags

'
' for lFilter
'
Const FILTER_NORMAL_ACCOUNT = &H2

Const gstrSEP_URLDIR$ = "/"
Const gstrSEP_DIR$ = "\"

Public PathLength As Long
Public PathName As String


Sub ManageQuit()
    MsgBox "数据库操作失败，请检查连接情况！(" & err.Description & ")", vbExclamation, "系统信息"
    gclsDatabase.CloseRDODatabaseConnection
    Set gclsDatabase = Nothing

    If Len(Trim(PathName)) <> 0 Then
        Return_Var = SetCurrentDirectory(PathName)
    End If
    
    End
End Sub

Function TenToSix(InputNum As Long) As String
    Dim strI As String
    Dim strC As String
    Dim numN As Long
    Dim i As Integer
    Dim j As Integer
    
    strI = "0123456789ABCDEF"
    strC = "&"
    numN = InputNum
    
    For i = 1 To 8
        j = (numN Mod 16) + 1
        numN = Int(numN / 16)
        
        strC = Mid(strI, j, 1) & strC
    Next i
    
    TenToSix = "&H" & strC
End Function

'Function GetPath(InputPathFIle As String) As String
'    Dim strI As String
'    Dim strC As String
'    Dim i As Integer
    
'    strI = Trim(InputPathFIle)
'    strC = ""
    
'    Do While True
'        i = InStr(Trim(strI), "\")
'        If i = 0 Then Exit Do
'        strC = strC & Mid(Trim(strI), 1, i)
'        strI = Mid(Trim(strI), i + 1, Len(Trim(strI)) - i)
'    Loop
    
'    GetPath = strC
'End Function

Function IncKey(strKey As String) As String
    Dim strI As String
    Dim strC As String
    Dim i As Integer
    Dim j As Integer
    
    strI = Trim(strKey)
    strC = Mid(Trim(strI), Len(Trim(strI)), 1)
    strI = Mid(Trim(strI), 1, Len(Trim(strI)) - 1)
    i = Val(Trim(strC)) + 1
    
    If i = 10 Then
        i = 0
        strC = Mid(Trim(strI), Len(Trim(strI)), 1)
        strI = Mid(Trim(strI), 1, Len(Trim(strI)) - 1)
        j = Val(Trim(strC)) + 1
        If j = 10 Then
            strI = ""
        Else
            strI = Trim(strI) & Trim(str(j)) & Trim(str(i))
        End If
    Else
        strI = Trim(strI) & Trim(str(i))
    End If
    
    IncKey = strI
End Function

Function DecKey(strKey As String) As String
    Dim strI As String
    Dim strC As String
    Dim i As Integer
    Dim j As Integer
    
    strI = Trim(strKey)
    strC = Mid(Trim(strI), Len(Trim(strI)), 1)
    strI = Mid(Trim(strI), 1, Len(Trim(strI)) - 1)
    i = Val(Trim(strC)) - 1
    
    If i = -1 Then
        i = 9
        strC = Mid(Trim(strI), Len(Trim(strI)), 1)
        strI = Mid(Trim(strI), 1, Len(Trim(strI)) - 1)
        j = Val(Trim(strC)) - 1
        If j = -1 Then
            strI = ""
        Else
            strI = Trim(strI) & Trim(str(j)) & Trim(str(i))
        End If
    Else
        strI = Trim(strI) & Trim(str(i))
    End If
    
    DecKey = strI
End Function

Function GetTitle(strKey As String) As String
    Dim strI As String
    Dim strC As String
    Dim i As Integer
    Dim j As Integer
    Dim rst As New ADODB.Recordset
    On Error GoTo DatabaseError

    strI = Trim(strKey)
    strC = ""
    
    Do While True
        sql = "SELECT treename FROM treebase WHERE "
        sql = sql & "treeno='" & strI & "' order by treeno"
        Set rst = Pubsaconn.Execute(sql)
        strC = Trim(rst!treename) & "-" & strC
        
        rst.Close
        
        If Len(Trim(strI)) = 2 Then
            Exit Do
        Else
            strI = Mid(Trim(strI), 1, Len(Trim(strI)) - 2)
        End If
    Loop
    Set rst = Nothing
    GetTitle = Mid(Trim(strC), 1, Len(Trim(strC)) - 1)
    
    Exit Function
DatabaseError:
    MsgBox err.Description, 64