Exemplo de db.search com multiplos valores para busca

Dim SearchFormula As String
Dim strLotacao As String

searchFormula = |Form = "NOMEDOFORME" & @Uppercase(CAMPO_A) ="| & Ucase(valorA) & |" & (fld_dt_criado >= [| & Cstr(dataInicio) & |] & fld_dt_criado <= [| & Cstr(dataFim) & |]) |

Ex.: doc.CAMPO_B = ["AG", "AS", "GE"] ( Array com 3 valores )

'CONCATENA OS VALORES PARA BUSCA
strLotacao = {"} & Implode(doc.CAMPO_B, {":"}) & {"}

searchFormula = searchFormula & "&" & | @If(@Uppercase(tx_tiposolicitante)="CONTRATADO";@Contains(@Uppercase(tx_departamento);@Uppercase(| & strLotacao &|));@Contains(@Uppercase(tx_departamento_solic);@Uppercase(| & strLotacao &|)))|

Rotina para geração de gráfico em Barra no Excel

Sub Grafico_Barra

On Error Goto trataerro
'seta a wsheet
xlApp.Sheets("Plan1").Select
'cria o gráfico
xlApp.Charts.Add
With xlApp.ActiveChart
.ChartArea.Select
'tipo do gráfico
.ChartType = xlColumnClustered
'//origem dos dados p/gráficos
.SetSourceData xlApp.Range(xlsheet.Cells(rows + 3, cols + 1 ), xlsheet.Cells( rows + 9, cols + 2)),2
'seta aonde o gráfico será exibido ( nova wsheet / na atual)
.Location 2, "Plan1"
End With
'alinhamento do gráfico
xlApp.ActiveSheet.Shapes(xlApp.ActiveChart.Parent.Name).Top = xlApp.ActiveSheet.Cells(rows , cols + 4 ).Top -133.5
'alinhamento do gráfico
xlApp.ActiveSheet.Shapes(xlApp.ActiveChart.Parent.Name).Left = xlApp.ActiveSheet.Cells(rows , cols + 4 ).Left + 100

Exit Sub
trataerro:
Msgbox " Erro - Rotina:'Grafico_Barra' Linha:"&Cstr(Erl)&" Tipo:"&Cstr(Erl)&" "&Cstr(Error)
Exit Sub
End Sub

Cálculo de horas

Sub Click(Source As Button)

On Error Goto erro

Dim ws As New NotesUIWorkspace
Dim doc As NotesDocument
Set doc = ws.CurrentDocument.Document

Dim aux1 As Double
Dim aux2 As Double
Dim aux3 As Double
Dim aux4 As Double
Dim aux5 As Double


aux1 = RetornaHora(doc.campo1(0))
aux2 = RetornaHora(doc.campo2(0))

aux3 = aux1 + aux2

Msgbox ConvertToHHMM(aux3)


Exit Sub
erro:
Msgbox "Linha:" & Cstr(Erl) & " tipo" & Cstr(Err) & " " & Cstr(Error)
Exit Sub
End Sub


Function RetornaHora(hora As String) As Double
On Error Goto erro

Dim hr As Double
Dim min As Double
Dim aux As Double

hr = Hour(hora)
min = Minute(hora)
aux = hr + (min / 60)
RetornaHora = aux

Exit Function
erro:
Msgbox "Linha:" & Cstr(Erl) & " tipo" & Cstr(Err) & " " & Cstr(Error)
Exit Function
End Function

Function ConvertToHHMM(dbl_hora As Double) As String
On Error Goto TrataErro

ConvertToHHMM = ""

hr
min =0 str_hr =""
str_min =""

If Instr(Cstr(dbl_hora),",") > 0 Then
hr = Cint(Strleft(Cstr(dbl_hora),","))
min = Fraction(dbl_hora) * 60

If Len(Cstr(hr)) > 1 Then
str_hr = Cstr(hr)
Else
str_hr = "0"+Cstr(hr)
End If

If Len(Cstr(min)) > 1 Then
str_min = Cstr(min)
Else
str_min = "0"+Cstr(min)
End If

' Msgbox Cstr(hr) & ":"& Cstr(min)
Else
If Len(Cstr(dbl_hora)) > 1 Then
str_hr = Cstr(dbl_hora)
Else
str_hr = "0"+Cstr(dbl_hora)
End If
str_min = "00"
End If

ConvertToHHMM=str_hr+":"+str_min

Exit Function
TrataErro:
Msgbox "Erro - Agente: 'NOMEDOAGENTE' Função:'ConvertToHHMM' - Linha:"&Cstr(Erl)&" Tipo:"&Cstr(Err)&" "&Cstr(Error),16,"Operação Cancelada"
Exit Function
End Function

Rotina de geração de gráfico para o BrOffice (Calc)

Sub Click(Source As Button)
Set objServiceManager = CreateObject("com.sun.star.ServiceManager")
Set objCoreReflection = objServiceManager.createInstance("com.sun.star.reflection.CoreReflection")
Set StarDesktop = objServiceManager.createInstance("com.sun.star.frame.Desktop")
Set dispatcher = objServiceManager.createInstance("com.sun.star.frame.DispatchHelper")
Set teste = objServiceManager.createInstance("com.sun.star.table.TableColumn")

' Cria um novo documento do Calc
Dim args()
sUrl = "private:factory/scalc"
Set oDoc = StarDesktop.loadComponentFromURL(sUrl, "_blank", 0, args())
Set frame = oDoc.CurrentController.Frame

' obtém a primeira planilha no documento
Set oPlanilha = oDoc.getSheets().getByIndex(0)


'Montando os valores pré-definidos (TABELA) *Dados Fictícios
'LINHA
Set oCelula = oPlanilha.getCellByPosition(0, 0)
oCelula.setString("RELATÓRIO:")
Set oCelula = oPlanilha.getCellByPosition(1, 0)
oCelula.setString("Satisfeito")
Set oCelula = oPlanilha.getCellByPosition(2, 0)
oCelula.setString("Nem Satisfeito / Nem Insatisfeito")
Set oCelula = oPlanilha.getCellByPosition(3, 0)
oCelula.setString("Insatisfeito")

'COLUNA
Set oCelula = oPlanilha.getCellByPosition(0, 1)
oCelula.setString("Tempo de Resposta")
Set oCelula = oPlanilha.getCellByPosition(0, 2)
oCelula.setString("Conteúdo da Resposta")
Set oCelula = oPlanilha.getCellByPosition(0, 3)
oCelula.setString("Facilidade de Acesso ao Sistema")

'Valores internos na tabela
For i=1 To 3
Set oCelula = oPlanilha.getCellByPosition(1, i)
oCelula.setValue(i+2)
Set oCelula = oPlanilha.getCellByPosition(2, i)
oCelula.setValue(i+4)
Set oCelula = oPlanilha.getCellByPosition(3, i)
oCelula.setValue(i-1)
Next

'GRÁFICO
Set classSize = objCoreReflection.forName("com.sun.star.awt.Rectangle")
classSize.createObject aStruct
Set Rect = aStruct

Dim RangeAddress(0)
Set classSize = objCoreReflection.forName("com.sun.star.table.CellRangeAddress")
classSize.createObject aStruct
Set RangeAddress(0) = aStruct

Set Charts = oDoc.getSheets().getByIndex(0).Charts

Rect.X = 8000
Rect.Y = 1000
Rect.Width = 10000
Rect.Height = 7000
RangeAddress(0).Sheet = 0
RangeAddress(0).StartColumn = 0
RangeAddress(0).StartRow = 0
RangeAddress(0).EndColumn = 3
RangeAddress(0).EndRow = 3

Call Charts.addNewByName("MyChart", Rect, RangeAddress(), True, True)
Set Chart = Charts.getByName("MyChart").embeddedObject

Set Chart.Diagram = Chart.createInstance("com.sun.star.chart.BarDiagram")

Chart.HasMainTitle = True
Chart.Title.String = "Title"
Chart.HasSubTitle = True
Chart.Subtitle.String = "Subtitle"
Chart.HasLegend = True
Chart.Legend.CharHeight = 7
Chart.Diagram.HasYAxisTitle = True
Chart.Diagram.YAxisTitle.String = "Total de Respostas"
End Sub

Mascara para qualquer tipo de campo

Uutilizada no evento onkeypress

HORA: return txtBoxFormat(this.form, this.name, '99:99', event);
CEP: return txtBoxFormat(this.form, this.name, '99999-999', event);
TELEFONE: return txtBoxFormat(this.form, this.name, '(99)9999-9999', event);
CPF: return txtBoxFormat(this.form, this.name, '999.999.999-99', event);


function txtBoxFormat(objForm, strField, sMask, evtKeyPress) {
var i, nCount, sValue, fldLen, mskLen,bolMask, sCod, nTecla;

if(document.all) { // Internet Explorer
nTecla = evtKeyPress.keyCode;
} else if(document.layers) { // Nestcape
nTecla = evtKeyPress.which;
} else {
nTecla = evtKeyPress.which;
if (nTecla == {
return true;
}
}

sValue = objForm[strField].value;
// Limpa todos os caracteres de formatação que
// já estiverem no campo.
// toString().replace [transforma em sring e troca elementos por ""]
sValue = sValue.toString().replace( "-", "" );
sValue = sValue.toString().replace( "-", "" );
sValue = sValue.toString().replace( ".", "" );
sValue = sValue.toString().replace( ".", "" );
sValue = sValue.toString().replace( "/", "" );
sValue = sValue.toString().replace( "/", "" );
sValue = sValue.toString().replace( "/", "" );
sValue = sValue.toString().replace( "(", "" );
sValue = sValue.toString().replace( "(", "" );
sValue = sValue.toString().replace( ")", "" );
sValue = sValue.toString().replace( ")", "" );
sValue = sValue.toString().replace( " ", "" );
sValue = sValue.toString().replace( " ", "" );
sValue = sValue.toString().replace( ":", "" );
sValue = sValue.toString().replace( ":", "" );
fldLen = sValue.length;
mskLen = sMask.length;

i = 0;
nCount = 0;
sCod = "";
mskLen = fldLen;

while (i <= mskLen) { bolMask = ((sMask.charAt(i) == "-") || (sMask.charAt(i) == ":") || (sMask.charAt(i) == ".") || (sMask.charAt(i) == "/")) bolMask = bolMask || ((sMask.charAt(i) == "(") || (sMask.charAt(i) == ")") || (sMask.charAt(i) == " ") || (sMask.charAt(i) == ".")) //Se for true utiliza elementos especiais aumenta a máscara if (bolMask) { sCod += sMask.charAt(i); mskLen++; //Caso false mostra o sValue(o q foi digitado) } else { sCod += sValue.charAt(nCount); nCount++; } i++; } objForm[strField].value = sCod; if (nTecla != { // backspace if (sMask.charAt(i-1) == "9") { // apenas números... return ((nTecla > 47) && (nTecla < 58)); } // números de 0 a 9
else { // qualquer caracter...
return true;
}
} else {
return true;
}
}

Desabilita teclas no browser

function f_KeyDown(evt){
// Captura a tecla Digitada

// code for IE
var evt = window.event;
var pressedKey = String.fromCharCode(evt.keyCode).toLowerCase();

//Desabilita o CTRL-C, V, X e P
if (window.event.ctrlKey && (pressedKey == "c" || pressedKey == "v" || pressedKey == "x" || pressedKey == "p")) {
// disable key press porcessing
cancelKey(evt);
}

//Desabilita o BACKSPACE e ESC.
if ( evt.keyCode==08 || evt.keyCode==27){
// disable key press porcessing
cancelKey(evt);
}
//Desabilita o F5.
if ( evt.keyCode==116){
// disable key press porcessing
cancelKey(evt);
}
}


function cancelKey(evt){

if (evt.preventDefault) {
evt.preventDefault();
return false;
}else {
evt.keyCode = 0;
evt.returnValue = false;
}
}

Desabilita o botão direito no browser

//inserir no header

document.oncontextmenu = function(){return false};

Capturar Teclas Digitadas no browser

function getKey(e){
if (e == null) { // ie
keycode = event.keyCode;
} else { // mozilla
keycode = e.which;
}
key = String.fromCharCode(keycode).toLowerCase();
}
}

Redirecionando com $$Return

Ex.1: Redirecionar para formulário específico: ex. frmPrincipal
Criar o campo $$Return do tipo 'computed for display' e insira no valor default

"[" + @webdbname + "/frmPrincipal?OpenForm]"

Ou para Notes 5:

DBName:=@ReplaceSubstring( @Subset( @DbName ; -1 ) ; "\\" ; "/" );
"[" + DbName + "/frmPrincipal?OpenForm]"

Ex.2: Redirecionar para o documento corrente
Criar o campo $$Return do tipo 'computed for display' e insira no valor default

"[/" + @webdbname + "/0/" + @Text(@DocumentUniqueID) + "?OpenDocument]"

Ou para Notes 5:

db := @Replacesubstring(@Subset(@Dbname; -1); " ":"\\"; "+":"/");
"[/" + db + "/0/" + @Text(@DocumentUniqueID) + "?OpenDocument]"


Ex.3: Redirecionar para uma visão
Criar o campo $$Return do tipo 'computed for display' e insira no valor default

"[/" + @webdbname + "/" + ViewName + "?OpenView]"

Ou para Notes 5:

db := @Replacesubstring(@Subset(@Dbname; -1); " ":"\\"; "+":"/");
"[/" + db + "/" + ViewName + "?OpenView]"


Ex.4: Utilizar o $$Return com condições diferentes:
Criar o campo $$Return do tipo 'computed for display' e insira no valor default

DB := @Replacesubstring(@Subset(@Dbname; -1); " ":"\\"; "+":"/");
unid:=@Text(@DocumentUniqueID);
c:="";
a:="[/" + DB + "/FrmConfirmation?ReadForm]";
b:="[/" + DB + "?OpenDatabase]";
d:=@If(@UserName="Anonymous";a ; c);
e:="[/" + DB +"/0/"+ unid+"?OpenDocument]";
@If(@IsDocBeingEdited & @ViewTitle="Gerencia" ;e;d)

Ler parametros passados via URL

Exemplo da URL:
http://servidor/base.nsf/formulario?Openform&par1=exemplopar1&par2=exemplopar2

Ex 1: Em Formula

NOTES RELEASE 6 EM DIANTE:

parametro1:=@urlQueryString("par1");
parametro2:=@urlQueryString("par2");

valor do parametro1: "exemplopar1"
valor do parametro2: "exemplopar2"

NOTES RELEASE ANTERIOR A 6:

_ArgsNames:=@Left(@Explode(@Right(Query_String_Decoded;"&");"&");"=");
_ArgValues:=@Right(@Explode(@Right(Query_String_Decoded;"&");"&");"=");

parametro1:= @If( _ArgsNames !="";@Do(@If(@Member("par1";_ArgsNames)>0;@GetMembers(_ArgValues;@Member("par1";_ArgsNames); 1); "")); "Sem VALOR")

parametro2:= @If( _ArgsNames !="";@Do(@If(@Member("par2";_ArgsNames)>0;@GetMembers(_ArgValues;@Member("par2";_ArgsNames); 1); "")); "Sem VALOR")


Ex 2: JavaScript

Utilizando a fução getURLParam.

parametro1=getURLParam('par1');
parametro2=getURLParam('par2');

valor do parametro1: "exemplopar1"
valor do parametro2: "exemplopar2"


function getURLParam(strParamName){

var strReturn = "";
var strHref = window.location.href;
if ( strHref.indexOf("?") > -1 ){
var strQueryString = "&" + strHref.substr(strHref.indexOf("?") + 1); //.toLowerCase();
var aQueryString = strQueryString.split("&");
for ( var iParam = 0; iParam < aQueryString.length; iParam++ ){ if (aQueryString[iParam].indexOf(strParamName + "=") > -1 ){
var aParam = aQueryString[iParam].split("=");
strReturn = aParam[1];
break;
}
}
}
return strReturn;
},


Ex 3: Lotus Script


Utilizando a fução getURLParam.

'<-- Aqui eu pego o parametro passado pela URL -->
parametro1 = f_retornaParametroURL (Ucase(doccontext.Query_String(0)),"par1")

'<-- Aqui eu pego o parametro passado pela URL -->
parametro2 = f_retornaParametroURL (Ucase(doccontext.Query_String(0)),"par2")


Function f_retornaParametroURL ( qry As String, param As String ) As String
On Error Goto erro

Dim i,j As Integer
Dim result As String

i = Instr(1, qry, param)
result= ""

If i > 0 Then
j = Instr(i, qry, "&")
If j > 0 Then
result$ = Mid(qry, i + Len(param) + 1, (j - 1) - (i + Len(param)))
Else
result$ = Mid(qry, i + Len(param) + 1)
End If
End If
f_retornaParametroURL = result

sai:
Exit Function
erro:
Msgbox "Erro na função f_retornaParametroURL na linha " + Str$(Erl) + " do tipo " + Str$(Err) + ": " + Error$
Resume sai
End Function


 function queryString(parameter) {
 var loc = location.search.substring(1, location.search.length);
 var param_value = false;
 var params = loc.split("&");
 for (i=0; i
 param_name = params[i].substring(0,params[i].indexOf('='));
 if (param_name == parameter) {
 param_value = params[i].substring(params[i].indexOf('=')+1)
 }
 }
 if (param_value) {
 return param_value;
 }
 else {
 return false;
 }
} 

Função para adicionar caracter a uma string informando a posição

AdicionaCaracter("String",4, ".")

Function AdicionaCaracter(valor As String,qtdToAddCaracter As Integer, caracter As String) As String

Dim texto As String, novaString As String
Dim ponto As Integer, total As Integer, cont As Integer
cont = 0

texto = valor
ponto = qtdToAddCaracter
total = Len(valor)

While cont < total
novaString = novaString & caracter & Cstr(Mid(texto,cont+1,4))
cont = cont+4
Wend

AdicionaCaracter = Right$(novaString,Len(novaString)-1)

End Function

Array Unique

Function strUniqueArray(array_in As Variant) As Variant
'Finalidade : Retirar os itens repetidos do array.
Dim array_aux As Variant
Dim array_out() As Variant
Dim ind As Integer
ind = 0
array_aux = array_in
If Isarray(array_aux) Then
Forall a In array_aux
If ind = 0 Then
Redim Preserve array_out(ind)
array_out(ind) = a
ind = ind + 1
Else
If strOcurrencesInArray(array_out, a) = 0 Then
Redim Preserve array_out(ind)
array_out(ind) = a
ind = ind + 1
End If
End If
End Forall
Else
strUniqueArray = array_in
Exit Function
End If
strUniqueArray = array_out
End Function

Formatar CNPJ

Function FormataCNPJ(str_cnpj As String ) As String


On Error Goto erro


Dim cnpj_original,ponto,barra,ifem,esq,dire As String
Dim parte1,parte2,parte3,parte4,parte5 As String
Dim tamanho,posicao As Integer

cnpj_original = str_cnpj
ponto = "."
barra = "/"
ifem = "-"

'Retira os pontos, barra e ifem
While Instr(str_cnpj, ponto) > 0 Or Instr(str_cnpj, barra) > 0 Or Instr(str_cnpj, ifem) > 0
tamanho = Len(str_cnpj)
posicao = Instr(str_cnpj, ponto)
If (posicao = 0 ) Then
posicao = Instr(str_cnpj, barra)
End If
If (posicao = 0 ) Then
posicao = Instr(str_cnpj, ifem)
End If

esq = Left(Cstr(str_cnpj), posicao -1)
dire = Right(Cstr(str_cnpj),tamanho - (posicao))
FormataCNPJ = Cstr(esq)+Cstr(dire)

Wend

'Verifica se é apenas numerico e se tem o tamanho correto do cnpj (só com numeros)
If Not Isnumeric(str_cnpj) Or Len(str_cnpj) <> 14 Then
Msgbox "Formato invalido do CNPJ, digite apenas numeros",,"Aviso Sistema"
FormataCNPJ = cnpj_original
Exit Function
End If

'Formata o CNPJ
parte1 = Left(Cstr(str_cnpj),2)+Cstr(ponto)
parte2 = Mid(Cstr(str_cnpj),3,3)+Cstr(ponto)
parte3 = Mid(Cstr(str_cnpj),6,3)+Cstr(barra)
parte4 = Mid(Cstr(str_cnpj),9,4)+Cstr(ifem)
parte5 = Mid(Cstr(str_cnpj),13,2)

FormataCNPJ = Cstr(parte1)+Cstr(parte2)+Cstr(parte3)+Cstr(parte4)+Cstr(parte5)

sai:
Exit Function
erro:
Msgbox "Erro na função FormataCNPJ da biblioteca BibRetencaoImposto na linha " + Str$(Erl) + " do tipo " + Str$(Err) + ": " + Error$
FormataCNPJ = cnpj_original
Resume sai
End Function

Formatar Cpf

Function FormataCPF(str_cpf As String) As String

On Error Goto erro

Dim cpf_original,CPF,Novostr_cpf,Tam,char,x As String
Dim i As Integer

'seta com o valor recebido como parametro
cpf_original = str_cpf

x = str_cpf
Tam = Len( x )

' se o campo for vazio sai do campo....
If Tam = 0 Then
FormataCPF = cpf_original
Exit Function
End If



Redim PosCaracter( Tam ) As String

For i = 1 To Tam
PosCaracter( i ) = Mid ( x , i , 1)
If Isnumeric ( PosCaracter( i ) ) Then
Novostr_cpf = Novostr_cpf & PosCaracter ( i )
End If
Next i

Tam = Len ( Novostr_cpf )
str_cpf= Novostr_cpf


Char = Cstr(Mid(str_cpf,9,1))


If Char = " " Or str_cpf = " " Then
FormataCPF = cpf_original
Exit Function
End If

Char = Cstr(Mid(str_cpf,11,1))

If Char = " " Then
Char = Cstr(Mid(str_cpf,10,1))
If Char = " " Then
str_cpf = "00" & Mid(str_cpf,1,1) & "." & Mid(str_cpf,2,3) & "." & Mid(str_cpf,5,3)_
& "-" & Mid(str_cpf,8,2)
Else
str_cpf = "0" & Mid(str_cpf,1,2) & "." & Mid(str_cpf,3,3) & "." & Mid(str_cpf,6,3)_
& "-" & Mid(str_cpf,9,2)
End If
Else
str_cpf = Mid(str_cpf,1,3) & "." & Mid(str_cpf,4,3) & "." & Mid( str_cpf ,7,3)_
& "-" & Mid( str_cpf ,10,2)
End If

CPF = str_cpf

If Tam = 11 Then
FormataCPF = str_cpf
Else
FormataCPF = cpf_original
Exit Function
End If


sai:
Exit Function
erro:
Msgbox "Erro na função FormataCPF da biblioteca BibRetencaoImposto na linha " + Str$(Erl) + " do tipo " + Str$(Err) + ": " + Error$
FormataCPF = cpf_original
Resume sai

End Function

Retorna Data

Function RetornaData(str_dt As String) As String

On Error Goto erro
Dim dt_original,dia,mes,ano As String

dt_original = str_dt

dia = Right(str_dt , 2 )
mes = Mid( str_dt ,5 , 2 )
ano = Left( str_dt , 4 )

RetornaData = Cstr(dia) + "/" + Cstr(mes) + "/" + Cstr(ano)


sai:
Exit Function
erro:
Msgbox "Erro na função RetornaData da biblioteca BibRetencaoImposto na linha " + Str$(Erl) + " do tipo " + Str$(Err) + ": " + Error$
RetornaData = dt_original
Resume sai
End Function

Troca ponto por virgula

Function TrocaPontoPorVirgula(Texto) As String

On Error Goto erro

Dim Começo, Tamanho As Long
Dim TextoAux,valoriginal As String

valoriginal = Texto
TextoAux = Texto
Começo = Instr(TextoAux,".")
Tamanho = Len(TextoAux)
While Começo > 0
TextoAux = Left$(TextoAux,Começo - 1) + "," + Right$(TextoAux, Tamanho - Começo)
Começo = Instr(TextoAux,".")
Wend
TrocaPontoPorVirgula = TextoAux

sai:
Exit Function
erro:
Msgbox "Erro na função TrocaPontoPorVirgula da biblioteca BibRetencaoImposto na linha " + Str$(Erl) + " do tipo " + Str$(Err) + ": " + Error$
TrocaPontoPorVirgula = valoriginal
Resume sai
End Function

Função para ocultar ou exibir elemento

/*******************************************************************
Função para exibir o elemento
*******************************************************************/
function f_exibe(elem) {
var el = document.getElementById(elem);

if(el.style.display == 'none'){
el.style.display = 'block';
}else{
el.style.display = 'block';
}
}

/*******************************************************************
Função para ocultar o elemento
*******************************************************************/
function f_esconde(id) {
var e = document.getElementById(id);
if(e.style.display == 'block')
e.style.display = 'none';
else
e.style.display = 'none';
}

ValidaCPF

Function ValidaCPF(cpf As String) As Boolean



' Verificando se o CPF é verdadeiro

carcterescpf = Len(CPF)
For i=1 To carcterescpf
caracter = Mid(cpf,i,1)
If Not(caracter = "0" Or caracter = "1" Or caracter = "2" Or caracter = "3" Or caracter = "4" Or caracter = "5"_
Or caracter = "6" Or caracter = "7" Or caracter = "8" Or caracter = "9") Then
ValidaCPF = True
Exit Function
End If
Next

If carcterescpf <11 Then zeros = "" For i = 1 To (11-carcterescpf ) zeros = "0" & zeros Next cpf = zeros & cpf End If 'Cálculo do 1º Dígito verificador dv1=0 elem1=Mid(cpf,1,1) res1=Cdbl(elem1)*10 elem2=Mid(cpf,2,1) res2=Cdbl(elem2)*9 elem3=Mid(cpf,3,1) res3=Cdbl(elem3)*8 elem4=Mid(cpf,4,1) res4=Cdbl(elem4)*7 elem5=Mid(cpf,5,1) res5=Cdbl(elem5)*6 elem6=Mid(cpf,6,1) res6=Cdbl(elem6)*5 elem7=Mid(cpf,7,1) res7=Cdbl(elem7)*4 elem8=Mid(cpf,8,1) res8=Cdbl(elem8)*3 elem9=Mid(cpf,9,1) res9=Cdbl(elem9)*2 soma=res1+res2+res3+res4+res5+res6+res7+res8+res9 resto=soma Mod 11 If resto=0 Or resto=1Then dv1=0 Else dv1=11 - resto 'Cálculo do 2º Dígito Verificador dv2=0 elem1dv2=Mid(cpf,1,1) res1dv2=Cdbl(elem1dv2)*11 elem2dv2=Mid(cpf,2,1) res2dv2=Cdbl(elem2dv2)*10 elem3dv2=Mid(cpf,3,1) res3dv2=Cdbl(elem3dv2)*9 elem4dv2=Mid(cpf,4,1) res4dv2=Cdbl(elem4dv2)*8 elem5dv2=Mid(cpf,5,1) res5dv2=Cdbl(elem5dv2)*7 elem6dv2=Mid(cpf,6,1) res6dv2=Cdbl(elem6dv2)*6 elem7dv2=Mid(cpf,7,1) res7dv2=Cdbl(elem7dv2)*5 elem8dv2=Mid(cpf,8,1) res8dv2=Cdbl(elem8dv2)*4 elem9dv2=Mid(cpf,9,1) res9dv2=Cdbl(elem9dv2)*3 elem10=dv1 res10dv2=elem10 * 2 soma2=res1dv2+res2dv2+res3dv2+res4dv2+res5dv2+res6dv2+res7dv2+res8dv2+res9dv2+res10dv2 resto2=soma2 Mod 11 If resto2=0 Or resto2=1 Then dv2=0 Else dv2=11 - resto2 testadv1=0 testadv2=0 cpfdv1=Cdbl(Mid(cpf,10,1)) If cpfdv1>11 Or testadv1=1 Or testadv2=1 Then
ValidaCPF = True
Exit Function
End If


End Function

UniquedbLookup

function uniquedbLookup(server,base,visao,chave,coluna){

xmlDoc = new ActiveXObject("Microsoft.XMLDOM");
xmlDoc.async = false;

if (server != "") server = "http://"+ server;
if (base != "") base = "/"+base +"/";

var start = Number(chave);

//urlgetfrm = trim(server)+trim(base)+visao+"?readviewentries&count=99999";
urlgetfrm = trim(server)+trim(base)+visao+"?readviewentries";
xmlDoc.load(urlgetfrm);

if (start > xmlDoc.documentElement.childNodes.length)
start = xmlDoc.documentElement.childNodes.length;


//alert("Procurar a partir da posicao " + start + " da visao");

//pegando a entrada de acordo com a chave ou de acordo com o count da view
urlgetfrm = trim(server)+trim(base)+visao+"?readviewentries&start="+start+"&count=1";
xmlDoc.load(urlgetfrm);

var count = 0;
var flag = xmlDoc.documentElement.childNodes(0).childNodes.item(0).text;

// alert("Valor da posicao " + start +" = " + flag);

while (flag !=chave & flag != "")
{
// if (count != 0)alert("Ultimo valor lido é " + flag);

count = start -1; //pegando ate a ultima posicao antes do inicio da lista anterior
// forçando a procura inciar em N posicoes atras ou no primeiro documento da view
start = start - 1000;
if (start < 0) start = 1; // alert("Pegando " + count + " documentos, a partir da posicao " + start); urlgetfrm = trim(server)+trim(base)+visao+"?readviewentries&start="+start+"&count="+count; xmlDoc.load(urlgetfrm); nodes = xmlDoc.documentElement.childNodes; //corresponde a nova collection var numchave = Number(chave); // alert("Numero de arquivos:" + nodes.length); var volta = ""; for (var i = 0; i < nodes.length; i++) { // alert(nodes.item(i).childNodes.item(0).text); var numero = Number(nodes.item(i).childNodes.item(0).text); if (numero > numchave)
{
if (i==0) volta = (nodes.item(i).childNodes.item(0).text); //primeiro valor da lista é maior, entao refazer a lista, buscando mais atras
else volta = ""; // encontrou valor maior depois do 1º valor lido => valor procurado nao existe
break;
}

else if(nodes.item(i).childNodes.item(0).text==chave)
{
volta = nodes.item(i).childNodes.item(0).text;
break;
}

}
flag = volta;
///alert(flag);

}

return(volta);

}

dbLookupUnique

function dbLookupUnique(server,base,visao,chave,coluna){
xmlDoc = new ActiveXObject("Microsoft.XMLDOM");
xmlDoc.async = false;



if (server != "") server = "http://"+ server;
if (base != "") base = "/"+base +"/";

urlgetfrm = trim(server)+trim(base)+visao+"?readviewentries&startkey=" +chave+ "&count=1";

xmlDoc.load(urlgetfrm);

nodes = xmlDoc.documentElement.childNodes;


temp = new Array(nodes.length);
var j = 0;
//alert("A chave : " + chave);
for (var i = 0; i < nodes.length; i++)
{

//alert(nodes.item(i).childNodes.item(0).text);
if(nodes.item(i).childNodes.item(0).text==chave)
{
temp[j] = nodes.item(i).childNodes.item(coluna-1).text;
j++;
}
}

volta = new Array(j);

for (var i = 0; i < j; i++)
{
volta[i] = temp[i];
}


return(volta);

}

dbLookup

function dbLookup(server,base,visao,chave,coluna){
alert('1');
xmlDoc = new ActiveXObject("Microsoft.XMLDOM");
xmlDoc.async = false;



if (server != "") server = "http://"+ server;
if (base != "") base = "/"+base +"/";

urlgetfrm = trim(server)+trim(base)+visao+"?readviewentries&count=99999";
//urlgetfrm = trim(server)+trim(base)+visao+"?readviewentries";
alert(urlgetfrm);
xmlDoc.load(urlgetfrm);

nodes = xmlDoc.documentElement.childNodes;


temp = new Array(nodes.length);
var j = 0;
//alert("A chave : " + chave);
for (var i = 0; i < nodes.length; i++)
{

//alert(nodes.item(i).childNodes.item(0).text);
if(nodes.item(i).childNodes.item(0).text==chave)
{
alert('ac');
temp[j] = nodes.item(i).childNodes.item(coluna-1).text;
j++;
}
}
alert(i);
volta = new Array(j);

for (var i = 0; i < j; i++)
{
volta[i] = temp[i];
}


return(volta);

}

DbColumn

function dbColumn(server,base,visao,coluna,unique){

xmlDoc = new ActiveXObject("Microsoft.XMLDOM");
xmlDoc.async = false;

if(unique=="") unique = false;

if (server != "") server = "http://"+ server;
if (base != "") base = "/"+base +"/";

//urlgetfrm = trim(server)+trim(base)+visao+"?readviewentries&count=10000";
urlgetfrm = trim(server)+trim(base)+visao+"?readviewentries";
xmlDoc.load(urlgetfrm);

nodes = xmlDoc.documentElement.childNodes;

volta = new Array();
z = -1;
for (var i = 0; i < nodes.length; i++)
{
if(unique)
{
if(i==0)
{
z++;
volta[z] = nodes.item(i).childNodes.item(coluna-1).text;
}
else
{
if(volta[z] != nodes.item(i).childNodes.item(coluna-1).text)
{
z++;
volta[z] = nodes.item(i).childNodes.item(coluna-1).text;
}
}
}
else
volta[i] = nodes.item(i).childNodes.item(coluna-1).text;
}


return(volta);

}

Formatar data e hora

Formato da data: dd/mm/aaaa

data:
@If(@Day(@now)>9;"";"0")+@Text(@Day(@now))+"/"+@If(@Month(@now)>9;"";"0")+@Text(@Month(@now))+"/"+@Text(@Year(@now))


Formato da hora: hh:mm

hora:
@Text(@Hour(@now)) + ":" + @If(@Minute(@now)>9;"";"0") + @Text(@Minute(@now))

Equivalente @Unique

Function Unique(sourceList As Variant) As Variant
On Error Goto errorHandle
Dim uniqueList List As Variant
Dim returnArray() As Variant ' return value
Dim count%

' Check to see we have more than one value
If Isscalar( sourceList ) Then
Unique = sourceList

Else
' Unique the values
Forall v In sourceList
uniqueList( Cstr( v ) ) = v

End Forall 'v in sourceList

Redim returnArray( 0 To Elements( uniqueList ) -1 )
' Set the
return array to be zero based

'Turn the values into an array
count% = 0
Forall u In uniqueList
returnArray( count% ) = u
count% = count% + 1

End Forall 'u In uniqueList

Unique = returnArray

End If 'isscalar


Exit Function
errorHandle:
Error Err, "[TextLib] [Unique] (" & Cstr(
Erl ) & ")" & Chr$(13) & Error$
Exit Function

End Function

Equivalente @Elements

Function Elements( values As Variant) As Integer
On Error Goto errorHandle
Elements = 0

' Check to see we have more than one value
If Isscalar( values ) Then
Elements = 1

Else 'Non scalar value
Forall v In values
Elements = Elements + 1
End Forall

End If 'isScalar

Exit Function

errorHandle:
Error Err, "[TextLib] [Elements] (" & Cstr
( Erl ) & ")" & Chr$(13) & Error$
Exit Function

End Function

ProperCase

Function ProperCaseEvaluate(sParam As String) As String
On Error Goto Erro

Dim vProperCase As Variant

vProperCase = Evaluate({@ProperCase("} & sParam & {")})

ProperCaseEvaluate = Cstr(vProperCase(0))

Exit Function
Erro:
ProperCaseEvaluate = ""
Exit Function
End Function
Function ProperCase(sParam As String) As String
On Error Goto Erro

Dim x As Integer

ProperCase = sParam

For x = 1 To Len(ProperCase)
If x = 1 Then
Mid$(ProperCase, 1, 1) = Ucase(Mid$(ProperCase, 1, 1))
Else
If Mid$( ProperCase, x - 1, 1 ) = " " Then
Mid$(ProperCase, x, 1) = Ucase$(Mid$( ProperCase, x, 1))
Else
Mid$(ProperCase, x, 1) = Lcase$(Mid$(ProperCase, x, 1))
End If
End If
Next

Exit Function
Erro:
ProperCase = ""
Exit Function
End Function

Converte caracteres na Web

Function ConverteCaracterWeb ( sTexto As String , iVer As Integer , iRep As Integer ) As String
%REM
Finalidade :
Retorna string de 2 duas maneiras

1. String no formato URL para com ou sem acento.
2. String com acento para sem acento ou no formato URL

Parametros :
1. sString = String que será convertida.
2. ver = Modelo atual da string.
3. rep = Modelo futuro da string.

Posições na Tabela :
1 - caracteres com acentos;
2 - caracteres com formato de URL;
3 - caracteres sem acentos;

OBS : Não há condições de se converter caracteres sem acentos para os outros formatos.

Exemplo :
1. Converter string com acento para formato URL e sem acento
x = ConvCaracter ( "Ação" , 1 , 2 ) // retorno : A%E7%E3o
x = ConvCaracter ( "Ação" , 1 , 3 ) // retorno : Acao
2. Converter string no formato de URL para acentos
x = ConvCaracter ( "A%E7%E3o" , 2 , 1 ) // retorno : Ação
x = ConvCaracter ( "A%E7%E3o" , 2 , 3 ) // retorno : Acao
%END REM

Dim sString As String
Dim iComp As Integer
Dim i As Integer
Dim j As Integer
Dim sEntradas() As String

' Atribuicao para evitar mudanca de valores por referencia
sString = sTexto

Redim Preserve sEntradas ( 1 To 71 , 1 To 3 )
sEntradas(1,1) = "á"
sEntradas(2,1) = "à"
sEntradas(3,1) = "ã"
sEntradas(4,1) = "â"
sEntradas(5,1) = "ä"
sEntradas(6,1) = "Á"
sEntradas(7,1) = "À"
sEntradas(8,1) = "Ã"
sEntradas(9,1) = "Â"
sEntradas(10,1) = "Ä"
sEntradas(11,1) = "è"
sEntradas(12,1) = "é"
sEntradas(13,1) = "ê"
sEntradas(14,1) = "ë"
sEntradas(15,1) = "È"
sEntradas(16,1) = "É"
sEntradas(17,1) = "Ê"
sEntradas(18,1) = "Ë"
sEntradas(19,1) = "í"
sEntradas(20,1) = "ì"
sEntradas(21,1) = "î"
sEntradas(22,1) = "ï"
sEntradas(23,1) = "Í"
sEntradas(24,1) = "Ì"
sEntradas(25,1) = "Î"
sEntradas(26,1) = "Ï"
sEntradas(27,1) = "ó"
sEntradas(28,1) = "ò"
sEntradas(29,1) = "õ"
sEntradas(30,1) = "ô"
sEntradas(31,1) = "ö"
sEntradas(32,1) = "Ó"
sEntradas(33,1) = "Ò"
sEntradas(34,1) = "Õ"
sEntradas(35,1) = "Ô"
sEntradas(36,1) = "Ö"
sEntradas(37,1) = "ú"
sEntradas(38,1) = "ù"
sEntradas(39,1) = "û"
sEntradas(40,1) = "ü"
sEntradas(41,1) = "Ú"
sEntradas(42,1) = "Ù"
sEntradas(43,1) = "Û"
sEntradas(44,1) = "Ü"
sEntradas(45,1) = "ç"
sEntradas(46,1) = "Ç"
sEntradas(47,1) = "ñ"
sEntradas(48,1) = "Ñ"
sEntradas(49,1) = " "
sEntradas(50,1) = "'"
sEntradas(51,1) = "#"
sEntradas(52,1) = "|"
sEntradas(53,1) = ","
sEntradas(54,1) = "("
sEntradas(55,1) = ")"
sEntradas(56,1) = "["
sEntradas(57,1) = "]"
sEntradas(58,1) = "{"
sEntradas(59,1) = "}"
sEntradas(60,1) = "<" sEntradas(61,1) = ">"
sEntradas(62,1) = Chr(13)
sEntradas(63,1) = Chr(10)
sEntradas(64,1) = "?"
sEntradas(65,1) = "!"
sEntradas(66,1) = ":"
sEntradas(67,1) = "%"
sEntradas(68,1) = "º"
sEntradas(69,1) = "/"
sEntradas(70,1) = "\"
sEntradas(71,1) = {"}

sEntradas(1,2) = "%E1"
sEntradas(2,2) = "%E0"
sEntradas(3,2) = "%E3"
sEntradas(4,2) = "%E2"
sEntradas(5,2) = "%E4"
sEntradas(6,2) = "%C1"
sEntradas(7,2) = "%C0"
sEntradas(8,2) = "%C3"
sEntradas(9,2) = "%C2"
sEntradas(10,2) = "%C4"
sEntradas(11,2) = "%E8"
sEntradas(12,2) = "%E9"
sEntradas(13,2) = "%EA"
sEntradas(14,2) = "%EB"
sEntradas(15,2) = "%C8"
sEntradas(16,2) = "%C9"
sEntradas(17,2) = "%CA"
sEntradas(18,2) = "%CB"
sEntradas(19,2) = "%ED"
sEntradas(20,2) = "%EC"
sEntradas(21,2) = "%EE"
sEntradas(22,2) = "%EF"
sEntradas(23,2) = "%CD"
sEntradas(24,2) = "%CC"
sEntradas(25,2) = "%CE"
sEntradas(26,2) = "%CF"
sEntradas(27,2) = "%F3"
sEntradas(28,2) = "%F2"
sEntradas(29,2) = "%F5"
sEntradas(30,2) = "%F4"
sEntradas(31,2) = "%F6"
sEntradas(32,2) = "%D3"
sEntradas(33,2) = "%D2"
sEntradas(34,2) = "%D5"
sEntradas(35,2) = "%D4"
sEntradas(36,2) = "%D6"
sEntradas(37,2) = "%FA"
sEntradas(38,2) = "%F9"
sEntradas(39,2) = "%FB"
sEntradas(40,2) = "%FC"
sEntradas(41,2) = "%DA"
sEntradas(42,2) = "%D9"
sEntradas(43,2) = "%DB"
sEntradas(44,2) = "%DC"
sEntradas(45,2) = "%E7"
sEntradas(46,2) = "%C7"
sEntradas(47,2) = "%F1"
sEntradas(48,2) = "%D1"
sEntradas(49,2) = "%20"
sEntradas(50,2) = "%27"
sEntradas(51,2) = "%23"
sEntradas(52,2) = "%7C"
sEntradas(53,2) = "%2C"
sEntradas(54,2) = "%28"
sEntradas(55,2) = "%29"
sEntradas(56,2) = "%5B"
sEntradas(57,2) = "%5D"
sEntradas(58,2) = "%7B"
sEntradas(59,2) = "%7D"
sEntradas(60,2) = "%3C"
sEntradas(61,2) = "%3E"
sEntradas(62,2) = "%0D"
sEntradas(63,2) = "%0A"
sEntradas(64,2) = "%3F"
sEntradas(65,2) = "%21"
sEntradas(66,2) = "%3A"
sEntradas(67,2) = "%25"
sEntradas(68,2) = "%BA"
sEntradas(69,2) = "%2F"
sEntradas(70,2) = "%5C"
sEntradas(71,2) = "%22"

sEntradas(1,3) = "a"
sEntradas(2,3) = "a"
sEntradas(3,3) = "a"
sEntradas(4,3) = "a"
sEntradas(5,3) = "a"
sEntradas(6,3) = "A"
sEntradas(7,3) = "A"
sEntradas(8,3) = "A"
sEntradas(9,3) = "A"
sEntradas(10,3) = "A"
sEntradas(11,3) = "e"
sEntradas(12,3) = "e"
sEntradas(13,3) = "e"
sEntradas(14,3) = "e"
sEntradas(15,3) = "E"
sEntradas(16,3) = "E"
sEntradas(17,3) = "E"
sEntradas(18,3) = "E"
sEntradas(19,3) = "i"
sEntradas(20,3) = "i"
sEntradas(21,3) = "i"
sEntradas(22,3) = "i"
sEntradas(23,3) = "I"
sEntradas(24,3) = "I"
sEntradas(25,3) = "I"
sEntradas(26,3) = "I"
sEntradas(27,3) = "o"
sEntradas(28,3) = "o"
sEntradas(29,3) = "o"
sEntradas(30,3) = "o"
sEntradas(31,3) = "o"
sEntradas(32,3) = "O"
sEntradas(33,3) = "O"
sEntradas(34,3) = "O"
sEntradas(35,3) = "O"
sEntradas(36,3) = "O"
sEntradas(37,3) = "u"
sEntradas(38,3) = "u"
sEntradas(39,3) = "u"
sEntradas(40,3) = "u"
sEntradas(41,3) = "U"
sEntradas(42,3) = "U"
sEntradas(43,3) = "U"
sEntradas(44,3) = "U"
sEntradas(45,3) = "c"
sEntradas(46,3) = "C"
sEntradas(47,3) = "n"
sEntradas(48,3) = "N"
sEntradas(49,3) = " "
sEntradas(50,3) = " "
sEntradas(51,3) = "#"
sEntradas(52,3) = "|"
sEntradas(53,3) = ","
sEntradas(54,3) = "("
sEntradas(55,3) = ")"
sEntradas(56,3) = "["
sEntradas(57,3) = "]"
sEntradas(58,3) = "{"
sEntradas(59,3) = "}"
sEntradas(60,3) = "<" sEntradas(61,3) = ">"
sEntradas(62,3) = Chr(13) & Chr(10)
sEntradas(63,3) = ""
sEntradas(64,3) = "?"
sEntradas(65,3) = "!"
sEntradas(66,3) = ":"
sEntradas(67,3) = "%"
sEntradas(68,3) = "o."
sEntradas(69,3) = "/"
sEntradas(70,3) = "\"
sEntradas(71,3) = {"}

If iVer > 2 Or iRep > 3 Or iVer = iRep Then
ConverteCaracterWeb = sString
Exit Function
End If

' Quantidade de caracteres a serem substituidos na string
iComp = 1
If (iVer = 2) Then iComp = 3

' Percorre a string desejada
For i = 0 To Len(sTexto)
' Percorre a tabela de URLs
For j = 0 To Ubound(sEntradas)-1
If sEntradas(j+1, iVer) = Mid$(sTexto, i+1, iComp) Then
' Substitui os caracteres na string
sString = SubstituiString(sString, sEntradas(j+1, iVer), sEntradas(j+1, iRep))
Exit For
End If
Next
Next

ConverteCaracterWeb = sString

End Function

Calcular os dias úteis entre as datas

Function CalculaDiasUteis(DtInicio, DtFim As NotesDateTime) As Integer
' ===> Objetivo:
' ===> Calcular os dias úteis entre as datas

' Parâmetros
' DtInicio = Data inicial
' DtIFim = Data termino

' Retorno => Total de dias úteis, excluindo os feriados entre as datas

'' Msgbox "Data Termino: " & dtFim.DateOnly
'' Msgbox "Data Inicio: " & DtInicio.DateOnly

Dim dc As NotesDocumentCollection
Dim strdt As String
Dim view As NotesView
Dim session As New NotesSession
Set db = session.CurrentDatabase
Set view = db.GetView("vwFeriados")

' Calcula a diferenca total entre as datas
dif = DtFim.TimeDifference( DtInicio )
difemdias = (dif / 86400) + 1



CalculaDiasUteis = 0
z=0
y=difemdias
diasUteis =0
dia = ""

Do Until (z = y)
If z = 0 Then
Call DtInicio.AdjustDay(0)
Else
Call DtInicio.AdjustDay(1)
End If

' Pegando o dia da semana
wd% = Weekday(DtInicio.dateonly)

' se data diferente de sábado e domingo
If (wd% <> 1 And wd% <> 7) Then
diasUteis = diasUteis + 1
End If

' string da data
strdt = Format(DtInicio.dateonly,"DD/MM/YYYY" )

' Procurando na visão de Feriados para ver se a data existe lá também
Set dc = view.GetAllDocumentsByKey(strdt, True)

' se achou algum feriado
If dc.count > 0 Then
' diminui o dia util
diasUteis = diasUteis - 1
' Msgbox "Dia Úteis sem o feriado: " & diasUteis
End If

z=z+1
Loop
CalculaDiasUteis = diasUteis

Exit Function

End Function

Incrementar dias uteis a partir de uma data inicial

Function IncrementaDiasUteis(DataInicial As NotesDateTime, Dias As Integer) As String
' ===> Objetivo:
' ===> Incrementar dias uteis a partir de uma data inicial

' Parâmetros
' DataInicial = Data inicial
' Dias = Dias uteis

' Retorno => Data incrementada dos dias uteis
On Error Goto trataerro

Dim dc As NotesDocumentCollection
Dim strdt As String
Dim view As NotesView
Dim session As New NotesSession
Set db = session.CurrentDatabase
Set view = db.GetView("vwFeriados")

Do
Call DataInicial.AdjustDay(1)

' Pegando o dia da semana
wd% = Weekday(DataInicial.dateonly)

' se data diferente de sábado e domingo
If (wd% <> 1 And wd% <> 7) Then
Dias = Dias - 1
End If

Loop While Dias > 1

IncrementaDiasUteis = Format(Cstr(DataInicial.DateOnly), "dd/mm/yyyy")
Exit Function
End Function

Criar o campo do tipo Lista

Sub CriaCampoLista(docA,docB As NotesDocument,CampoA,CampoB, Tipo As String)
' ===> Objetivo:
' ===> Criar o campo do tipo Lista
' Parâmetros
' docA = Documento de origem
' docB = Documento destino, onde deseja criar o CampoB
' CampoA = Nome do campo de origem
' CampoB = Nome do campo destino
' Tipo de Campo (Autor, Leitor ou nada)

On Error Goto trataerro

If docA.HasItem(CampoA) Then

Set item = docA.GetFirstItem(CampoA)

Dim Vet() As String
i = 0
Forall v In item.Values
Redim Preserve Vet(i)

' setando o vetor
Vet(i) = Cstr(v)

i = i + 1
End Forall

' Criando o campo no documento destino
Call CriaCampo(docB,CampoB,Vet,Tipo)
End If

Exit Sub

End Sub

Sub AlteraCampo(docD As NotesDocument, Campo,ValorA,ValorN,Tipo As String)
' ===> Objetivo:
' ===> Altera um campo caso exista um determinado valor (ValorA),
' substituindo pelo novo valor (ValorN)

' Parâmetros
' docD = Documento
' Campo = Nome do Campo que deseja recriar
' ValorA= Valor que deseja excluir no "Campo"
' ValorN= Valor que deseja incluir no "Campo"
' Tipo = Tipo do Campo, podendo ser AUTHORS (Autor),
' READERS (Leitor) ou sem especificação


' verificando se existe o campo
If docD.HasItem(Campo) Then

' setando o campo
Set item = docD.GetFirstItem(Campo)

' se encontrou o valorA, coloca o novo valorN
If item.Contains( ValorA ) Then
Dim vet() As String
j = 0
x = 0
' recriando os valores do campos carregando no vetor
Forall v In item.values
' coloca somente os valores # do ValorA
If (v <> ValorA) And (v <> "") Then
Redim Preserve vet(x)
vet(x) = v
x = x + 1
End If
End Forall

Redim Preserve vet(x)
' colocando o novo valorN no vetor
vet(x) = ValorN

' Remove o campo
Call item.Remove

' Cria o campo
' Se Tipo Autor
If Tipo = "Autor" Then
Set Item = New NotesItem(docD, Campo, vet, AUTHORS)
End If

' Se Tipo Leitor
If Tipo = "Leitor" Then
Set Item = New NotesItem(docD, Campo, vet, READERS)
End If

' Sem Tipo
If Tipo = "" Then
Set Item = New NotesItem(docD, Campo, vet)
End If

item.IsSummary = True

End If
End If
End Sub

Recria o grupo e insere o usuario no Grupo do Names

Sub RecriarGrupo(Grupo As String)
' ===> Objetivo:
' ===> Recria o grupo e insere o usuario no Grupo do Names

' Parâmetros
' Grupo = Nome do Grupo que deseja recriar

Dim docGrupo As notesdocument
Dim vw As notesview
Dim item As NotesItem
Dim session As New NotesSession
Dim books As Variant

books = session.AddressBooks
Forall b In books
Call b.Open( "", "" )
' visao com todos os grupos na names
Set vw=b.getview("($VIMGroups)")

' pegando o grupo atraves da chave = nome do grupo (Exemplo: "Grupo00000076")
Set docGrupo = vw.getdocumentbykey(Grupo)

If Not docGrupo Is Nothing Then
Set item = docGrupo.ReplaceItemValue( "members", "")
Call docGrupo.save(True,False)
End If

End Forall

Exit Sub

End Sub

Remove o usuario do Grupo do Names

Sub RemoverGrupo(docG As NotesDocument, Grupo As String)
' ===> Objetivo:
' ===> Remove o usuario do Grupo do Names

' Parâmetros
' docG = Documento
' Grupo = Nome do Grupo que onde deseja remover o usuario

Dim docGrupo As notesdocument
Dim vw As notesview
Dim item As NotesItem
Dim session As New NotesSession
Dim books As Variant

books = session.AddressBooks
Forall b In books
Call b.Open( "", "" )
Set vw=b.getview("($VIMGroups)")
Set docGrupo = vw.getdocumentbykey(Grupo)
If Not docGrupo Is Nothing Then

Set item = docGrupo.getfirstitem("members") 'pego item com membros do grupo grupos(i)
If item.Contains(docG.login(0)) Then 'vejo se usuario existe, para remover
cont% = 0
Forall x In docGrupo.members 'varro membros
If (x <> docG.login(0)) Then 'se não é usuario em questao, usuario deve permanecer
'guarda membro no vet de membros que devem permanecer
Redim Preserve vetMembrosQueFicam(0 To cont%)
vetMembrosQueFicam(cont%) = x
cont% = cont% + 1
End If
End Forall
docGrupo.members = vetMembrosQueFicam 'seto no campo membros, só os que devem permanecer
Call docGrupo.save(True,False) 'salvo doc de grupo
End If
End If
End Forall

Exit Sub

End Sub

Inserir o usuario no Grupo do Names

Sub InserirGrupo(docG As NotesDocument, Grupo As String)
' ===> Objetivo:
' ===> Inserir o usuario no Grupo do Names

' Parâmetros
' docG = Documento
' Grupo = Nome do Grupo que onde deseja inserir o usuario


Dim docGrupo As notesdocument
Dim vw As notesview
Dim item As NotesItem
Dim session As New NotesSession
Dim books As Variant

books = session.AddressBooks
Forall b In books
Call b.Open( "", "" )
' visao com todos os grupos na names
Set vw=b.getview("($VIMGroups)")

' pegando o grupo atraves da chave = nome do grupo (Exemplo: "Grupo00000076")
Set docGrupo = vw.getdocumentbykey(Grupo)

If Not docGrupo Is Nothing Then
Set item = docGrupo.getfirstitem("members")

' se nao existe o login do usuario no grupo, insere
If Not item.Contains(docG.login(0)) Then

' append do login do usuario
item.AppendToTextList(docG.login(0))

'' Call docGrupo.ComputeWithForm( True, False )

' salva
Call docGrupo.save(True,False)
End If

End If
End Forall

Exit Sub

End Sub

Cria um campo, caso existe remove e cria novamente

Sub CriaCampo(docD As NotesDocument, Campo,Valor,Tipo As String)
' ===> Objetivo:
' ===> Cria um campo, caso existe remove e cria novamente

Dim C As String
C = Campo

' Parâmetros
' docD = Documento
' Campo = Nome do Campo que deseja criar
' Valor = Valor que deseja incluir no "Campo"
' Tipo = Tipo do Campo, podendo ser AUTHORS (Autor),
' READERS (Leitor) ou sem especificação

' Excluindo Campo
Call ExcluiCampo (docD, C)

' Cria o campo
' Se Tipo Autor
If Tipo = "Autor" Then
Set Item = New NotesItem(docD, Campo, Valor, AUTHORS)
End If

' Se Tipo Leitor
If Tipo = "Leitor" Then
Set Item = New NotesItem(docD, Campo, Valor, READERS)
End If

' Sem tipo
If Tipo = "" Then
Set Item = New NotesItem(docD, Campo, Valor)
End If
Item.IsSummary = True


End Sub

ltera um campo caso exista um determinado valor (ValorA), substituindo pelo novo valor (ValorN)

Sub AlteraCampo(docD As NotesDocument, Campo,ValorA,ValorN,Tipo As String)
' ===> Objetivo:
' ===> Altera um campo caso exista um determinado valor (ValorA),
' substituindo pelo novo valor (ValorN)

' Parâmetros
' docD = Documento
' Campo = Nome do Campo que deseja recriar
' ValorA= Valor que deseja excluir no "Campo"
' ValorN= Valor que deseja incluir no "Campo"
' Tipo = Tipo do Campo, podendo ser AUTHORS (Autor),
' READERS (Leitor) ou sem especificação


' verificando se existe o campo
If docD.HasItem(Campo) Then

' setando o campo
Set item = docD.GetFirstItem(Campo)

' se encontrou o valorA, coloca o novo valorN
If item.Contains( ValorA ) Then
Dim vet() As String
j = 0
x = 0
' recriando os valores do campos carregando no vetor
Forall v In item.values
' coloca somente os valores # do ValorA
If (v <> ValorA) And (v <> "") Then
Redim Preserve vet(x)
vet(x) = v
x = x + 1
End If
End Forall

Redim Preserve vet(x)
' colocando o novo valorN no vetor
vet(x) = ValorN

' Remove o campo
Call item.Remove

' Cria o campo
' Se Tipo Autor
If Tipo = "Autor" Then
Set Item = New NotesItem(docD, Campo, vet, AUTHORS)
End If

' Se Tipo Leitor
If Tipo = "Leitor" Then
Set Item = New NotesItem(docD, Campo, vet, READERS)
End If

' Sem Tipo
If Tipo = "" Then
Set Item = New NotesItem(docD, Campo, vet)
End If

item.IsSummary = True

End If
End If
End Sub

Recria um campo caso exista um determinado valor (ValorA), substituindo pelo novo valor (ValorN)

Sub RecriaCampo(docD As NotesDocument, Campo,ValorA,ValorN,Tipo As String)
' ===> Objetivo:
' ===> Recria um campo caso exista um determinado valor (ValorA),
' substituindo pelo novo valor (ValorN)

' Parâmetros
' docD = Documento
' Campo = Nome do Campo que deseja recriar
' ValorA= Valor que deseja excluir no "Campo"
' ValorN= Valor que deseja incluir no "Campo"
' Tipo = Tipo do Campo, podendo ser AUTHORS (Autor),
' READERS (Leitor) ou sem especificação


' verificando se existe o campo
If docD.HasItem(Campo) Then

' setando o campo
Set item = docD.GetFirstItem( Campo )

' se existe valor antigo
If item.Contains( ValorA ) Then
' remove o campo
Call item.Remove

' Cria o campo
' Se Tipo Autor
If Tipo = "Autor" Then
Set Item = New NotesItem(docD, Campo, ValorN, AUTHORS)
End If

' Se Tipo Leitor
If Tipo = "Leitor" Then
Set Item = New NotesItem(docD, Campo, ValorN, READERS)
End If

' Sem tipo
If Tipo = "" Then
Set Item = New NotesItem(docD, Campo, ValorN)
End If
Item.IsSummary = True


End If
End If
End Sub

Inclui um determinado valor no campo, caso não exista

Sub AppendCampo(docD As NotesDocument, Campo,Valor As String)
' ===> Objetivo:
' ===> Inclui um determinado valor no campo, caso não exista

' Parâmetros
' docD = Documento
' Campo = Nome do Campo que deseja incluir
' Valor = Valor que deseja incluir em "Campo"

' verificando se existe o campo
If docD.HasItem(Campo) Then

' setando o campo
Set item = docD.GetFirstItem( Campo )

' se não existe o valor, insere...
If Not item.Contains( Valor ) Then
Call item.AppendToTextList(Valor)
End If

End If

End Sub

Exclui um campo

Sub ExcluiCampo(docD As NotesDocument, Campo As String)
' ===> Objetivo:
' ===> Exclui um campo

' Parâmetros
' docD = Documento
' Campo = Nome do Campo que deseja excluir

' Verificando se existe o campo
If docD.HasItem(Campo) Then
Set item = docD.GetFirstItem( Campo )

' remove o campo
Call item.Remove
End If

End Sub

Criar campos autores

Sub CriaCampoAutores(doc As NotesDocument,usuario As String)
' se existe autores
If doc.HasItem("autores") Then
' setando
Set itemPendente = doc.GetFirstItem( "autores" )
' se nao contem, inclui
If Not itemPendente.Contains( usuario ) Then
Call itemPendente.AppendToTextList(usuario)
End If
Else
' criando o item autores
Set itemPendente = New NotesItem(doc, "autores",usuario,AUTHORS)
itemPendente.IsSummary = True
End If

End Sub

Rotina simples para envio de e-mail

Sub EnviarMail(Destinatario As String, Titulo As String, Mensagem As String,doc As NotesDocument)

Dim s As New NotesSession
Dim Mail As NotesDocument
Dim rtitem As Variant

Set Mail = Session.CurrentDatabase.CreateDocument
Mail.Form = "Memo"
Mail.Subject = Titulo
Mail.SendTo = Destinatario

Set rtitem = New NotesRichTextItem( Mail, "Body" )

Call rtitem.AppendText(Mensagem)
Call rtitem.AddNewLine( 2 )
Call rtitem.AppendText("Clique no DocLink para acessar o documento -> ")
Call rtitem.AppendDocLink( Doc, db.Title )
Call Mail.Send(True)


End Sub

Verifica se o usuário possui a Role passada como parametro

Function UsuarioPossuiRole(Role As String, Usuario As String) As Variant

Dim session As New NotesSession
Dim db As NotesDatabase
Dim acl As NotesACL
Dim entry As NotesACLEntry
Set db = session.CurrentDatabase
Set acl = db.ACL
Set entry = acl.GetEntry( Usuario )
If Not entry Is Nothing Then
Forall r In entry.Roles
If r = Role Then
UsuarioPossuiRole = True
Exit Function
Else
UsuarioPossuiRole = False
End If
End Forall
Else
UsuarioPossuiRole = False
End If

End Function

Impressão de documentos selecionados na web

Sub Initialize

On Error Goto erro

Dim s As New Notessession
Dim doccontext As NotesDocument
Set doccontext = s.DocumentContext

'ex: query_string = "Openagente&id=123456;789456"

'Pegando os ids da URL
str_id = Fulltrim(Split(retornaParametro(doccontext.query_string(0), "id"),";") )

Forall x In str_id
Msgbox "valor de x = " & x
Print|iframe src="./0/| + x + |?OpenDocument" frameborder=0 marginheight=5% marginwidth=% width=100% height=100%>iframe|
End Forall


SAI:
Exit Sub
erro:
Print "Erro no initialize do agente agt_imprimir na linha " & Erl & " Do tipo" & Error
Resume SAI
End Sub


Function retornaParametro ( qry As String, param As String ) As String
'Função para retornar o parâmetro da querystring

Dim i,j As Integer
Dim result As String

i = Instr(1, qry, param)
result= ""

If i > 0 Then
j = Instr(i, qry, "&")
If j > 0 Then
result$ = Mid(qry, i + Len(param) + 1, (j - 1) - (i + Len(param)))
Else
result$ = Mid(qry, i + Len(param) + 1)
End If
End If

retornaParametro = result
End Function

Utlizada para tratar o subject do email recebido removendo tudo à esquesda

Function filtrasubject(versubject As String) As String
'//função utlizada para tratar o subject do email recebido removendo tudo à esquesda do ":"
'//alguns e-mails são recebidos com Re: FW: Enc:

On Error Goto ops

Dim i As Integer
Dim a As Integer
'//procuro ":" no subject
f = ":"

i = Instr(versubject,f)
'//se encontro ":" procuro até nao encontrar mais
While i > 0
a = i
'//procuro o proximo ":"
i = Instr(a+1,versubject,f)
Wend
If a > 0 Then
'//removo tudo antes dos ":"
filtrasubject = Trim(Right$(versubject,Len(versubject) - a))
Else
'//nao encontrou ":"- retorno o subnject inicial
filtrasubject = Trim(versubject)

End If

sai:
Exit Function
ops:

Msgbox "Erro na function filtrasubject na linha " & Erl & " do tipo:" & Error & Err
Resume sai
End Function

Enviar e-mail contendo HTML

Sub respautomatica(remetente As String,destinatario As String,strHTML As String)
'//Rotina utilizada para enviar e-mail contendo no corpo do e-mail codigo html

On Error Goto ops
Dim s As New NotesSession
Dim memo As New NotesDocument(s.CurrentDatabase)

Dim rtBody As NotesMIMEEntity
Dim rtHtml As NotesMIMEEntity
Dim strmHtml As NotesStream

Set rtBody = memo.CreateMIMEEntity
Set rtHtml = rtBody.CreateChildEntity
Set strmHtml = s.CreateStream
s.ConvertMIME = False ' Do not convert MIME to rich text

Call strmHtml.WriteText(strHTML) '//corpo do e-mail com codigo html
Call rtHtml.SetContentFromText( strmHtml ,"text/html;charset=iso-8859-1", ENC_NONE )

'//Criando o E-Mail
With memo
.Form = "Memo"
.Principal = remetente
' .SMTPOriginator = remetente
.From = remetente
.AltFrom = remetente
.SendTo = remetente
.SentBy = remetente
' .INetFrom = remetente
' .tmpDisplayFrom_Preview = remetente
' .tmpDisplaySentBy = remetente
'' .tmpDisplayReplyInfo = remetente
' .tmpDisplayFrom_NoLogo = remetente
.Subject = assunto
.SendTo = destinatario
.RecNoOutOfOffice = "1" 'Set it so out of office agents don't reply to the message
.SaveMessageOnSend = False
End With

Call memo.Send( False )
s.ConvertMIME = True

sai:
Exit Sub
ops:
Msgbox "Erro na função respautomatica na linha " & Erl & " do tipo:" & Error & Err
Resume sai
End Sub

verificar se o e-mail é um e-mail externo

Function emailexterno(verfrom As String) As Boolean
'//função para verificar se o e-mail é um e-mail externo

On Error Goto ops

Dim i As Integer

f = "@"
g = "."

emailexterno = False
'//verifico se existe @ no nome
i = Instr(verfrom,f)
'//se i >0 entao existe @
If i > 0 Then
'//se existir procuro um "." depois do @ - é obrigatório ter ponto depois do @ para o email ser externo
If Instr(i,verfrom,g) > i Then
emailexterno = True
End If
'//se nao existir retorno false
End If

sai:

Exit Function

ops:

Msgbox "Erro na function email externo na linha " & Erl & " do tipo:" & Error & Err
Resume sai

End Function

Extrair o endereço de e-mail

Function filtrafrom(verfrom As String) As String
'//função utlizada para extrair o endereço de e-mail
'//alguns e-mails são recebidos com "fulano"


On Error Goto ops

Dim i As Integer
'//procuro o label do email recebido
f = "<"
g = ">"

i = Instr(verfrom,f)
j = ( Instr(verfrom,g) -1)

'// se i > 0 entao existe label para o email
If i > 0 Then
If j > 0 Then
'//removo o label do endereco de correio
filtrafrom = Mid$(verfrom, i+1,j-i)
End If
Else

'// se nao existe label retorno o coreio recebido
filtrafrom = verfrom
End If



sai:

Exit Function

ops:

Msgbox "Erro na function filtrafrom na linha " & Erl & " do tipo:" & Error & Err
Resume sai

End Function

FullTrim Js

//++++++++++++++++++++++++++++++++++++++++++++
// Retira brancos de strings antes, depois e excessos do meio
//++++++++++++++++++++++++++++++++++++++++++++
function FullTrim(sStr)
{
var iI = 0;
var iJ = 0;
var iTam = 0;
var sAux = "";

// Verifica string vazia
iTam = sStr.length;
if(iTam==0) return(sStr);

// Localiza primeiro caracter nao espaco
for(iI=0; iI if(sStr.charAt(iI)!=' ') break;

// verifica se String so tinha espacos
if(iI >= iTam) return("");

// Localiza ultimo caracter nao espaco
for(iJ=iTam - 1; iJ>=0; iJ--)
if(sStr.charAt(iJ)!=' ') break;

// Retorna do primeiro ao ultimo nao espaco
// return(sStr.substring(iI,iJ+1));
// adiconado

sStr = sStr.substring(iI,iJ+1);
iTam = sStr.length;
iJ = 0;
for ( iI = 0 ; iI < iTam; iI++)
{
if (sStr.charAt(iI) == ' ') iJ++;
else iJ = 0;
if ( iJ > 1 )
{
sStr= sStr.substring(0,iI-1) + sStr.substring(iI,iTam ) ;
iI = iI -2;
iJ = 0;
}
} // end for
return(sStr);
}

Função para deixar uma array de maneira aleatória

//Função para deixar uma array de maneira aleatória
// Chamada: RandomizeArray( seuArray )

Sub RandomizeArray(ArrayIn As Variant)

Dim cnt As Long
Dim RandomIndex As Long
Dim tmp As Variant

'only if an array was passed
If VarType(ArrayIn) >= vbArray Then

'loop through the array elements in reverse
For cnt = UBound(ArrayIn) To LBound(ArrayIn) Step -1

'select a random array index
RandomIndex = Int((cnt - LBound(ArrayIn) + 1) * _
Rnd + LBound(ArrayIn))

'cnt represents one array member
'index, and RandomIndex represents
'another, so swap the data held in
'myarray(cnt) with that in myarray(RandomIndex)
tmp = ArrayIn(RandomIndex)
ArrayIn(RandomIndex) = ArrayIn(cnt)
ArrayIn(cnt) = tmp

Next

Else

'The passed argument was not an
'array; error handler goes here

End If

End Sub

Função para maximizar a janela ao abrir

function maxWindow(){
window.moveTo(0,0);
if (document.all){
top.window.resizeTo(screen.availWidth,screen.availHeight);
}else if (document.layers||document.getElementById){
if (top.window.outerHeight top.window.outerHeight = screen.availHeight;
top.window.outerWidth = screen.availWidth;
}
}
}

Renomear o nome da base notes

Dim s As New NotesSession
Dim dbCur As NotesDatabase
Set dbCur = s.CurrentDatabase
Dim sDirectoryPath As String
sDirectoryPath = Left( dbCur.FilePath, Len(dbCur.FilePath) - Len(dbCur.FileName) )




Function rename(dbase As NotesDatabase,newname As String)

'//seta o caminho da base a ser renomeada
fulldbase$ = dbase.FilePath

a = 1
Do
b=a
a = Instr(b+1,fulldbase$, "\")
Loop Until a = 0

fulldbpathwithoutnsf$ = Left$(fulldbase$,b)

'//perdendo o indice da base
Set dbase = Nothing
'//renomeando a base
Name fulldbase$ As fulldbpathwithoutnsf$ + newname + ".nsf"

End Function

Funções para trabalhar com listas

Function RemoveFromList (Value As Variant, ValueList As Variant)
Dim tmpValueList() As String
x = 0
Redim Preserve tmpValueList(x)
Forall vals In ValueList
If Not Value = vals Then
Redim Preserve tmpValueList(x)
tmpValueList(x) = vals
x = x + 1
End If
End Forall
RemoveValueFromList = tmpValueList
End Function

Function AddToList (Value As Variant, ValueList As Variant)
Dim tmpValueList As Variant
' Load the array element by element so that the datatype is preserved
Redim tmpValueList(Ubound(ValueList))
For i = 0 To Ubound(ValueList)
tmpValueList(i) = ValueList(i)
Next
' Determine if we are dealing with a new list, if absolutely no
values in the first entry, then add new value to 0
If Ubound(tmpValueList) = 0 And Cstr(tmpValueList(0)) = "" Then
x = 0
Else
x = Ubound(tmpValueList) + 1
End If
Redim Preserve tmpValueList(x)
tmpValueList(x) = Value
AddToList = tmpValueList
End Function

Function RemoveItemFromList (intItem As Integer, ValueList As Variant)
' *** intItem should be passed in zero based as well as ValueList
Dim tmpValueList() As Variant
Dim intItemCnt As Integer
' Init the temporary list
Redim tmpValueList(0)
intItemCnt = 0
For x = 0 To Ubound(ValueList)
If Not intItem = x Then 'Not equal, we must
keep this one in the list
Redim Preserve tmpValueList(intItemCnt)
tmpValueList(intItemCnt) = ValueList(x)
intItemCnt = intItemCnt + 1 ' Count the
items we have kept so that we can adjust the array properly
End If
Next
RemoveItemFromList = tmpValueList

End Function

Function EntryInList (Value As Variant, ValueList As Variant) As Integer
' This will return a 1 based value if the position in the list
EntryInList = 0
i = 1
Forall Entries In ValueList
If Entries = Value Then
EntryInList = i
Exit Function
End If
i = i + 1
End Forall
End Function

Function RemoveRangeFromList (intStartPos As Integer, intEndPos As Integer,
varInput As Variant) As Variant
Dim tmpList() As Variant
Dim intPosCnt As Integer
intPosCnt = 0
For i = 0 To Ubound(varInput)
If i < intStartPos Or i > intEndPos Then
Redim Preserve tmpList(intPosCnt)
tmpList(intPosCnt) = varInput(i)
intPosCnt = intPosCnt + 1
End If
Next
RemoveRangeFromList = tmpList
End Function

URL: http://searchdomino.techtarget.com/tip/0,289483,sid4_gci490542,00.html

Seleciona no checkbox/radio o valor passado como parametro

function checkOption(radioName, newValue){
var els = document.getElementsByName(radioName);
if (els.value){
if (els.value == newValue){
els.checked = true;
}
}
for (var i = 0; i < els.length; i++){
if (els[i].value == newValue)
els[i].checked = true;
}
}

Seleciona no combobox o valor passado como parametro

function selectOption(selectName, value) {
var select = document.getElementById(selectName);
var options = select.options;
for (var i = 0; i < options.length; i++) {
var option = options.item(i);
if(option.value == value) {
option.selected = true;
}
}
}

Seleciona todos os valores do ListBox

function selectAllListBox(formName, filterId) {
var check = document.getElementById("filter_" + filterId + "_all");
var select = document.getElementById("filter_" + filterId);
var selected = true;
var options = select.options;
var i = 0;
while (i < options.length && selected) {
var option = options.item(i);
selected = option.selected;
i++;
}
check.checked = selected;
}

Seleciona todos os valores do CheckBox

function selectAllCheckBox( filterId) {
var check = document.getElementById("filter_" + filterId + "_all");
var select = document.getElementById("filter_" + filterId);
var options = select.options;
for(var i = 0; i < options.length; i++) {
var option = options.item(i);
option.selected = check.checked;
}
}

Adiciona valor no combo e ordena

function addToComboboxInOrder(select, value, text) {
var option = document.createElement("option");
option.value = value;
option.innerHTML = text;
for (var i = 0; select.options.length; i++){
if (select.options[i].text.toLowerCase() > text.toLowerCase()){
select.insertBefore(option, select.options[i]);
return;
}
}
select.appendChild(option);
}

Adiciona valor no combo para seleção

function addToCombobox(select, value, text) {
var option = document.createElement("option");
option.value = value;
select.appendChild(option);
var _text = document.createTextNode(text);
option.appendChild(_text);
}

Verifica se existe o valor passado como parametro no combo

function hasItemCombobox(select, value) {
for (var i = 0; i < select.options.length; i++){
if (select.options[i].value == value){
return true;
}
}
return false;
}

Limpa combobox

function clearCombobox(select) {
select.options.length = 0;
select.disabled = false;
}

Função Split ( StringToArray )

Function StringToArray(textstr As String, delimiter As String) As Variant
' count is the counter for the number of array elements
Dim count As Integer
Dim ending As Integer
count = 0
'placeholder is used to mark the beginning of the string to be split
Dim placeholder As Integer
Dim splitstr As String
placeholder = 1
splitstr$ = delimiter
' txt$() is the array that will be returned
Dim txt$()
Redim txt$(0)
ending = Instr(placeholder, textstr, splitstr$)
'if ending = 0 then text does not contain a ; and the entire value should be returned
If ending = 0 Then
txt$(0) = textstr
End If
' do this until no more delimiters are found
While ending <> 0 And ending < Len(textstr) Redim Preserve txt$(count) txt$(count) = Mid$(textstr, placeholder, ending - placeholder ) count = count + 1 placeholder = ending + Len(splitstr$) ending = Instr(placeholder, textstr, splitstr$) If ending = 0 Then Redim Preserve txt$(count) txt$(count) = Mid$(textstr, placeholder, (Len(textstr)-placeholder) +1 ) End If Wend StringToArray = txt$ End Function ############################################################ ex.:call fcn_split(doc.campoA(0) + ";" + doc.campoB(0)) function fcn_split(chave As String) On Error Goto ops Dim formula As String Dim array As Variant '//gerando o array a partir da chave formula = {@Explode("} & chave & {";";")} array = Evaluate(formula) exit function #################################################### Function Split(sValue As String, sSeparador As String) As Variant '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 'Função Split(string, separador) -Transforma de uma String separada por um 'separador especifico em um Array de String do tipo Variant. ' Parâmetros: 'sValue(String) - Valores separados por um Caracter (Separador); 'sSeparador(String) - Separador que terá de ser encontrado na sValue 'Saída(Variant- Array ou String) - Se o método encontrar um separador na string, 'retornará um Array de String, senão retorna a String sem alterações. '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Dim aFile() As String Dim iCon As Integer Dim iPos As Integer Dim iPosIni As Integer Dim i As Integer iPos = Instr(sValue, sSeparador) If iPos = 0 Then Redim Preserve aFile(iPos+1) aFile(iPos) = sValue Split = aFile ' Split = sValue Else iPosIni = 1 While iPos <> 0
Redim Preserve aFile(iCon+1)
If IPos > iPosIni Then
aFile(iCon) = Mid$(sValue, iPosIni, iPos - iPosIni)
Else
aFile(iCon) = ""
End If

iPosIni = iPos+1
iPos = Instr(iPosIni, sValue, sSeparador)
iCon = iCon + 1
Wend

If iPosIni <= Len(sValue) Then Redim Preserve aFile(iCon+1) aFile(iCon) = Mid$(sValue, iPosIni, (Len(sValue) - iPosIni)+1) End If If Right$(sValue,1) <> sSeparador Then Redim Preserve aFile ( Ubound(aFile)-1)
Split = aFile
End If

End Function

Função para limpar campos do tipo combo ou text

function limpaCampo(campo){
var oList = document.getElementById(campo);
if ( oList.type =="select-one" || oList.type=="select-multiple" ) {
for (var i = oList.options.length - 1; i >= 0; i--){
oList.options[i] = null;
}
oList.selectedIndex = -1;
}else {
oList.value = ''; // campo texto
}
}

Ler contéudo dos campos no arquivo XML

ex.:
var descricao = pegaValor(item.getElementsByTagName("descricao")[0]);

function pegaValor(no){
if(no.childNodes.length>0){
return no.firstChild.nodeValue;
}else{
try{
return no.nodeValue;
}catch(e){
return " ";
}
}
}

OU:


function getElementText( xml, tagName ){
return xml.getElementsByTagName(tagName).item(0).text;
}

function getNodeValue(obj,tag){
return obj.getElementsByTagName(tag)[0].firstChild.nodeValue;
}

Preview em um documento para impressão

function printpreview(){
var OLECMDID = 7;
var PROMPT = 1;
var WebBrowser = '';
document.body.insertAdjacentHTML('beforeBegin', WebBrowser);
WebBrowser1.ExecWB(OLECMDID, PROMPT);
WebBrowser1.outerHTML = "";
}

Função tulizada para criacao do objeto XMLHTTP

function getXmlHttp() {
try{
xmlhttp = new XMLHttpRequest();
}catch (ee){
try{
xmlhttp= new ActiveXObject("Msxml2.XMLHttp");
}catch(e){
try{
xmlhttp = new ActiveXObject("Microsoft.XMLHTTP");
}catch(E){
xmlhttp=false;
}
}
}
return xmlhttp;
}

critica para qualquer tipo de campo

//o parametro flgCriticaHidden é opcional se quiser criticar mesmo que campo seja hidden

function isCampoPreenchido(objCampo, msgErro, flgCriticaHidden){

var flgOK = true;

//só critica se o objCampo existir no document
if(!objCampo){
return true;
}

//pega tipo do objCampo ou, caso tenha mais de um, do primeito elemnto do objCampo
var tipo = (objCampo.type ? objCampo.type : objCampo[0].type);

if(tipo=='hidden'){
//as vezes, é interessante que se o campo for hidden eu não critique,
//nesse caso é só passar false para flgCriticaHidden ou não passar
//nada, mas se eu quiser forçar a criticar é so passar o parâmetro
//como no caso de querer criticar campos de tabelas dinâmicas
if(flgCriticaHidden){ //se recebeu parametro e recebeu true
//se foi passado flag indicando que deve criticar HIDDEN
if(Trim(objCampo.value) == '') flgOK = false;
}else{
//só critica se o objCampo não for hidden
return true;
}
}else if(tipo=='select-one'){
//se o primeiro elemento da combo está selecionado, não está preenchido corretamente
if(objCampo.selectedIndex==0) flgOK = false;
}else if(tipo=='select-multiple'){
//inicialmente assumo que nenhum elemento do listbox está selecionado
flgOK = false;
for(var i=0; i //se algum foi selecionado considero preenchimento ok
if(objCampo.options[i].selected) flgOK = true;
}
}else if( (tipo=='radio') || (tipo=='checkbox') ){
//inicialmente assumo que nenhum elemento do checkbox ou radiobutton está checado
flgOK = false;
if(objCampo.length){
//caso exista mais de um checkbox/radio com esse nome, varro todos
for(var i=0; i //se algum foi selecionado considero preenchimento ok
if(objCampo[i].checked) flgOK = true;
}
}else if(objCampo.checked){
//caso só exista um checkbox/radio com esse nome, verifico se ele está checado
flgOK = true;
}
}else{ //text, textarea, file, ...
if(Trim(objCampo.value) == '') flgOK = false;
}

if(flgOK){ //se objCampo esta preenchido ok
return true;
}else{
if((msgErro)&&(msgErro!=null)&&(Trim(msgErro)!='')){
//exibe msgErro e põe foco no objCampo só se
//foi passada alguma msgErro com conteudo
alert(msgErro);
if(tipo!='hidden'){
if(objCampo.type)
objCampo.focus();
else
objCampo[0].focus();
}
}

return false; //objCampo não preenchido ok
}
}

Função para colocar o doc. pai em modo de leitura.

function LeituraDocPai(){
var f = window.opener.document.forms;
if(!f.elements){
var currHref = (window.opener.document.location.href);
var newHref = currHref.substring(0, currHref.indexOf("?"))+"?OpenDocument";
window.opener.location.href = newHref;
}
}

Função para voltar o doc em modo de leitura.

function Leitura(){
var f = document.forms;
if(!f.elements){
var currHref = (document.location.href);
var newHref = currHref.substring(0,currHref.indexOf("?"))+"?OpenDocument";
window.location.href = newHref;
}
}

Retorna a data atual formatada com dd/mm/aaaa

function dataatual() {
var hoje = new Date()
var dia = hoje.getDate()
var mes = hoje.getMonth()
mes = mes+1
var ano = hoje.getFullYear()
if (dia < 10)
dia = '0' + dia
if (mes < 10)
mes = '0' + mes

var dtatual = dia+'/'+mes+'/'+ano
return (dtatual);
};

COLLAPSE & EXPAND

function ExpColCateg(docnumber, view){

var form = document.forms[0].action.substring(0, document.forms[0].action.indexOf("?") + 9);
var url = window.location.href;
var strlen = url.length;
var before = url.indexOf("DocNum=");
var result = url.substring(before + 7 , strlen);
aux = "IMG" + docnumber;

// SE CLICAR EM EXPAND
if(url.indexOf("ExpandView") != -1){
window.open( form + "&Collapse="+ docnumber + "&View="+view +"&DocNum=" + docnumber , "_self") ;
}else{
// SE CLICAR EM COLLAPSE
if(url.indexOf("CollapseView") != -1){
window.open( form + "&Expand="+ docnumber + "&View=" +view +"&DocNum=" + docnumber , "_self") ;
}else{
// SE A ÚLTIMA AÇÃO FOR UM EXPAND
if(url.indexOf("Expand") != -1){
// SE O ÚLTIMO NÚMERO É O NÜMERO ATUAL
if(result == docnumber){
window.open( form + "&Collapse="+ docnumber + "&View="+view +"&DocNum=" + docnumber , "_self") ;
}else{
if(window.document.images[aux].src == location.protocol+"//"+location.host+ caminho +"/icon_epm_collapse.gif"){
window.open( form + "&Collapse="+ docnumber + "&View="+view +"&DocNum=" + docnumber , "_self") ; }else{
window.open( form + "&Expand="+ docnumber + "&View="+view +"&DocNum=" + docnumber , "_self") ;
}
}
}else{
// SE A ÚLTIMA AÇÃO FOR UM COLLAPSE
if(url.indexOf("Collapse") != -1){
if(result == docnumber){
window.open( form + "&Expand="+ docnumber + "&View="+view +"&DocNum=" + docnumber , "_self") ;
}else{
if(window.document.images[aux].src == location.protocol+"//"+location.host+ caminho +"/icon_epm_collapse.gif"){
window.open( form + "&Collapse="+ docnumber + "&View="+view +"&DocNum=" + docnumber , "_self") ;
}else{
window.open( form + "&Expand="+ docnumber + "&View="+view +"&DocNum=" + docnumber , "_self") ;
}
}
}else{
// DEFAULT
if(url.indexOf("Collapse") == -1 && url.indexOf("Expand") == -1){
window.open( form + "&Expand="+ docnumber + "&View="+view +"&DocNum=" + docnumber ,"_self") ;
}else{
window.open( form + "&Collapse="+ docnumber + "&View="+view +"&DocNum=" + docnumber , "_self") ;
}
}
}
}
}
}

validar cpf

function valida_cpf(cpf) {

for(i=0;i cpf = cpf.replace(".","");
cpf = cpf.replace("-","");
}

var rcpf1 = cpf.substr(0,9);
var rcpf2 = cpf.substr(9,2);
var d1 = 0;

for (i=0;i<9;i++) {
d1 += rcpf1.charAt(i)*(10-i);
d1 = 11 - (d1 % 11);
}

if (d1>9) d1 = 0;

if (rcpf2.charAt(0) != d1) {
return false;
}

d1 *= 2;

for (i=0;i<9;i++) {
d1 += rcpf1.charAt(i)*(11-i);
d1 = 11 - (d1 % 11);
}
if (d1>9) d1 = 0;

if (rcpf2.charAt(1) != d1) {
return false;
}

return true;
}

Função Propercase

function toProperCase(s){
var i;
var returnString = "";
var tmpS=s.value.toLowerCase();
var arrS= new Array();
var arrS2 = new Array();
//search each word in array arrS
arrS=tmpS.split(" ");
for (i = 0; i < arrS.length; i++){
var thisWord=arrS[i];
//Check to see if word contains a hyphen
if(thisWord.indexOf("-")!=-1){
arrS2 = thisWord.split("-");
for(var j=0; j < arrS2.length; j++){
var thisWord2=arrS2[j];
returnString = returnString + thisWord2.charAt(0).toUpperCase() + thisWord2.substring(1,thisWord2.length)+"-";
}
returnString = returnString.substring(0,returnString.length-1)+" ";
} else {
returnString = returnString + thisWord.charAt(0).toUpperCase() + thisWord.substring(1,thisWord.length)+" ";
}
}
returnString = returnString.substring(0,returnString.length-1);
s.value = returnString;
}

Formatar CPF

Cpf:

function FormataCpf(campo, teclapres){

var tecla = teclapres.keyCode;
var vr = new String(campo.value);
vr = vr.replace(".", "");
vr = vr.replace("/", "");
vr = vr.replace("-", "");
tam = vr.length + 1;
if (tecla != 14) {
if (tam == 4)
campo.value = vr.substr(0, 3) + '.';
if (tam == 7)
campo.value = vr.substr(0, 3) + '.' + vr.substr(3, 6) + '.';
if (tam == 11)
campo.value = vr.substr(0, 3) + '.' + vr.substr(3, 3) + '.' + vr.substr(7, 3) + '-' + vr.substr(11, 2);
}
}


OU

function FormatarCPF(src, mask){
var i = src.value.length;
var saida = mask.substring(0,1);
var texto = mask.substring(i)
if (texto.substring(0,1) != saida){
src.value += texto.substring(0,1);
}
}

Verifica se a data é maior ou igual

Ex:

dtselecionada = document.getElementById('campodata').value;

if (datamaior(dataatual(),dtselecionada)){
alert( 'A data selecionada não pode ser menor que a data atual!');
return false;
}



function dataatual() {
var hoje = new Date()
var dia = hoje.getDate()
var mes = hoje.getMonth()
mes = mes+1
var ano = hoje.getFullYear()
if (dia < 10) dia = '0' + dia if (mes < 10) mes = '0' + mes var dtatual = dia+'/'+mes+'/'+ano return (dtatual); }; function datamaiorigual(dt1,dt2){ var hoje = new Date(); var ano = hoje.getYear(); if(ano >= 50 && ano <= 99) ano = 1900 + ano else ano = 2000 + ano; var pos1 = dt1.indexOf("/",0) var dd = dt1.substring(0,pos1) pos2 = dt1.indexOf("/", pos1 + 1) var mm = dt1.substring(pos1 + 1,pos2) var aa = dt1.substring(pos2 + 1,10) if(aa.length < 4) if(ano > 1999)
aa = (2000 + parseInt(aa,10))
else
aa = (1900 + parseInt(aa,10));
var data1 = new Date(parseInt(aa,10),parseInt(mm,10) - 1, parseInt(dd,10));
var pos1 = dt2.indexOf("/",0)
var dd = dt2.substring(0,pos1)
pos2 = dt2.indexOf("/", pos1 + 1)
var mm = dt2.substring(pos1 + 1,pos2)
var aa = dt2.substring(pos2 + 1,10)
if(aa.length < 4) if(ano > 80 && ano <= 99) aa = (1900 + parseInt(aa,10)) else aa = (2000 + parseInt(aa,10)); var data2 = new Date(parseInt(aa,10),parseInt(mm,10) - 1,parseInt(dd,10)); if(data1 > data2)
return true;
else
return false;
}

Verifica se e-mail é valido

function emailCheck (emailStr) {
var emailPat=/^(.+)@(.+)$/
var specialChars="\\(\\)<>@,;:\\\\\\\"\\.\\[\\]"
var validChars="\[^\\s" + specialChars + "\]"
var quotedUser="(\"[^\"]*\")"
var ipDomainPat=/^\[(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})\]$/
var atom=validChars + '+'
var word="(" + atom + "|" + quotedUser + ")"
var userPat=new RegExp("^" + word + "(\\." + word + ")*$")
var domainPat=new RegExp("^" + atom + "(\\." + atom +")*$")

var matchArray=emailStr.match(emailPat)
if (matchArray==null) {
return false
}
var user=matchArray[1]
var domain=matchArray[2]

if (user.match(userPat)==null) {
return false
}

var IPArray=domain.match(ipDomainPat)
if (IPArray!=null) {
for (var i=1;i<=4;i++) {
if (IPArray[i]>255) {
return false
}
}
return true
}

var domainArray=domain.match(domainPat)
if (domainArray==null) {
return false
}

var atomPat=new RegExp(atom,"g")
var domArr=domain.match(atomPat)
var len=domArr.length
if (domArr[domArr.length-1].length<2 ||
domArr[domArr.length-1].length>3) {
return false
}

if (len<2) {
var errStr="Este endereço de e-mail não possui um nome de Host!"
return false
}

return true;
}

Valida Data

function ValidacaoData(aDate) {
var monthDays = "101010110101";
var validDate = new String("");
var aDay, aMonth, aYear;
var aN, aMonthFlg;
validDate = aDate;

if( validDate.length != 10 ) { alert("utilizar a data com formato = (dd/mm/yyyy)."); return false; }

aDay = validDate.substring(0, 2);
aMonth = validDate.substring(3, 5);
aYear = validDate.substring(6, 10);

if( isNaN(parseInt(aDay)) || isNaN(parseInt(aMonth)) || isNaN(parseInt(aYear)) ) {
alert(" - Dia, mês e ano devem ser numéricos."); return false; }

aN = parseInt(aDay);
if( (aN < 0) || (aN > 31) ) { alert(" - O dia do mês de estar entre 1 e 31."); return false; }

if( (aMonth < 1) || (aMonth > 12) ) { alert(" - O mês deve estar entre 1 e 12."); return false; }

aMod = aYear % 4;
if( aMod == 0 ) aLim = 29;
else aLim = 28;

if( (aMonth == 2) && (aDay > aLim) ) { alert("Fevereiro, deste ano, tem " + aLim + " dias."); return false; }
aMonthFlg = parseInt(monthDays.substring(aMonth-1, aMonth));

if( (aMonthFlg == 0) && (aDay > 30) ) { alert("O mês tem somente 30 dias."); return false;
} return true;
}

#################################################################################

function validaData(pStr){
reDate = /^((0[1-9]|[12]\d)\/(0[1-9]|1[0-2])|30\/(0[13-9]|1[0-2])|31\/(0[13578]|1[02]))\/\d{4}$/;
if (reDate.test(pStr)) {
//alert(pStr + " é uma data válida.");
return true
} else if (pStr != null && pStr != "") {
// alert(pStr + " NÃO é uma data válida.");
return false
}
}

funções Left , right e Mid

function Left(str, valor)
{
var i = 0;
var strLen = 0;
strLen = str.length;
for(i = 0; (i < strLen) && (str.charAt(i) != valor); i++) ;
return str.substr(0,i);
}

function Right(str, valor)
{
var i = 0;
var strLen = 0;
strLen = str.length;
for(i = 0; (i < strLen) && (str.charAt(i) != valor); i++) ;
i++;
return str.substr(i,strLen);
}

function Mid(campo,x,y){
var res;
if(x>0)
x = x-1;
if(x+y > campo.length)
y = campo.length
else
y = x + y;
res = campo.substring(x,y);
return res;
}

Formatar CNPJ

function FormatarCNPJ(src, mask)
{
var i = src.value.length;
var saida = mask.substring(0,1);
var texto = mask.substring(i)
if (texto.substring(0,1) != saida)
{
src.value += texto.substring(0,1);
}
}

Valida CNPJ

function valida_cnpj(cnpj)
      {
      var numeros, digitos, soma, i, resultado, pos, tamanho, digitos_iguais;
      digitos_iguais = 1;
      if (cnpj.length < 14 && cnpj.length < 15)
            return false;
      for (i = 0; i < cnpj.length - 1; i++)
            if (cnpj.charAt(i) != cnpj.charAt(i + 1))
                  {
                  digitos_iguais = 0;
                  break;
                  }
      if (!digitos_iguais)
            {
            tamanho = cnpj.length - 2
            numeros = cnpj.substring(0,tamanho);
            digitos = cnpj.substring(tamanho);
            soma = 0;
            pos = tamanho - 7;
            for (i = tamanho; i >= 1; i--)
                  {
                  soma += numeros.charAt(tamanho - i) * pos--;
                  if (pos < 2)
                        pos = 9;
                  }
            resultado = soma % 11 < 2 ? 0 : 11 - soma % 11;
            if (resultado != digitos.charAt(0))
                  return false;
            tamanho = tamanho + 1;
            numeros = cnpj.substring(0,tamanho);
            soma = 0;
            pos = tamanho - 7;
            for (i = tamanho; i >= 1; i--)
                  {
                  soma += numeros.charAt(tamanho - i) * pos--;
                  if (pos < 2)
                        pos = 9;
                  }
            resultado = soma % 11 < 2 ? 0 : 11 - soma % 11;
            if (resultado != digitos.charAt(1))
                  return false;
            return true;
            }
      else
            return false;
      }

Valida todos os tipos de campos. Texto, Data, Numero, Radio, Check, Combo

function ValidaCampo(Campo,NomeCampo,TipoCampo){
if (TipoCampo == "Texto"){
if (document.getElementById(Campo).value ==""){
alert("Você deve preencher o campo " + NomeCampo);
return false
}else{
return true
}
}

if (TipoCampo == "Data"){
if(!validaData(document.getElementById(Campo).value)){
alert("Você deve preencher o campo " + NomeCampo);
return false
}else{
return true
}
}

if (TipoCampo == "Check"){
obj = document.getElementById(Campo)
if (obj.length > 0){
for (i=0 ; i { if (obj[i].checked){
return true
}
}
}else{
if (obj.checked){
return true
}
}
alert("Você deve selecionar uma opção no campo " + NomeCampo);
return false
}

if (TipoCampo == "Combo"){
objCombo = document.getElementById(Campo)
if (objCombo.options[objCombo.selectedIndex].text == "" | objCombo.options[objCombo.selectedIndex].text == "Selecione uma Opção"){
alert("Você deve selecionar uma opção no campo " + NomeCampo);
return false
}else{
return true
}
}

if (TipoCampo == "Radio"){
objRadio = eval("document.forms[0]." + Campo)
var flagRadio = 0;
for( var nPos = 0; nPos < objRadio.length; nPos++)
{
if( objRadio[nPos].checked){
flagRadio = 1;
}
}
if (flagRadio == 1){
return true
}else{
alert("Você deve selecionar uma opção no campo " + NomeCampo);
return false
}
}

if (TipoCampo == "Valor"){
objNumber = replace(replace(document.getElementById(Campo).value, ",",""),".","")
if (objNumber == parseInt( objNumber ) ){ return true;
}else{
alert("Você deve preencher o campo " + NomeCampo + " com caracteres monetários( Números, vírgula e pontos )");
return false;
}
}

if (TipoCampo == "Numero"){
objNumber = document.getElementById(Campo).value
if (objNumber == parseInt( objNumber ) ){ return true;
}else{
alert("Você deve preencher o campo " + NomeCampo + " com caracteres númericos.");
return false;
}
}
}

Trata a Mensagem "No Documents Found".

Funções chamadas no Envento OnLoad.

var noDocumentsFound = document.body.all.tags("H2");
var tagH2, textH2;

for (var i = 0; i < noDocumentsFound.length; i++){
tagH2 = noDocumentsFound[i];
textH2 = tagH2.innerText;
if (textH2.toLowerCase() == "no documents found"){
tagH2.innerHTML = '

Não foram encontradas .....';
}
tagH2.style.display = "block";
}



function MudaMsg() {
var chkH = document.all.tags('h2') ;
if (chkH.length==1) {
document.all.vwEmbed.style.visibility="hidden";
document.all.texto.style.visibility="visible";
} else {
document.all.vwEmbed.style.visibility="visible";
document.all.texto.style.visibility="hidden";
}
}
}