Function DbLookup(strServer As String, strDB As String, strView As String, strKey As String, column As String) As Variant
On Error Goto ops
Dim session As notesSession
Dim db As notesDatabase
Dim dbTmp As notesDatabase
Dim viewTmp As NotesView
Dim Nvcol As NotesViewEntryCollection
Dim ventry As NotesViewEntry
Dim col As notesViewColumn
Dim tmpArray() As Variant
Dim Lista As Variant
Dim tmpcount As Integer
Set session = New NotesSession
Set db = session.currentDatabase
If strServer = "" Then
strServer = db.Server
End If
If strDB = "" Then
Set dbTmp = db
Else
Set dbTmp = session.GetDatabase(strServer, strDB)
End If
If dbTmp Is Nothing Then
Msgbox "Base não encontrada ou não pode ser abertar"
DbLookup = ""
Exit Function
End If
Set viewTmp = dbTmp.GetView(strView)
If viewTmp Is Nothing Then
Msgbox "View não encontrada"
DbLookup = ""
Exit Function
End If
Call viewTmp.Refresh
Set Nvcol = viewTmp.GetAllEntriesByKey(strKey,True)
If Nvcol.Count <> 0 Then
Set ventry = Nvcol.GetFirstEntry()
tmpcount=0
While Not (ventry Is Nothing)
If Isarray(ventry.ColumnValues(column)) Then
Lista = ventry.ColumnValues(column)
For y = 0 To Ubound(Lista)
Redim Preserve tmpArray(y)
tmpArray(y) = lista(y)
' Msgbox "valor encontrado = " & lista(y)
Next
Else
Redim Preserve tmpArray(tmpcount)
' pega os valores na coluna
tmpArray(tmpcount) = Cstr(ventry.ColumnValues(column))
' Msgbox "valor encontrado = " & Cstr(ventry.ColumnValues(column))
tmpcount=tmpcount + 1
End If
Set ventry = Nvcol.GetNextEntry(ventry)
Wend
'Retorna o resultado
DbLookup = Arrayunique(tmpArray)
Else
DbLookup = ""
End If
sai:
Exit Function
ops:
Msgbox "Erro na função Dblookup na linha " & Erl & " do tipo " & Err & " " & Error
DbLookup = ""
Resume sai
End Function
Nenhum comentário:
Postar um comentário