PROTE

[wkarts]

Bom Hoje Gostaria Tratar (Abordar) Um Assunto Muito Interessante
A Proteção para aplicativos DELPHI Gerados no XMAKER

Não vou Postar a Fonte POis não sei se é permitido.

Apouco tempo encontrei na Internet um poste tratando esse assunto.
E as seguintes Rotinas:

1) Reconhece se tem proteção, se não cria proteção para 30 dias corridos
2) Reconhece se acabou o tempo de avaliação de 30 dias e faz a proposta para mais 5 dias ou :
3) Aluga para 30 dias ou
4) Compra definitivamente o programa

Procedure registrarprg;
procedure violacao;
procedure alugaprograma;
procedure maiscincodias;
procedure EscolhadeProtecao;
{Verifica numero do serial do HD}
Function SerialNum(FDrive:String) :String;
Function Gera_Senha(Name: string; Key: string):string;
{Direciona o Diretorio do Windows}
function DirWindows: string;
procedure versituacao;
procedure CriaProtecao;
procedure VerAluguel;
procedure Ver5dias;
function ReadRegInt(sPath: HKey; sOpenKey,sNomeValue: string; sValue: integer): integer;
function ObtemData(dwChaveRaiz: DWord; const strChave,strCampo: string): TDateTime;
function Encript(Encript : String): string;
function Decript(Decript : String): string;
{fim dos procedures de proteção do programa}


implementation



function Encript(Encript : String): string;
var
Cod: String;
Codi_go: String;
Qt_Expc: Integer;
X : Integer;
POrd: Integer;
D: string;
begin
Cod := Encript;
Codi_go := '';
Qt_Expc := Length(Encript);
for X := QT_EXPC downto 1 do
Codi_go := Codi_go + Copy(Cod,X,1);
Cod:= '';
for X := 1 TO Qt_Expc do
begin
D:= Copy(Codi_go,X,1);
Pord := Ord(D[1]);
if X/2 = INT(X/2) then
Cod := Cod+CHR(Pord+1)
else
Cod := Cod+CHR(Pord-1);
end;
Codi_go := Cod;
Result := Codi_go;
end;

function Decript(Decript : String): string;
var
Cod: String;
Codi_go: String;
Qt_Expc: Integer;
X : Integer;
POrd: Integer;
D: string;
Resto: Integer;
begin
Cod := Decript;
Codi_go := '';
Qt_Expc := Length(Decript);
Resto := Length(Decript) mod 2;
for X := QT_EXPC downto 1 do
Codi_go := Codi_go + Copy(Cod,X,1);
Cod:= '';
for X := 1 TO Qt_Expc do
begin
D:= Copy(Codi_go,X,1);
Pord := Ord(D[1]);
if Resto > 0 then
begin
if not (X/2 = INT(X/2)) then
Cod := Cod+CHR(Pord+1)
else
Cod := Cod+CHR(Pord-1);
end
else
begin
if X/2 = INT(X/2) then
Cod := Cod+CHR(Pord+1)
else
Cod := Cod+CHR(Pord-1);
end;
end;
Codi_go := Cod;
Result := Codi_go;
end;

procedure versituacao;
var
Reg: TRegistry;
Situacao:integer;
DataValidade,DataAcesso:TDate;
begin
try
Reg:= TRegistry.Create;
if not Reg.KeyExists('ProtS2') then
begin
IF fileExists(DirWindows+'\system\stma.txt') or
fileExists(DirWindows+'\system\alg.txt') or
fileExists(DirWindows+'\vrfc.txt') then
Application.MessageBox('Será criado permissão de uso para 5 dias visto você já conhecer o Seu Programa!','Bem vindo ao Seu Programa 3', MB_ICONINFORMATION + MB_OK ) else
Application.MessageBox('Será criado permissão de uso para 30 dias!','Bem vindo ao Seu Programa 3', MB_ICONINFORMATION + MB_OK );
CriaProtecao;
VerSituacao;
end
else
begin
Reg.OpenKey('ProtS2',True);
situacao:=ReadRegInt(HKEY_CURRENT_USER,'ProtS2','Sit',situacao);
DataValidade:=ObtemData(HKEY_CURRENT_USER,'ProtS2','Data_Limite');
DataAcesso:=ObtemData(HKEY_CURRENT_USER,'ProtS2','Data_Ultmacs');

case situacao of
0:VerAluguel;
1:Ver5dias;
3:violacao;
end;
end;
finally
Reg.CloseKey;
end;
end;

{direção para diretorio do windos}
function DirWindows: string;
var
Dir: array[0..255] of char;
begin
GetWindowsDirectory(Dir, 255);
Result := StrPas(Dir);
end;

{gera senha para proteção}
Function Gera_Senha(Name: string; Key: string):string;
var
I: Integer;
begin
Result := '';
for I := 1 to Length(Name) do
Result := Result + IntToHex(Ord(Name[I]) xor Ord(Key[(I mod Length(Key) + 1)]), 2);
end;

{pega o serial fisico do HD}
Function SerialNum(FDrive:String) :String;
Var
Serial:DWord;
DirLen,Flags: DWord;
DLabel : Array[0..11] of Char;
begin
Try GetVolumeInformation(PChar(FDrive+':\'),dLabel,12,@Serial,DirLen,Flags,nil,0);
Result := IntToHex(Serial, ;
Except Result :='';
end;
end;

{Procedimento se houver violação da data do sistema, se a pessoa quer voltar a data para ganhar mais tempo}
procedure violacao;
var
Reg: TRegistry;
choix: integer;
begin
try
Reg:= TRegistry.Create;
try
Reg.OpenKey('ProtS2',True);
Reg.WriteInteger('Sit',3); //0=aluguel 30 dias, 1=+ 5 dias , 2=registro do programa final e 3= violacao da data do sistema
except
on E: Exception do ShowMessage(E.Message);
end;
//choix:=MessageBox(Handle, pchar('Houve violação na data do Sistema,o programa vai ser terminado.Deseja resolver agora?') , pchar('Aviso da Proteção do Sistema'), 36);

If choix=6 then
alugaprograma else Application.Terminate;

finally
Reg.CloseKey;
end;
end;

{cria a proteção do programa}
procedure CriaProtecao;
var arq: TextFile;
Reg: TRegistry;
begin
if not FileExists(DirWindows+'\inf\xxxx1.txt') then //vs. 2.09.00 Acrescentado 30/11/06 se o usuario retirar aproteção no registro
begin
AssignFile ( arq, DirWindows+'\inf\xxxx1.txt');
Rewrite(arq, DirWindows+'\inf\xxxx1.txt');
FileSetAttr (DirWindows+'\inf\xxxx1.txt',3);
closefile(arq);
Reg:= TRegistry.Create;
if not Reg.KeyExists('ProtS2') then
begin
Reg.CreateKey('ProtS2');
Reg.OpenKey('ProtS2',True);
if not Reg.ValueExists('Data_Limite') then
try
IF fileExists(DirWindows+'\system\stm.txt')then
Reg.WriteDate('Data_Limite',IncDia(now,5)) else
IF fileExists(DirWindows+'\vrfc.txt') then
Reg.WriteDate('Data_Limite',IncDia(now,5)) else
IF fileExists(DirWindows+'\system\alg.txt') then
Reg.WriteDate('Data_Limite',IncDia(now,5)) else
Reg.WriteDate('Data_Limite',IncDia(now,30));
except
on E: Exception do ShowMessage(E.Message);
end;
if not Reg.ValueExists('Data_Ultmacs') then
try
Reg.WriteDate('Data_Ultmacs',date);
except
on E: Exception do ShowMessage(E.Message);
end;
if not Reg.ValueExists('Sit') then
try
Reg.WriteInteger('Sit',0); //0=aluguel 30 dias, 1=+ 5 dias , 2=registro do programa final e 3= violacao da data do sistema
except
on E: Exception do ShowMessage(E.Message);
end;
Reg.CloseKey;
end;
end
else
begin
SHowMessage('Houve violação no registro do Sistema,você terá que escolher a forma de registro');
EscolhadeProtecao;
end;
end;

procedure EscolhadeProtecao;
var opcao:string;
begin
Application.MessageBox('Venceu o prazo de licenciamento do Sistema!','Aviso do Sistema', MB_ICONINFORMATION + MB_OK );
opcao := InputBox('Registrar, Alugar ou mais 5 Dias', 'Digite: (1) Registrar, (2) Alugar, (3) + 5 Dias:', '');
if opcao ='1' then Registrarprg else
if opcao ='2' then AlugaPrograma else
if opcao ='3' then MaisCincoDias else
if (opcao <> '1') and (opcao <> '2') and (opcao <> '3')
then
begin
Application.MessageBox('Opção de escolha incorreta, será encerrado o sistema!','Erro de Escolha', MB_ICONSTOP + MB_OK );
Application.Terminate;
end;

end;
{registra o programa definitivamente}
Procedure registrarprg;
var
Reg: TRegistry;
senha,habilita:string;
DataValidade,DataAcesso:TDate;
begin
try
Reg:= TRegistry.Create;
try
Reg.OpenKey('ProtS2',True);

senha:=Copy(Gera_Senha(SerialNum('C'), DatetoStr(NOW)),1,10);
habilita:=InputBox('Registro do Seu Programa','Digite o Serial informado pelo seu Fornecedor da máquina com serial '+SerialNum('C')+':','');
DataValidade:=ObtemData(HKEY_CURRENT_USER,'ProtS2','Data_Limite');
if senha = UpperCase(habilita) then
begin
Reg.WriteInteger('Sit',2);
Application.MessageBox('Obrigado por registrar o Seu Programa!','Aviso do Sistema', MB_ICONINFORMATION + MB_OK );
VerSituacao;
end
else
begin
Application.MessageBox('Senha incorreta, não foi possível registrar o Seu Programa!','Aviso do Sistema', MB_ICONERROR + MB_OK );
Application.Terminate;
end;
except
on E: Exception do ShowMessage(E.Message);
end;
finally
Reg.CloseKey;
end;
end;

{dá mais 5 dias para avaliação do programa}
procedure maiscincodias;
var
Reg: TRegistry;
senha,habilita:string;
DataValidade,DataAcesso:TDate;
begin
try
Reg:= TRegistry.Create;
try
Reg.OpenKey('ProtS2',True);
senha:=Copy(Gera_Senha(SerialNum('C'), DatetoStr(NOW)),1,14);
habilita:=InputBox('Registro do Seu Programa','Digite o Serial informado pelo seu Fornecedor da máquina com serial '+SerialNum('C')+':','');
if senha = UpperCase(habilita) then
begin
Reg.WriteInteger('Sit',1);
Reg.WriteDate('Data_Limite',IncDia(now,5));
DataValidade:=ObtemData(HKEY_CURRENT_USER,'ProtS2','Data_Limite');
ShowMessage('Validade foi prorrogada até '+DateToStr(DataValidade));
VerSituacao;
end
else
begin
Application.MessageBox('Senha incorreta, não foi possível registrar o Seu Programa!','Aviso do Sistema', MB_ICONERROR + MB_OK );
Application.Terminate;
end;
except
on E: Exception do ShowMessage(E.Message);
end;
finally
Reg.CloseKey;
end;
end;

{aluga o programa}

procedure alugaprograma;
var
Reg: TRegistry;
senha,habilita:string;
DataValidade,DataAcesso:TDate;
begin
try
Reg:= TRegistry.Create;
Reg.OpenKey('ProtS2',True);
senha:=Copy(Gera_Senha(SerialNum('C'), DatetoStr(NOW)),1,12);
habilita:=InputBox('Registro do Seu Programa','Digite o Serial informado pelo seu Fornecedor da máquina com serial '+SerialNum('C')+':','');
if senha = UpperCase(habilita) then
begin
Reg.WriteInteger('Sit',0);
Reg.WriteDate('Data_Limite',IncDia(now,30));
DataValidade:=ObtemData(HKEY_CURRENT_USER,'ProtS2','Data_Limite');
ShowMessage('Validade foi prorrogada até '+DateToStr(DataValidade));
VerSituacao;
end
else
begin
Application.MessageBox('Senha incorreta, não foi possível alugar o Seu Programa!','Aviso do Sistema', MB_ICONERROR + MB_OK );
if date < DataValidade then Application.Terminate else
VerSituacao;
end;
finally
Reg.CloseKey;
end;
end;

{pega no registro valor integer}
function ReadRegInt(sPath: HKey; sOpenKey,sNomeValue: string; sValue: integer): integer;
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
if Reg.KeyExists(sOpenKey) then
begin
Reg.OpenKey(sOpenKey, false);
if Reg.ValueExists(sNomeValue) then
try
result := Reg.ReadInteger(sNomeValue)
except
result := -1
end
else
result := -1
end
else
result := -1
finally
Reg.Free;
end;
end;
// Obtém Data do Registro

function ObtemData(dwChaveRaiz: DWord; const strChave,strCampo: string): TDateTime;
begin
Result := 0; // Valor de retorno default
with TRegistry.Create do
begin
RootKey := dwChaveRaiz;
if OpenKey(strChave, False) then
begin
try
ReadBinaryData(strCampo, Result, SizeOf(Result));
finally
CloseKey;
end;
end;
Free;
end;
end;

{aluga o programa}
procedure VerAluguel;
var
DataValidade,DataAcesso:TDate;
begin
DataValidade:=ObtemData(HKEY_CURRENT_USER,'ProtS2','Data_Limite');
DataAcesso :=ObtemData(HKEY_CURRENT_USER,'ProtS2','Data_Ultmacs');
if now < DataAcesso then Violacao;
if (DataValidade - date < 2) then Application.MessageBox('Amanhã encerrará a validade de 30 dias do programa!','Aviso do Sistema', MB_ICONINFORMATION + MB_OK );
if (DataValidade < date) then EscolhadeProtecao;
end;

{ver se o foi concedido 5 dias e se já acabou}

procedure Ver5dias;
var

DataValidade,DataAcesso:TDate;
begin
DataValidade:=ObtemData(HKEY_CURRENT_USER,'ProtS2','Data_Limite');
DataAcesso :=ObtemData(HKEY_CURRENT_USER,'ProtS2','Data_Ultmacs');
ShowMessage('Data Hoje : '+DateToStr(now)+', Data Validade :'+DateToStr(DataValidade));
if now < DataAcesso then Violacao;
if (DataValidade - date < 2) then Application.MessageBox('Amanhã encerrará a validade de 5 dias do programa!','Aviso do Sistema', MB_ICONINFORMATION + MB_OK );
if DataValidade < date then EscolhadeProtecao;
end;
end.



No OnShow do aplicativo vc coloca apenas a chamada :

versituacao;


Qual a forma que gera a chave de lieberação...?

?? só vc criar um pequeno programa para quando o pessoal ligar vc passar a chave que liberará o programa:

Para Registrar definitivamente a copia:
senha:=Copy(Gera_Senha(Alltrim(EditSHD.Text), DatetoStr(NOW)),1,10);
EditRegistrar.Text:=senha;

Para Alugar a copia para mais 30 dias:

senha:=Copy(Gera_Senha(Alltrim(EditSHD.Text), DatetoStr(NOW)),1,12);
EditAlugar.Text:=senha;

Para dar mais cinco dias:

senha:=Copy(Gera_Senha(Alltrim(EditSHD.Text), DatetoStr(NOW)),1,14);
Edit5dias.Text:=senha;


Detalhe Como Aplicar essa interessante ROTINA ao XMAKER?

PESSO AGORA A COLABORA????O DO SUPORTE DO F??RUM!

OBRIGADO.

[wkarts]

Eu já Fiz uma Tentativa, mas na hora de compila apresenta muitos erros umas até corrigi
porém quando chega em :

Rotinas.Pas(1342) Error: Undeclared indentifier: 'IncDia.dcu'

aí eu vou e declaro em:

uses
Registry, IncDia;

Apresenta o seguinte erro:


Rotinas.Pas(99) Fatal: file not found: 'IncDia.dcu'

Aí neste ponto fiquei perdido!

[Suporte]

Olá,

Você fez corretamente, porém a função incdia, não exite, mas o objetivo dela analisando o programa, pode ser substituido pela soma simples...

Substitua totdos IncDia(now,5) por (now+5)
e todos IncDia(now,30) por (now+30)

Retire do seu "Uses" o que você adicionou "IncDia"

Qualquer coisa volte a postar.

[wkarts]

[wkarts]

Olá

Será Que Você pode estar fazendo um exemplo e me enviando por email?

[LOGISOFT]

Prezado amigo,

Vi seu post que foi feito em janeiro, sobre uma rotina de proteção para os sistemas gerados no xmaker !!!

O pessoal do suporte conseguiu te ajudar a implantar ?

Teria como disponibilizar para nós do fórum ?, seria de grande ajuda !!!

Grato
João Carlos

[ricardobhte]

Amigos, boa noite, faça uma pesquisa na internet e tente achar um componente chamado
AVLOCK muito completo e simples.

At,
Ricardo

[LOGISOFT]

Prezado Ricardo,

Vi seu post referente o Awlock, porém pergunto, o xmaker vai aceitar componentes de terceiros ?

a idéia e uma solução para usar no Xmaker !

Grato
João Carlos