Hjælp til kode der henter brugere fra AD
Håber på hurtigt hjælp til dette problem, da det har generet mig i lang tid nu, og jeg gerne snart skulle være færdig med opgaven.Jeg har en VBA kode, der bl.a. henter brugerinfomationer fra vores AD, til brug i en Word skabelon.
Mit store problem, er at når en bestemt person er logget ind og til gå skabelonen, så fejler koden med følgende fejl -> Run-time error 3021. Når jeg logget ind som en anden bruger, og vil vælge den bruger der skaber fejlen, så kommer der ingen fejl.
Altså må det være et eller andet med koden der hente brugerlogin og sammenligner med AD's brugerinfo, men lige hvor og hvordan det løser, ja, det vil jeg altså gerne have hjælp til.
Koden:
Public rs
Public afsName, afsTlf, afsMail, afsTitle, afsMobile, afsDistName As String
Public att As String
Public hilsen As String
'Public side As String
'Public sideaf As String
Public sprog As String
Public direkte As String
Public mobil As String
Public før
Public anden
Private Sub dansk_Click()
Me.att = "Att.:"
Me.hilsen = "Med venlig hilsen"
Me.sprog = "dansk"
Me.direkte = "Direkte:"
Me.mobil = "Mobil:"
'Dim BMRange As Range
'Identify current Bookmark range and insert text
'Set BMRange = ActiveDocument.Bookmarks("side").Range
'BMRange.Text = "Hello world"
'Re-insert the bookmark
'ActiveDocument.Bookmarks.Add "side", BMRange
' SkrivTilBogmaerke "side", "Side "
'SkrivTilBogmaerke "sideaf", "af "
'ActiveDocument.Bookmarks("side").Select
'Selection.TypeText Text:="Side"
'ActiveDocument.Bookmarks("sideaf").Select
'Selection.TypeText Text:="af"
ActiveDocument.ActiveWindow.View.Type = wdPrintView
End Sub
Private Sub engelsk_Click()
Me.att = "Att.:"
Me.hilsen = "Best regards"
Me.sprog = "engelsk"
Me.direkte = "Direct:"
Me.mobil = "Mobilephone:"
' SkrivTilBogmaerke "side", "Page "
' SkrivTilBogmaerke "sideaf", "of "
ActiveDocument.ActiveWindow.View.Type = wdPrintView
End Sub
Private Sub tysk_Click()
Me.att = "Z.Hd.:"
Me.hilsen = "Mit freundlichen Grüßen"
Me.sprog = "tysk"
Me.direkte = "Direkt:"
Me.mobil = "Mobilephone:"
' SkrivTilBogmaerke "side", "Seite "
'SkrivTilBogmaerke "sideaf", "von "
ActiveDocument.ActiveWindow.View.Type = wdPrintView
End Sub
Private Sub UserForm_Terminate()
ActiveDocument.Close False
End Sub
Public Sub SkrivTilBogmaerke(bmkName As String, bmkNyText As String)
If ActiveDocument.Bookmarks.Exists(bmkName) = True Then
ActiveDocument.Bookmarks(bmkName).Select
If Not ActiveDocument.Bookmarks(bmkName).Range.Text = "" Then
Selection.Range.Delete
End If
If Not bmkNyText = "" Then 'Indsætter tekst (og sletter bokmærke)
'**** Sletter evt. overflødige linieskift.
While Asc(Right(bmkNyText, 1)) = 13 Or Asc(Right(bmkNyText, 1)) = 10
bmkNyText = Left(bmkNyText, Len(bmkNyText) - 1)
Wend
Selection.TypeText "." 'Bruges til at bevare bogmærket
Selection.MoveLeft wdCharacter, 1, wdExtend
Selection.Bookmarks.Add bmkName
Selection.MoveLeft wdCharacter, 1
Selection.TypeText bmkNyText
Selection.Range.Delete
Else
Selection.Bookmarks.Add bmkName
End If
End If
End Sub
Sub find_bruger()
ActiveDocument.ActiveWindow.Visible = False
dansk_Click
dansk.Value = True
'Tøm felter for tidligere brev
tbModtager.Text = ""
tbFirma.Text = ""
tbAdresse.Text = ""
tbBy.Text = ""
tbOverskrift.Text = ""
'TextBox1.Text = ""
'rtbBrev.Text = ""
tbModtagerTlf.Text = ""
tbModtagerMobil.Text = ""
tbModtagerFax.Text = ""
' Create the connection and command object.
Set oConnection1 = CreateObject("ADODB.Connection")
Set oCommand1 = CreateObject("ADODB.Command")
' Open the connection.
oConnection1.Provider = "ADsDSOObject" ' This is the ADSI OLE-DB provider name
oConnection1.Open "Active Directory Provider"
' Create a command object for this connection.
Set oCommand1.ActiveConnection = oConnection1
' Compose a search string.
oCommand1.CommandText = "select sAMAccountName, distinguishedName, name, telephoneNumber, mail, title, l, mobile " & _
"from 'LDAP://serveren'" & _
"WHERE objectCategory='Person'" & _
"AND objectClass='user'" & _
"AND department=100" & _
"OR department=210" & _
"OR department=220" & _
"OR department=230" & _
"OR department=300" & _
"OR department=310" & _
"OR department=400" & _
"OR department=410" & _
"OR department=700"
' Execute the query.
Set rs = oCommand1.Execute
' Hvilken bruger skal markeres
Dim wshNetwork
Set wshNetwork = CreateObject("WScript.Network")
user = wshNetwork.UserName
'Domain = wshNetwork.userdomain
'computer = wshNetwork.ComputerName
'--------------------------------------
' Navigate the record set
' select the user
'--------------------------------------
While Not rs.EOF
startBoks.cbAfsender.AddItem rs.Fields("name")
If LCase(user) = LCase(rs.Fields("sAMAccountName")) Then
For i = 0 To cbAfsender.ListCount - 1
If cbAfsender.List(i) = rs.Fields("name") Then
cbAfsender.ListIndex = i
Exit For
End If
Next
End If
' Debug.Print rs.Fields("sAMAccountName")
' Debug.Print rs.Fields("name") & ", " & rs.Fields("telephoneNumber") & ", " & rs.Fields("mail") & ", " & rs.Fields("title") & ", " & rs.Fields("facsimileTelephoneNumber") & ", " & rs.Fields("mobile") & ", ---- " & rs.Fields("distinguishedName")
rs.MoveNext
Wend
End Sub
Private Sub cbAfsender_Change()
rs.MoveFirst
Dim found As Boolean
found = False
While (Not found) And (Not rs.EOF)
If LCase(cbAfsender.Value) = LCase(rs.Fields("name")) Then
found = True
Me.afsName = rs.Fields("name")
Me.afsTlf = rs.Fields("telephoneNumber")
Me.afsMail = rs.Fields("mail")
' Me.afsTitle = rs.Fields("title")
Me.afsMobile = rs.Fields("mobile")
Me.afsDistName = rs.Fields("distinguishedName")
Dim strAfsender As String
If Not IsNull(Me.afsName) Then
strAfsender = Me.afsName
End If
'If Not IsNull(Me.afsTitle) Then
' strAfsender = strAfsender & vbCrLf & Me.afsTitle
'End If
If Not IsNull(Me.afsMail) Then
strAfsender = strAfsender & vbCrLf & Me.afsMail
End If
If Not IsNull(Me.afsTlf) Then
strAfsender = strAfsender & vbCrLf & Me.afsTlf
End If
If Not IsNull(Me.afsMobile) Then
strAfsender = strAfsender & vbCrLf & Me.afsMobile
End If
Me.tbAfsenderdata = strAfsender
End If
rs.MoveNext
Wend
End Sub
Private Sub cdAnnuller_Click()
If MsgBox("Vil du lukke uden at oprette og gemme brevet?", vbYesNo, "Lukke dokument") = vbYes Then
startBoks.Hide
ActiveWindow.Close SaveChanges:=False
End If
End Sub
Private Sub opret_Click()
On Error Resume Next:
'afsender
Dim strAfsender As String
If Not IsNull(Me.afsName) Then
strAfsender = Me.afsName & vbCrLf
End If
'If Not IsNull(Me.afsTitle) Then
' strAfsender = strAfsender & vbCrLf & Me.afsTitle
'End If
If Not IsNull(Me.afsTlf) Then
strAfsender = strAfsender & vbCrLf & direkte & " " & Me.afsTlf
End If
If Not IsNull(Me.afsMobile) Then
strAfsender = strAfsender & vbCrLf & mobil & " " & Me.afsMobile
End If
If Not IsNull(Me.afsMail) Then
strAfsender = strAfsender & vbCrLf & Me.afsMail
End If
'Tjek for om alle nødvendige modtagerinfo er udfyldt, ellers oprettes dokumentet ikke.
If startBoks.tbFirma.Value = "" Then
MsgBox "Du har ikke udfyldt firmanavnet"
ElseIf startBoks.tbAdresse.Value = "" Then
MsgBox "Du har ikke udfyldt firmaadressen"
ElseIf startBoks.tbBy.Value = "" Then
MsgBox "Du har ikke udfyldt postnr. og/eller by"
ElseIf startBoks.tbModtager.Value = "" Then
MsgBox "Du har ikke udfyldt modtageren af brevet"
ElseIf startBoks.tbOverskrift.Value = "" Then
MsgBox "Du har ikke givet brevet en overskrift"
'ElseIf startBoks.TextBox1.Value = "" Then
' MsgBox "Du har ikke skrevet selve brevet"
ElseIf sprog = "" Then
MsgBox "Du har ikke valgt et sprog til stavekontrollen"
ElseIf sprog = "" Then
MsgBox "Du har ikke valgt et sprog til stavekontrollen"
Else
'End If
Set Range = ActiveDocument.Range
If sprog = "dansk" Then
Range.LanguageID = wdDanish
ElseIf sprog = "engelsk" Then
Range.LanguageID = wdEnglishUK
ElseIf sprog = "tysk" Then
Range.LanguageID = wdGerman
End If
'ElseIf sprog = "" Then
'If Not IsNull(sprog) Then
'side -> Da formular-felter ikke kan laves i sidehoved/fod ligger de i selve dokumentet.
'ActiveDocument.FormFields("side").Range.Text = side
'ActiveDocument.FormFields("af").Range.Text = sideaf
'hilsen
ActiveDocument.FormFields("hilsen").Range.Text = hilsen
'afsender
ActiveDocument.FormFields("afsender").Range.Text = strAfsender
'modtagerfimra
Dim strModtager As String
strModtager = startBoks.tbFirma.Value & vbCrLf & startBoks.tbAdresse.Value & vbCrLf _
& startBoks.tbBy.Value
ActiveDocument.FormFields("modtager").Range.Text = strModtager
'modtagerperson
ActiveDocument.FormFields("person").Range.Text = att & " " & startBoks.tbModtager.Value
'modtagertlf
ActiveDocument.FormFields("modtagerTlf").Range.Text = startBoks.tbModtagerTlf.Value
'modtagerfax
ActiveDocument.FormFields("modtagerFax").Range.Text = startBoks.tbModtagerFax.Value
'modtagermobil
ActiveDocument.FormFields("modtagerMobil").Range.Text = startBoks.tbModtagerMobil.Value
'overskrift
ActiveDocument.FormFields("overskrift").Range.Text = startBoks.tbOverskrift.Value
'brev
'ActiveDocument.FormFields("brev").Range.Text = startBoks.TextBox1.Text
'Skjuler formen
startBoks.Hide
ActiveDocument.ActiveWindow.View.Type = wdPrintView
'Udføre stavekontrol
Range.CheckSpelling
ActiveDocument.ActiveWindow.View.Type = wdPrintView
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
'Sætte Word til automatisk at udføre en stavekontrol
If Options.CheckGrammarWithSpelling = True Then
ActiveDocument.CheckGrammar
Else
ActiveDocument.CheckSpelling
End If
'ActiveDocument.Application.CheckLanguage = True
'Application.CheckLanguage = True
'Gem dokument
ActiveDocument.Save
' Skifter til udskriftslayout og sidebredde
ActiveDocument.ActiveWindow.View.Type = wdPrintView
ActiveDocument.ActivePane.View.Zoom.PageFit = wdPageFitBestFit
' Beskyt dokumentet.
If ActiveDocument.ProtectionType = wdNoProtection Then
ActiveDocument.Protect Type:=wdAllowOnlyFormFields, NoReset:=True, Password:=""
End If
End If
ActiveDocument.ActiveWindow.Visible = True
'End If
End Sub
