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)
quinta-feira, 26 de agosto de 2010
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;
}
}
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;
}
}
quarta-feira, 25 de agosto de 2010
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
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
quinta-feira, 19 de agosto de 2010
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
'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
terça-feira, 17 de agosto de 2010
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
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
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
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
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
segunda-feira, 16 de agosto de 2010
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';
}
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';
}
segunda-feira, 9 de agosto de 2010
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
' 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>
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);
}
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);
}
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);
}
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);
}
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);
}
sexta-feira, 6 de agosto de 2010
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))
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))
quinta-feira, 5 de agosto de 2010
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
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
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
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
%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
quarta-feira, 4 de agosto de 2010
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
' ===> 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
' ===> 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
' ===> 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
' ===> 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
' ===> 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
' ===> 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
' ===> 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
' ===> 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
' ===> 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
' ===> 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
' ===> 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
' 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
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
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
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
'//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
'//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
'//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
'//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
segunda-feira, 2 de agosto de 2010
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
// 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);
}
// 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
// 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);
}
Assinar:
Postagens (Atom)