Page 1 sur 1
UserRegistration Class
Publié:
24 Mars 2006 à 10:41par Stephane Maillard
- Code : Tout sélectionner
'=+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++=
' UserRegistration Class
'=+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++=
'----- API Constants ----
Private Const MAILSYSTEM_NOTES = 0
Private Const MAILSYSTEM_CCMAIL = 1
Private Const MAILSYSTEM_VIMMAIL = 2
Private Const MAILSYSTEM_NONE = 99
Private Const REG_MAIL_OWNER_ACL_MANAGER = 0
Private Const REG_MAIL_OWNER_ACL_DESIGNER = 1
Private Const REG_MAIL_OWNER_ACL_EDITOR = 2
Private Const KFM_IDFILE_TYPE_DERIVED = 4
Private Const fREGCreateIDFileNow = &H0001
Private Const fREGUSARequested = &H0002
Private Const fREGCreateMailFileNow = &H0004
Private Const fREGCreateAddrBookEntry = &H0008
Private Const fREGOkayToModifyID = &H0010
Private Const fREGOkayToModifyAddrbook = &H0020
Private Const fREGSaveIDInFile = &H0040
Private Const fREGCreateLimitedClient = &H0080
Private Const fREGCreateDesktopClient = &H0100
Private Const fREGSaveIDInAddrBook = &H0200
Private Const fREGCreateMailFileUsingAdminp = &H0800
Private Const fREGSetInternetPassword = &H1000
Private Const fREGExtCreateMailFTIndex = &H00000001
Private Const fREGExtReturnPersonNote = &H00000002
Private Const fREGExtEnforceUniqueShortName = &H00000004
Private Const bufferSize = 1024
Private Const BUFFER_SIZE = 256
Private Const STS_REMOTE = &H4000
Private Const STS_DISPLAYED = &H8000
'----- Type definitions ----
Private Type REG_USERNAME_INFO
LastName As String
FirstName As String
MidInitial As String
OrgUnit As String
ShortName As String
AlternateName As String
AltOrgUnit As String
AltLanguage As String
Spare As String*8
End Type
Private Type REG_MAIL_INFO
MailSystem As Integer
MailOwnerAccess As Integer
DbQuotaSizeLimit As Long
DbQuotaWarningThreshold As Long
MailServerName As String
MailFileName As String
MailTemplateName As String
MailForwardAddress As String
MailACLManager As String
Spare As String*10
End Type
Private Type KFM_PASSWORD
type As Integer
HashedPassword As String * 48
End Type
Private Type TIMEDATE
Innards( 1) As Long
End Type
'----- W32 api declarations ----
Declare Private Sub TimeConstruct Lib "nnotes" (Byval aDate As Long, Byval aTime As Long, TIMEDATE As TIMEDATE)
Declare Private Sub SECKFMCreatePassword Lib "nnotes" (Byval pPassword As String, retHashedPassword As KFM_PASSWORD)
Declare Private Sub SECKFMFreeCertifierCtx Lib "nnotes" (Byval hCertCtx As Long)
Declare Private Function SECKFMGetCertifierCtx Lib "nnotes" (Byval pCertFile As String, _
pKfmPW As KFM_PASSWORD, Byval pLogFile As String, pExpDate As TIMEDATE, retCertName As String, _
rethKfmCertCtx As Long, retflsHierarchical As Integer, retwFileVersion As Long) As Integer
Declare Private Function REGNewUser Lib "nnotes" (Byval hCertCtx As Long, Byval MakeIDType As Integer, _
Byval RegServer As Lmbcs String, RegUserNameInfo As Lmbcs REG_USERNAME_INFO, _
RegMailInfo As Lmbcs REG_MAIL_INFO, Byval Password As Lmbcs String, Byval pGroupList As Long, _
Byval IDFileName As Lmbcs String, Byval Location As Lmbcs String, Byval Comment As Lmbcs String, _
Byval InternetAddress As Lmbcs String, Byval ProfileName As Lmbcs String, Byval LocalAdminName As Lmbcs String, _
Byval Flags As Integer, Byval FlagsExt As Long, Byval MinPasswordLength As Integer, phUserNote As Long, _
phUserNoteNAB As Long, Byval signalstatus As Long, Byval ErrorPathName As Lmbcs String, _
Byval Reserved As Long, Byval Spare As Long ) As Integer
Declare Private Function OSMemAlloc Lib "nnotes" ( Byval T As Integer, Byval N As Long, hM As Long) As Integer
Declare Private Function OSMemFree Lib "nnotes" ( Byval Handle As Long) As Integer
Declare Private Function OSLockObject Lib "nnotes" ( Byval H As Long) As Long
Declare Private Sub OSUnlockObject Lib "nnotes" ( Byval H As Long)
Declare Private Function ListAllocate Lib "nnotes" ( Byval N As Integer, Byval S As Integer, Byval T As Integer, hL As Long, pL As Long, pLSize As Integer) As Integer
Declare Private Function ListAddEntry Lib "nnotes" (Byval hList As Long, Byval fPrefix As Integer, pListSize As Integer, Byval EntryNumber As Integer, Byval text As Lmbcs String, Byval textSize As Integer) As Integer
Declare Private Function OSLoadString Lib "nnotes" (Byval hModule As Long, Byval StringCode As Integer, Byval retBuffer As Lmbcs String, Byval BufferLength As Integer) As Integer
Declare Private Function NSFItemSetTextSummary Lib "nnotes" (Byval hNote As Long, Byval ItemName As String, Byval ItemText As String, Byval TextLength As Integer, Byval summary As Integer) As Integer
Declare Private Function NSFNoteUpdate Lib "nnotes" (Byval hNote As Long, Byval flags As Integer) As Integer
Declare Private Function NSFNoteClose Lib "nnotes" (Byval hNote As Long) As Integer
'----- userRegistration Class ---- v0.2 by Davy Vanherbergen
Public Class userRegistration
Private RegUserNameInfo As REG_USERNAME_INFO
Private RegMailInfo As REG_MAIL_INFO
Private minPasswordLength As Integer
Private flags As Integer
Private flagsExt As Long
'public properties in same sequence as the new registration dialog box
Property Set firstName As String
RegUserNameInfo.firstName = firstName
End Property
Property Set midInitial As String
RegUserNameInfo.midInitial = midInitial
End Property
Property Set lastName As String
RegUserNameInfo.lastName = lastName
End Property
Property Set shortName As String
RegUserNameInfo.shortName = shortName
End Property
Public password As String
Property Set passwordQuality As Integer
If passwordQuality < 32 Then
minPasswordLength = passwordQuality
Else
minPasswordLength = 31
End If
End Property
Property Set setInternetPassword As Variant
If setInternetPassword Then
flags = flags Or fREGSetInternetPassword
Else
flags = flags And (&HFFFF Xor fREGSetInternetPassword)
End If
End Property
Public internetAddress As String
Property Set mailSystem As String
Select Case Ucase(mailSystem)
Case "NONE":
RegMailInfo.mailSystem = MAILSYSTEM_NONE
Case "CCMAIL":
RegMailInfo.mailSystem = MAILSYSTEM_CCMAIL
Case "VIM"
RegMailInfo.mailSystem = MAILSYSTEM_VIMMAIL
Case Else
RegMailInfo.mailSystem = MAILSYSTEM_NOTES
End Select
End Property
Property Set mailFileTemplate As String
RegMailInfo.MailTemplateName = mailFileTemplate
End Property
Property Set mailFileName As String
RegMailInfo.MailFileName = mailFileName
End Property
Property Set mailServer As String
RegMailInfo.mailServerName = mailServer
End Property
Property Set mailFileAccessLevel As String
Select Case Ucase(mailFileAccessLevel)
Case "EDITOR":
RegMailInfo.MailOwnerAccess = REG_MAIL_OWNER_ACL_EDITOR
Case "DESIGNER":
RegMailInfo.MailOwnerAccess = REG_MAIL_OWNER_ACL_DESIGNER
Case Else
RegMailInfo.MailOwnerAccess = REG_MAIL_OWNER_ACL_MANAGER
End Select
End Property
Property Set createMailFileNow As Variant
If createMailFileNow Then
flags = flags Or fREGCreateMailFileNow
Else
flags = flags And (&HFFFF Xor fREGCreateMailFileNow)
End If
End Property
Property Set createMailFileUsingAdminp As Variant
If createMailFileUsingAdminp Then
CreateMailFileNow = False
flags = flags Or fREGCreateMailFileUsingAdminp
Else
flags = flags And (&HFFFF Xor fREGCreateMailFileUsingAdminp)
End If
End Property
Property Set createFTindex As Variant
If createFTindex Then
flagsExt = flagsExt Or fREGExtCreateMailFTIndex
Else
flagsExt = flagsExt And (&HFFFFFFFF Xor fREGExtCreateMailFTIndex)
End If
End Property
Property Set mailQuota As Integer
RegMailInfo.DbQuotaSizeLimit = mailQuota
End Property
Property Set mailThreshold As Integer
RegMailInfo.DbQuotaWarningThreshold = mailThreshold
End Property
Property Set isNorthAmerican As Variant
If isNorthAmerican Then
flags = flags Or fREGUSARequested
Else
flags = flags And (&HFFFF Xor fREGUSARequested)
End If
End Property
Property Set storeIDinNAB As Variant
If storeIDinNAB Then
flags = flags Or fREGSaveIDInAddrBook
Else
Me.storeIDInFile = True
flags = flags And (&HFFFF Xor fREGSaveIDInAddrBook)
End If
End Property
Property Set storeIDInFile As Variant
If storeIDInFile Then
flags = flags Or fREGSaveIDInFile
Else
Me.storeIDInNAB = True
flags = flags And (&HFFFF Xor fREGSaveIDInFile)
End If
End Property
Public idFile As String
Public setupProfile As String
Property Set UniqueOrgUnit As String
RegUserNameInfo.orgUnit = UniqueOrgUnit
End Property
Public location As String
Public localadmin As String
Public comment As String
Property Set AltLanguage As String
RegUserNameInfo.AltLanguage = AltLanguage
End Property
Property Set AlternateName As String
RegUserNameInfo.AlternateName = AltName
End Property
Property Set altOrgUnit As String
RegUserNameInfo.AltOrgUnit = altOrgUnit
End Property
Property Set createNABEntry As Variant
If createNABEntry Then
flags = flags Or fREGCreateAddrBookEntry
Else
flags = flags And (&HFFFF Xor fREGCreateAddrBookEntry)
End If
End Property
Property Set createIDfile As Variant
If createIDfile Then
flags = flags Or fREGCreateIDFileNow
Else
flags = flags And (&HFFFF Xor fREGCreateIDFileNow)
End If
End Property
Public addToGroups As Variant
'other private members
Private hCertCtx As Long
Private phUserNote As Long
Private phUserNoteNAB As Long
Private errorpathname As String
Private hashedPassword As KFM_PASSWORD
Private certLog As String
Private certExpires As TIMEDATE
Private certID As String
Private NABServer As String
Private itemsToAdd As Integer
Private itemnames() As String
Private itemvalues() As String
'UserRegistration Class Constructor
Public Sub new(registrationServer As String, certifierID As String, _
certifierpwd As String , expirationDate As notesdatetime )
itemsToAdd = 0
Redim itemnames(0)
Redim itemvalues(0)
NABServer = registrationServer
Set certdb = New NotesDatabase( registrationServer, "certlog.nsf")
If certdb.IsOpen = False Then
Error 666, "Certlog.nsf not found on " + registration
Exit Sub
End If
certLog = registrationServer + "!!certlog.nsf"
'hash pwd
Call SECKFMCreatePassword(certifierpwd, hashedPassword)
'expiration date
Dim JulianDate As Double
JulianDate = GregorianToJulian(Year( expirationDate.LSGMTTime), Month( expirationDate.LSGMTTime), Day( expirationDate.LSGMTTime))
Call TimeConstruct(JulianDate, &HFFFFFFFF, certExpires)
certID = certifierID
'Setting some default flags
CreateIDFile = True 'create ID file
CreateNABEntry = True 'create NAB entry
CreateMailFileNow = False 'create mailFile in background
CreateMailFileUsingAdminP = True
End Sub
'Register Method
Public Function register(force As Variant)
Dim retflsHierarchical As Integer
Dim retCertName As String
Dim retwFileVersion As Long
Dim result As Integer
Dim nullvalue As Long
nullvalue = 0
If force Then
Flags = flags Or fREGOkayToModifyID Or fREGOkayToModifyAddrbook
Else
flags = flags And ( &HFFFF Xor ( fREGOkayToModifyID Or fREGOkayToModifyAddrbook ) )
End If
'always return notehandle
flagsExt = flagsExt Or fREGExtReturnPersonNote
'Get certifier context
Stop
result = SECKFMGetCertifierCtx( certID, HashedPassword, certLog, certExpires, retCertName, hCertCtx, retflsHierarchical, retwFileVersion)
If result > 0 Then Call flagError(result,"Could not create certifier context.")
Dim pList As Long
Dim hList As Long
hList = BuildGroupList()
If hList Then
'refresh pointers
OSUnlockObject(hList)
pList = OSLockObject(hList)
End If
'Regiser user
result = REGNewUser (hCertCtx, KFM_IDFILE_TYPE_DERIVED, NABServer, RegUserNameInfo, _
RegMailInfo, Password, pList, IDFile, Location, Comment, InternetAddress, ProfileName, _
LocalAdmin, Flags, FlagsExt, MinPasswordLength, phUserNote, phUserNoteNAB, nullValue, _
ErrorPathName, nullValue, nullValue )
If hList Then
OSUnlockObject(hList)
OSMemFree(hList)
End If
If result > 0 Then Call flagError(result,"Could not register user.")
'Free certifier context
Call SECKFMFreeCertifierCtx( hCertCtx)
'Update nabnote with extra items
If itemsToAdd = 0 Then Exit Function
If phUsernote = 0 Then
Error 69, "note handle to person document is empty"
Else
Dim itemname As String
Dim itemvalue As String
For i = 0 To (itemsToAdd-1)
itemname = itemnames(i) + Chr$(0)
itemvalue = itemvalues(i)
result = NSFItemSetTextSummary (phUserNote, itemname, itemvalue, Len(itemvalue), True)
If result > 0 Then Call flagError(result,"Could not set item: " + itemnames(i))
Next
result = NSFNoteUpdate( phUserNote, 0)
If result > 0 Then Call flagError(result,"Could not update note")
result = NSFNoteClose( phUserNote )
If result > 0 Then Call flagError(result,"Could not close note")
End If
End Function
Public Function setStringItem(itemname As String, itemvalue As String)
If Trim(itemname) = "" Then Exit Function
Redim Preserve itemnames(itemsToAdd)
Redim Preserve itemvalues(itemsToAdd)
itemnames(itemsToAdd) = itemname
itemvalues(itemsToAdd) = itemvalue
itemsToAdd = itemsToAdd + 1
End Function
Private Function GregorianToJulian(y1 As Long, m1 As Integer, d As Double) As Double
y& = y1
m% = m1
If m% < 3 Then
m% = m% + 12
y& = y& - 1
End If
GregorianToJulian = d# + ( 153 * m% - 457) / 5 + Int( 365.25# * y&) - Int( y& * .01#) + Int( y& * .0025#) + 1721119#
End Function
Private Function BuildGroupList() As Long
Dim newlist() As String
Dim ListEntries As Integer
Dim rethList As Long
Dim retpList As Long
Dim listSize As Integer
Dim result As Integer
Dim j As Integer
ListEntries = Ubound(addToGroups)
If Isempty(AddToGroups) Then
BuildGroupList = 0
Exit Function
Elseif Trim(AddToGroups(0)) = "" Then
BuildGroupList = 0
Exit Function
End If
'Build LIST structure
result = ListAllocate(0, 0, False, retHList, retpList, listSize)
If result > 0 Then Call flagError(result,"Could not allocate list.")
OSUnlockObject(retHList)
buildGroupList = retHList
Dim grp As String
Dim grplen As Integer
For j = 0 To ListEntries
grp = addToGroups(j)
grplen = Len(addToGroups(j))
result = ListAddEntry(retHList, False, listSize, j, grp, grplen)
If result > 0 Then Call flagError(result,"Could not add entry to list.")
Next
End Function
Private Function flagError (errorNumber As Integer, addmsg As String)
Dim bufferSize As Integer
Dim buffer As String*BUFFER_SIZE
Dim stringLength As Integer
Dim msg As String
bufferSize = BUFFER_SIZE
If errornumber = 0 Then Exit Function
If errornumber And STS_DISPLAYED Then
errornumber = errornumber And ( &HFFFF Xor STS_DISPLAYED)
End If
If errornumber And STS_REMOTE Then
msg = "Remote Error: "
errornumber = errornumber And ( &HFFFF Xor STS_REMOTE)
End If
stringLength = OSLoadString(0, errornumber, buffer, bufferSize - 1)
If stringLength > 0 Then
Error errornumber, addmsg + " - " + msg + Left(buffer, stringLength) + "."
Else
Error 69, addmsg + " - Couldn't load Error String for Error " + Cstr(errornumber)
End If
End Function
End Class
UserRegistration Class
Publié:
25 Jan 2007 à 10:59par regm8
Bonjour,
Ton Script fonctionne à merveille, sauf pour le quotas.
j'ai ecris dans mon lotus Script :
userReg.mailQuota=200
userReg.mailThreshold=160
Dans le Doc requète de l'Admin4 il a bien ajouté les champs :
Taille du quota de la base (Mo) :
Seuil d'alerte du quota de la base (Mo) :
seulement les valeur sont à 0
j'ai alors ecris :
userReg.mailQuota=200
userReg.mailThreshold=160
mais même punition.
Pourrait on m'aider
Publié:
25 Jan 2007 à 11:07par Stephane Maillard
Salut,
Essai avec le debugger pour voir si il passe bien les paramètres à la classe.
UserRegistration Class
Publié:
25 Jan 2007 à 15:40par regm8
Oui avec le debugger pas de souci, le script passe bien dans les propriétées de la classe.
Dans ton code du déclare :
Private Type REG_MAIL_INFO
MailSystem As Integer
MailOwnerAccess As Integer
DbQuotaSizeLimit As Long
DbQuotaWarningThreshold As Long
MailServerName As String
MailFileName As String
MailTemplateName As String
MailForwardAddress As String
MailACLManager As String
Spare As String*10
End Type
Puis dans les propriétées de ta classe tu déclare :
Property Set mailQuota As Integer
RegMailInfo.DbQuotaSizeLimit = mailQuota
End Property
Property Set mailThreshold As Integer
RegMailInfo.DbQuotaWarningThreshold = mailThreshold
End Property
n'y a t-il pas incohérence Long / Integer ?
Publié:
26 Jan 2007 à 08:23par Stephane Maillard
Re,
Normalement il ne devrait pas y avoir de pb, essai de tout passer en long ou integer pour faire des tests.
UserRegistration Class
Publié:
26 Jan 2007 à 17:49par regm8
Oui l'argument fonctionne, mais ne tiens pas compte des valeurs que je lui renseigne.
Après:
'register
Call userReg.register(True)
Je parcours la base Admin4.nsf et je vais modifier la valeurs des champs dans la requète.
Merci pour avoir réfléchit à mon problème.
@+
Regm8
Publié:
26 Jan 2007 à 18:07par regm8
Ci quelqu'un se trouve confronté à mon problème.
- Code : Tout sélectionner
Set dbAdmin = s.GetDatabase( NameServ.Canonical, "admin4.nsf")
If dbAdmin.Title <> "" Then
requete=|Form = "AdminRequest" & ProxyAction="24" & @name([CN];ProxyNameList)="|+ Strconv(Doc.Prenom(0) , SC_ProperCase) & " " & Ucase(Doc.Nom(0))+|"|
Set collection = dbAdmin.Search(requete, Nothing, 0)
nbColl = collection.count
Set docAdmi4 = collection.GetFirstDocument
While Not(docAdmi4 Is Nothing)
docAdmi4.ProxyNumItem1=VarQuotasLim
docAdmi4.ProxyNumItem2=VarQuotasAl
Call docAdmi4.save(True,True)
Set docAdmi4 = collection.Getnextdocument(docAdmi4)
Wend
Else
Msgbox "Un problème est survenu -- Cf Admin4 pour -->"+NameUser.common
End If