segunda-feira, 26 de julho de 2010

DbLookup em Ls

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