Analitcs

Pesquisar no conteúdo do blog.atlabs.com.br

quarta-feira, 27 de junho de 2012

DELPHI/FIREBIRD - Criação de banco (Firebird/Interbase) em RunTime (tempo de execução) e Execução de script de criação.

Reações: 


// ATLabs 27-06-2012
// Unit1.pas inicio

Unit Unit1;

interface

uses

  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, DB, IBDatabase, IBCustomDataSet, IBQuery, DBXpress,
  SqlExpr, Gauges;

type

  TForm1 = class(TForm)
    IBDatabase1: TIBDatabase;
    Button1: TButton;
    IBTransaction1: TIBTransaction;
    IBQuery1: TIBQuery;
    OpenDialog1: TOpenDialog;
    Gauge1: TGauge;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    procedure ExecutaScript(DBNAME, sArquivo: String);
    procedure CommitWork;
    Function ExecutaSQL(S : String; Var sError : String) : Boolean;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

Const
    fProcedures = 'STORED PROCEDURES';
    fViews      = 'VIEWS';
    fTables     = 'TABLES';
    fInsert     = 'INSERT INTO ';
    fDelete     = 'DELETE FROM ';
    fSetGen     = 'SET GENERATOR ';
    fCommit     = 'COMMIT WORK;';

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
const
  DataBaseName = 'C:\TMP\BASE.GDB';
var
  i : Integer;  
begin
  IBDatabase1.DatabaseName := DataBaseName;
  IBDatabase1.LoginPrompt := false;
  if not FileExists(DataBaseName) then
  begin
    IBDatabase1.Params.Text :=
      ' USER ''SYSDBA'' PASSWORD ''masterkey'' ' +
      ' PAGE_SIZE 8192 ' +
      ' DEFAULT CHARACTER SET NONE COLLATION NONE ';
    IBDatabase1.CreateDatabase;
    ShowMessage('Banco de dados ' + DataBaseName + ' criado com sucesso!');
  end;
  IBDatabase1.Close;
  IBDatabase1.Params.Clear;
  IBDatabase1.Params.Add('user_name=sysdba');
  IBDatabase1.Params.Add('password=masterkey');

  IBDatabase1.Open;
  if OpenDialog1.Execute then
  begin
    Gauge1.Visible := True;
    try
    Self.ExecutaScript(DataBaseName, OpenDialog1.FileName);
    finally
      Gauge1.Visible := False;
    end;
  end;
  IBDatabase1.Close;
end;

procedure TForm1.CommitWork;
var
  ibqCommit : TIBQuery;
begin
  Try
    ibqCommit             := TIBQuery.Create(Nil);
    ibqCommit.Database    := IBDatabase1;
    ibqCommit.Transaction := IBDatabase1.DefaultTransaction;
    ibqCommit.Close;
    ibqCommit.SQL.Text := 'Commit Work';
    ibqCommit.ExecSQL;
  Finally
    FreeAndNil(ibqCommit);
  End;
end;


procedure TForm1.ExecutaScript(DBNAME, sArquivo: String);
var
  Strs, sSQL : TStringList;
  SQL, sItem, scTipo, sNProc, cEnd, sMSG, sError : String;
  I, Itens, ItensProc, ItensNProc,
  ErrorCode : Integer;
  SQLConnection : TSQLConnection;
Const

  cView0  = 'CREATE VIEW ';
  cView1  = 'CREATE OR ALTER VIEW ';
  cSP0    = 'CREATE PROCEDURE ';
  cSP1    = 'ALTER PROCEDURE ';
  cSP2    = 'CREATE OR ALTER PROCEDURE ';

  cCreate       = 'CREATE ';
  cCreateErr0   = 'CREATE DATABASE ';

  cAlter        = 'ALTER ';
  cInsert       = 'INSERT ';
  cDelete       = 'DELETE ';
  cDescrib      = 'DESCRIBE ';
  cDeclareExt   = 'DECLARE EXTERNAL ';
  cSet          = 'SET ';
  cSetErr0      = 'SET SQL ';
  cSetErr1      = 'SET NAMES ';
  cSetErr2      = 'SET TERM ';
  cCommit       = 'COMMIT ';
  cEndP         = '^';
  cEndAll       = ';';

  procedure LimpaVars;
  begin
    sSQL.Clear;
    sSQL.text := '';
    SQL := '';
    scTipo := '';
    sItem := '';
  end;

  function ValidaItem(SQL : String) : Boolean;
  begin
    Result := False;
    if (
       ((POS(cCreate, UpperCase(SQL)) = 1)
       and (POS(cCreateErr0, UpperCase(SQL)) = 0)
       )
    or (POS(cView0, UpperCase(SQL)) = 1)
    or (POS(cView1, UpperCase(SQL)) = 1)
    or (POS(cSP0, UpperCase(SQL)) = 1)
    or (POS(cSP1, UpperCase(SQL)) = 1)
    or (POS(cSP2, UpperCase(SQL)) = 1)
    or (POS(cAlter, UpperCase(SQL)) = 1)
    or (POS(cInsert, UpperCase(SQL)) = 1)
    or (POS(cDelete, UpperCase(SQL)) = 1)
    or (POS(cDescrib, UpperCase(SQL)) = 1)
    or (POS(cDeclareExt, UpperCase(SQL)) = 1)
    or ((POS(cSet, UpperCase(SQL)) = 1)
         and (POS(cSetErr0, UpperCase(SQL)) = 0)
         and (POS(cSetErr1, UpperCase(SQL)) = 0)
       )
    or (POS(cCommit, UpperCase(SQL)) = 1)) then
    Result := True;
  end;

  Procedure SetItem(SQL : String);
  begin
    scTipo := '';
    if ValidaItem(SQL) then
    begin
      if (POS(cCreate, UpperCase(SQL)) = 1) then
        scTipo := cCreate;
      if (POS(cView0, UpperCase(SQL)) = 1) then
        scTipo := cView0;
      if (POS(cView1, UpperCase(SQL)) = 1) then
        scTipo := cView1;
      if (POS(cSP0, UpperCase(SQL)) = 1) then
        scTipo := cSP0;
      if (POS(cSP1, UpperCase(SQL)) = 1) then
        scTipo := cSP1;
      if (POS(cSP2, UpperCase(SQL)) = 1) then
        scTipo := cSP2;

      if (POS(cAlter, UpperCase(SQL)) = 1) then
        scTipo := cAlter;

      if (POS(cInsert, UpperCase(SQL)) = 1) then
        scTipo := cInsert;
      if (POS(cDelete, UpperCase(SQL)) = 1) then
        scTipo := cDelete;
      if (POS(cDescrib, UpperCase(SQL)) = 1) then
        scTipo := cDescrib;
      if (POS(cDeclareExt, UpperCase(SQL)) = 1) then
        scTipo := cDeclareExt;
      if (POS(cSet, UpperCase(SQL)) = 1) then
        scTipo := cSet;
      if (POS(cCommit, UpperCase(SQL)) = 1) then
        scTipo := cCommit;
    end;
  end;

  procedure SetValuecEnd(SQL : String);
  begin
    if ValidaItem(SQL) then
    begin
      cEnd := cEndAll;
      if (POS(cSP0, UpperCase(SQL)) = 1)
      or (POS(cSP1, UpperCase(SQL)) = 1)
      or (POS(cSP2, UpperCase(SQL)) = 1) then
      cEnd := cEndP;
    end;  
  end;

  Function SQLValido (SQL : TStringList) : Boolean;
  begin
    Result := False;
    if (POS(UpperCase(scTipo), UpperCase(SQL.Strings[0])) = 1) then
      Result := True
    Else
      LimpaVars;
  end;
begin

  try

    Strs := TStringList.Create;
    SQLConnection := TSQLConnection.Create(Nil);
    SQLConnection.ConnectionName := 'IBLocal';
    SQLConnection.DriverName     := 'Interbase';
    SQLConnection.GetDriverFunc  := 'getSQLDriverINTERBASE';
    SQLConnection.LibraryName    := 'dbexpint.dll';
    SQLConnection.Params.Text :=
      'BlobSize=-1' + #13#10 +
      'CommitRetain=False' + #13#10 +
      'Database=' + DBNAME + #13#10 +
      'DriverName=Interbase' + #13#10 +
      'ErrorResourceFile=' + #13#10 +
      'LocaleCode=0000' + #13#10 +
      'Password=masterkey' + #13#10 +
      'RoleName=RoleName' + #13#10 +
      'ServerCharSet=' + #13#10 +
      'SQLDialect=3' + #13#10 +
      'Interbase TransIsolation=ReadCommited' + #13#10 +
      'User_Name=sysdba' + #13#10 +
      'WaitOnLocks=True';
    SQLConnection.VendorLib := 'GDS32.DLL';
    SQLConnection.Open;

   if FileExists(sArquivo) then
    begin
      try
      sSQL := TStringList.Create;
      Strs.LoadFromFile(sArquivo);
      Gauge1.MinValue := 0;
      Gauge1.MaxValue := Strs.Count;

      I := 0;
      Itens := 0;
      ItensProc := 0;
      ItensNProc := 0;
      LimpaVars;

      while I <= Strs.Count - 1 do
      begin
        if (trim(StringReplace(Strs.Strings[i], #$D#$A, '', [rfReplaceAll, rfIgnoreCase])) = '')  and (sSQL.Count = 0) then
        begin
          Inc(I);
          Continue;
        end;


        if (sSQL.Count > 0)
        and (SQLValido(sSQL))
        and (POS(cEnd, sSQL.text) > 0)
        and (StringReplace(sSQL.text, #$D#$A, '', [rfReplaceAll, rfIgnoreCase]) <> '')
        and (ValidaItem(sSQL.Strings[0]))
        then
        begin
          Sleep(1);
          Application.ProcessMessages;
          SQL := sSQL.text;
            if cEnd = cEndP then
            begin
              Delete(SQL, Pos(cEnd,sSQL.text), 1);
              sSQL.text := SQL;
              try

              ErrorCode := SQLConnection.ExecuteDirect(sSQL.text);
              SQLConnection.ExecuteDirect('COMMIT WORK');
              except
                on e: Exception do
                begin
                  if POS(UpperCase('ALREADY EXISTS'), UpperCase(E.Message)) = 0 then
                  ShowMessage('Erro: ' + E.Message);
                  end;
              end;
              if ErrorCode <> 0 then
              begin
                sNProc := sNProc + ' ' + sItem;
                Inc(ItensNProc);
              end
              else
              Inc(ItensProc);
            end;

          if (cEnd = cEndAll) and (POS(cEndAll, sSQL.text) > 0) then
          begin
            Delete(SQL, Pos(cEnd,sSQL.text), 1);
            sSQL.text := SQL;

            if Self.ExecutaSQL(sSQL.text, sError) then
            begin
              Inc(ItensProc);
              Self.CommitWork;
            end
            else
            begin
              if POS(UpperCase('ALREADY EXISTS'), UpperCase(sError)) = 0 then
              begin
                sNProc := sNProc + ' ' + sItem;
                Inc(ItensNProc);
              end;
            end;
          end;

          LimpaVars;
          inc(Itens);
        end;


        if (trim(Strs.Strings[i]) <> '') then
        begin
          if (scTipo = '') then
            LimpaVars;

          SQL := Strs.Strings[i];

          if ValidaItem(SQL) then
          begin
            SetValuecEnd(SQL);
            if (POS(cView0, UpperCase(SQL)) > 0) then
            begin
              SQL := StringReplace(SQL, cView0, cView1, [rfReplaceAll, rfIgnoreCase]);
              scTipo := cView1;
            end;

            if (POS(cSP1, UpperCase(SQL)) > 0) then
            begin
              SQL := StringReplace(SQL, cSP1, cSP2, [rfReplaceAll, rfIgnoreCase]);
              scTipo := cSP2;
            end;

            SetItem(SQL);

            if  Pos('(', SQL) > 0 then
            begin
              sItem := Copy(SQL, POS(scTipo, UpperCase(SQL)) + Length(scTipo), Pos('(', SQL) - (POS(scTipo, UpperCase(SQL)) + Length(scTipo)));
              if  Pos(' ', sItem) > 0 then
              sItem := Copy(sItem, POS(' ', UpperCase(sItem)), Length(sItem));
            end
            else
              if (POS(cEnd, SQL) > 0) then
                sItem := SQL;
          end;
          Self.Caption := sItem;
          sSQL.Add(SQL);
        end;

        Inc(i);
        Gauge1.Progress := i;
      end;

      finally
        Gauge1.Progress := Strs.Count;
        FreeAndNil(sSQL);
        SQLConnection.Close;
        FreeAndNil(SQLConnection);
        Self.CommitWork;
        sMSG := 'Resumo Arquivo : ' + ExtractFileName(sArquivo) + #$D#$A +
                'Linhas: ' + inttostr(I) + #$D#$A +
                'Qtd. Itens: ' + inttostr(Itens) + #$D#$A +
                'Qtd. Itens Processados: ' + inttostr(ItensProc) + #$D#$A +
                'Qtd. Itens Não Processados: ' + inttostr(ItensNProc) + #$D#$A +
                TrimLeft(sNProc);

       ShowMessage(sMSG);
      end;

   end
    else
    begin
      ShowMessage('O arquivo: "' + sArquivo + '" não foi localizado. Cancelado.');
    end;
  finally
    FreeAndNil(Strs);
  end;
end;

function TForm1.ExecutaSQL(S : String; Var sError : String): Boolean;
var
  ibqExecSql : TIBQuery;
begin

  Try
    Result                 := False;
    ibqExecSql             := TIBQuery.Create(Nil);
    ibqExecSql.Database    := IBDatabase1;
    ibqExecSql.Transaction := IBDatabase1.DefaultTransaction;

    ibqExecSql.Close;
    ibqExecSql.SQL.Text := S;
    try
      ibqExecSql.ExecSQL;
      Result := True;
      sError := '';
    Except
      on E: Exception do
      begin
        Result := False;
        sError := E.Message;
      end;
    end;
  Finally
    FreeAndNil(ibqExecSql);
  End;
end;
end.
// Unit1.pas Fim


// Unit1.dfm Inicio

object Form1: TForm1
  Left = 175
  Top = 117
  Width = 169
  Height = 121
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object Gauge1: TGauge
    Left = 0
    Top = 73
    Width = 161
    Height = 14
    Align = alBottom
    Progress = 0
    Visible = False
  end
  object Button1: TButton
    Left = 43
    Top = 31
    Width = 75
    Height = 25
    Caption = 'Cria Base'
    TabOrder = 0
    OnClick = Button1Click
  end
  object IBDatabase1: TIBDatabase
    DatabaseName = 'C:\TMP\BASE.GDB'
    Params.Strings = (
      'user_name=sysdba'
      'password=masterkey')
    LoginPrompt = False
    DefaultTransaction = IBTransaction1
    IdleTimer = 0
    SQLDialect = 3
    TraceFlags = []
    Left = 27
    Top = 15
  end
  object IBTransaction1: TIBTransaction
    Active = False
    AutoStopAction = saNone
    Left = 27
    Top = 45
  end
  object IBQuery1: TIBQuery
    Database = IBDatabase1
    Transaction = IBTransaction1
    BufferChunks = 1000
    CachedUpdates = False
    Left = 75
    Top = 6
  end
  object OpenDialog1: TOpenDialog
    Filter = 'Arquivos *.sql|*.sql'
    Left = 114
    Top = 6
  end
end
// Unit1.dfm Fim

terça-feira, 26 de junho de 2012

DELPHI - Alterando Configurações Regionais (dd/MM/yyyy)

Reações: 


// ATLabs 26-06-2012

SetLocaleInfo(LOCALE_SYSTEM_DEFAULT,  LOCALE_SSHORTDATE, PChar('dd/MM/yyyy'));

// Há outras configurações que podem ser alteradas, altere a constante LOCALE_SSHORTDATE pressionando o ctrl+espaco em LOCALE_S

DELPHI - Formatando CNPJ/CPF

Reações: 


//ATLabs 26-06-2012


//Formatar CNPJ

function FormataCNPJ(const Valor : String) : string;
Const
  ZEROS = '000000000000000000'; // 18 Caracteres
Var S : String;
begin
   S := ZEROS + Valor;
   S :=       Copy(S, length(S) - 13, 2) +
        '.' + Copy(S, length(S) - 11, 3) +
        '.' + Copy(S, length(S) - 8, 3) +
        '/' + Copy(S, length(S) - 5, 4) +
        '-' + Copy(S, length(S) - 1, 2);
   result := Copy(S, Length(S) - 18, 18); // Tamanho 18 já com a formatação 00.000.000/0000-00
end;

//Formatar CPF
function FormataCPF(const Valor : String) : string;
Const
  ZEROS = '00000000000000'; // 14 Caracteres
Var S : String;
begin
   S := ZEROS + Valor;
   S :=       Copy(S, length(S) - 10, 3) +
        '.' + Copy(S, length(S) - 7, 3) +
        '.' + Copy(S, length(S) - 4, 3) +
        '-' + Copy(S, length(S) - 1, 2);
   result := Copy(S, Length(S) - 14, 14); // Tamanho 14 já com a formatação 000.000.000-00
end;

segunda-feira, 25 de junho de 2012

DELPHI - Listando Processos da Memória

Reações: 


// Dados da Unit1.Pas

// Unit1.pas - Inicio

unit Unit1;

interface

uses

  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls;

type

  TForm1 = class(TForm)
    Timer1: TTimer;
    ListBox1: TListBox;
    procedure FormShow(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
  public
    lp : Integer;
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

function EnumProcess(hHwnd: HWND; lParam : integer): boolean; stdcall;
var
  pPid : DWORD;
  title, ClassName, Extra : string;
begin
  //Se retornar nulo, cancela e sai
  if (hHwnd=NULL) then
  begin
    result := false;
  end
  else
  begin
    //Pega o Numero Identificado Do Processo(PID)
    GetWindowThreadProcessId(hHwnd,pPid);
    //ClassName do Processo
    SetLength(ClassName, 255);
    SetLength(ClassName,
              GetClassName(hHwnd,
                           PChar(className),
                           Length(className)));
    SetLength(title, 255);
    //Titulo do Processo
    SetLength(title, GetWindowText(hHwnd, PChar(title), Length(title)));
    //Exibe a informação em uma lista (Componente Visual)
    Form1.ListBox1.Items.Add
      ('Class Name = ' + className +
       '; Title = ' + title +
       '; HWND = ' + IntToStr(hHwnd) +
       '; Pid = ' + IntToStr(pPid));
    Result := true;
  end;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  Timer1Timer(Self); 
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  ListBox1.Clear;
  if not EnumWindows(@EnumProcess,lp) then exit; // A cada 10 segundos exibe o q está em memória
end;

end.

//Unit1.pas Fim


// Unit1.dfm - Inicio (Form1)

object Form1: TForm1
  Left = 192
  Top = 114
  Width = 1179
  Height = 585
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnShow = FormShow
  PixelsPerInch = 96
  TextHeight = 13
  object ListBox1: TListBox
    Left = 0
    Top = 0
    Width = 1171
    Height = 551
    Align = alClient
    ItemHeight = 13
    TabOrder = 0
  end
  object Timer1: TTimer
    Interval = 10000
    OnTimer = Timer1Timer
    Left = 69
    Top = 33
  end
end
// Unit1.dfm - Fim (Form1)

sexta-feira, 22 de junho de 2012

DELPHI - Listando tamanho das áreas de trabalho - TScreen

Reações: 


// ATLabs 22-06-2012

procedure TForm1.FormCreate(Sender: TObject);
begin

  Label1.Caption := // Largura do monitor principal
                    ' Screen.Width: ' + IntToStr(Screen.Width)+ #13#10 +
                    //------------------------------------

                    // Largura Total de monitores, monitor[0].width + monitor[1].width), depende do posicionamento dos monitores (Top - Left - Bottom - Right)
                    ' Screen.DesktopWidth: ' + IntToStr(Screen.DesktopWidth)+ #13#10 +
                    //--------------------------------------------------------------

                    // Largura do monitor principal menos a largura da barra de iniciar (se estiver na vertical)
                    ' Screen.WorkAreaWidth: ' + IntToStr(Screen.WorkAreaWidth)+ #13#10 +
                    //------------------------------------------------------------------

                    // Largura do monitor 0
                    ' Screen.Monitors[0].Width: ' + IntToStr(Screen.Monitors[0].Width)+ #13#10 +
                    //---------------------

                    // Largura do monitor 1// Somente se tiver + de um monitor (este seria o segundo monitor)
                    ' Screen.Monitors[1].Width: ' + IntToStr(Screen.Monitors[1].Width)+ #13#10 +
                    //---------------------

                    // Altura do monitor principal
                    ' Screen.Height: ' + IntToStr(Screen.Height)+ #13#10 +
                    //----------------------------

                    // Maior Largura Total dos monitores, depende do posicionamento dos monitores  (Top - Left - Bottom - Right)
                    ' Screen.DesktopHeight: ' + IntToStr(Screen.DesktopHeight)+ #13#10 +
                    //------------------------------------------------------------------

                    // Altura do monitor principal menos a largura da barra de iniciar (se estiver na horizontal)
                    ' Screen.WorkAreaHeight: ' + IntToStr(Screen.WorkAreaHeight)+ #13#10 +
                    //--------------------------------------------------------------------


                    // Altura do monitor 0
                    ' Screen.Monitors[0].Height: ' + IntToStr(Screen.Monitors[0].Height)+ #13#10 +
                    //--------------------

                    // Altura do monitor 1 // Somente se tiver + de um monitor (este seria o segundo monitor)
                    ' Screen.Monitors[1].Height: ' + IntToStr(Screen.Monitors[1].Height);
                    //--------------------
end;

//Aconselho o teste dentro de uma Virtual Machine (VMWarePlayer) para conseguir simular casos de area de trabalho e multiplos monitores.


quinta-feira, 21 de junho de 2012

DELPHI - Altura da StartBar - Barra do Menu Iniciar

Reações: 


ShowMessage(IntToStr(Screen.DesktopHeight - Screen.WorkAreaHeight));

sábado, 2 de junho de 2012

DELPHI - Upload via Web Server Application - DELPHI

Reações: 


//ATLabs - Postado no site Planetadelphi.com.br - Quase 20.000 views

{
ATENÇÃO: POR MOTIVOS ÓBVIOS, SEMPRE TENTE UTILIZAR A VERSÃO MAIS ATUAL DO DELPHI PARA COMPILAÇÕES WEB, VOCÊ PODERÁ TER PROBLEMAS DE INCOMPATIBILIDADE COM O SERVIDOR DO IIS OU APACHE
// ULTIMO TESTE REALIZADO EM PLATAFORMA DELPHI XE
E LÁ VAMOS NÓS DE NOVO.
FIQUEI 4 DIAS PARA DESCOBRIR COMO FUNCIONA, E COMO O JÁ POSTADO
NOS MEUS OUTROS POSTS NÃO ENCONTREI NADA NA INTERNET DAI EU ME VIREI...
VOU INDICAR COMO SE FAZ UPLOAD DE ARQUIVO VIA WEB SERVER APPLICATION, TESTEI OS FONTES VIA ISAPI (*.DLL) E VIA CGI STAND-ALONE (*.EXE) E FUNCIONOU PERFEITAMENTE.
VAMOS DO COMEÇO, LEMBRANDO QUE EU NÃO VOU DAR DICAS DE HTML, VOU POSTAR SOMENTE O QUE PRECISA PARA QUE FUNCIONE, E
LEMBRANDO SEMPRE QUE EU POSTO O QUE JÁ ESTÁ EM PRATICA NOS MEUS FONTES, POR ESTE MOTIVO ELES FUNCIONAM:
O FORMULÁRIO DO HTML DEVE CONTER A SEGUINTE SINTAXE:
//    form enctype="multipart/form-data" method="post" runat="server" action="../appweb.exe/sobe_arq" name="f_envio">
REPARE NA OPÇÃO [enctype="multipart/form-data"] SE NÃO FOR DECLARADA NÃO FUNCIONA!!!!
SEGUE ABAIXO AS FUNCÕES PARA RESGATAR OS VALORES DO UPLOAD:
EXPLICAÇÃO:
// RETORNA OS VALORES DE CAMPOS DOS FORMULARIOS, DO TIPO TEXTFIELD POR EXEMPLO
function ValorCampoMultipartFormData(const Content: String; Chave,
  NomeCampo: String): String;
// RETORNA O VALOR DO NOME DO ARQUIVO ENVIADO PELO USUARIO FINAL, ELA NÃO RETORNA O CAMINHO, SOMENTE O VALOR
function NomeOriginalArqMultipartFormData(const Content: String; Chave: String): String;
// RETORNA O ARQUIVO EM UMA STRNG GIGANTESCA, SE FOR O CASO DE ARQUIVO ZIP POR EX.
function ValorArquivoMultipartFormData(const Content: String; Chave, TipoArquivo: String): String;
}

function ValorCampoMultipartFormData(const Content: String; Chave,
  NomeCampo: String): String;
Var
 S : String;
begin
// NO HTML INFORMAR:  form enctype="multipart/form-data" method="post" runat="server" action="[ACTION QUE PROCESSARÁ ESTE CODIGO]">
// REPARE NA OPÇÃO ENCTYPE="MULTPART/FORM-DATA" METHOD="POST" ELA QUE IRÁ PASSAR A INFORMAÇÃO DO ARQUIVO DE UPLOAD, SEM ELA O HTML NÃO ENVIA O ARQUIVO PARA A MEMORIA DO SERVIDOR
// Content => PASSAR O VALOR DE REQUEST.CONTENT;
// Chave => PASSAR O VALOR DE REQUEST.CONTENTFIELDS.STRINGS[0]; // ZERO PORQUE ELE IRÁ RETORNAR NA POSIÇÃO ZERO A CHAVE DE IDENTIFICAÇÃO DAKELE POST
// NomeCampo => NOME DO TEXTFIELD QUE SE DESEJA RESGATAR A INFORMAÇÃO
S := Content;
Delete(S, 1, pos(NomeCampo, S) + length(NomeCampo) + 1);
Result := copy(S, 1, pos(Chave, S) - 2);
end;

function NomeOriginalArqMultipartFormData(const Content: String; Chave: String): String;
Var
 S : String;
begin

// NO HTML INFORMAR: form enctype="multipart/form-data" method="post" runat="server" action="[ACTION QUE PROCESSARÁ ESTE CODIGO]">
// REPARE NA OPÇÃO ENCTYPE="MULTPART/FORM-DATA" METHOD="POST" ELA QUE IRÁ PASSAR A INFORMAÇÃO DO ARQUIVO DE UPLOAD, SEM ELA O HTML NÃO ENVIA O ARQUIVO PARA A MEMORIA DO SERVIDOR
// Content => PASSAR O VALOR DE REQUEST.CONTENT;
// Chave => PASSAR O VALOR DE REQUEST.CONTENTFIELDS.STRINGS[0]; // ZERO PORQUE ELE IRÁ RETORNAR NA POSIÇÃO ZERO A CHAVE DE IDENTIFICAÇÃO DAKELE POST
S := Content;
Delete(S, 1, pos('filename', S) + length('filename') + 1);
Result := copy(S, 1, pos('Content-Type:', S) - 4);
end;

function ValorArquivoMultipartFormData(const Content: String; Chave, TipoArquivo: String): String;
Var
 S : String;
begin
// NO HTML INFORMAR: form enctype="multipart/form-data" method="post" runat="server" action="[ACTION QUE PROCESSARÁ ESTE CODIGO]">
// REPARE NA OPÇÃO ENCTYPE="MULTPART/FORM-DATA" METHOD="POST" ELA QUE IRÁ PASSAR A INFORMAÇÃO DO ARQUIVO DE UPLOAD, SEM ELA O HTML NÃO ENVIA O ARQUIVO PARA A MEMORIA DO SERVIDOR
// Content => PASSAR O VALOR DE REQUEST.CONTENT;
// Chave => PASSAR O VALOR DE REQUEST.CONTENTFIELDS.STRINGS[0]; // ZERO PORQUE ELE IRÁ RETORNAR NA POSIÇÃO ZERO A CHAVE DE IDENTIFICAÇÃO DAKELE POST
// TipoArquivo => PASSAR O VALOR DE REQUEST.CONTENTFIELDS.STRINGS[3]; // RETORNA O VALOR: EX.:  "Content-Type: application/octet-stream" - OBS. SEM AS ASPAS
// CASO O VALOR NÃO SEJA DA 3ª STRING, FAÇA UM LOOPING PARA PEGAR O TEXTO "Content-Type:" DENTRO DA OPÇÃO CONTENTFIELDS DO REQUEST
// ContentField2 => PASSAR O VALOR DE REQUEST.CONTENTFIELDS.STRINGS[2]; // RETORNA O VALOR: EX.:  [filename="acordosg.sql"] - OBS. SEM AS CHAVES
S := Content;
Delete(S, 1, pos(TipoArquivo, S) + length(TipoArquivo) + 3);
Result := copy(S, 1, pos(Chave, S) - 3);
end;

{
INFORMANDO ESTAS FUNÇÕES NA APLICAÇÃO EU VOU EXPLICAR SOMENTE A VALOR DO ARQUIVO, POIS ELA É A UNICA MAIS CRITICA PARA EXPLICAÇÃO.
COLOQUE UMA NOVA WEBACTION (QUE VAR SER A AÇÃO DO FORMULÁRIO JÁ DESCRITO COM O ENCTYPE)
DECLARE AS VARIAVEIS: }

VAR
F : File;
Arq, LocalArqUpLoad,
ContType : String;
TamArq, TamW, I : Integer;
BEGIN
  try
  ContType := '';
  for i := 0 to Request.ContentFields.Count - 1 do
   begin
    if pos('Content-Type:', Request.ContentFields.Strings[i]) > 0 then
     ContType := Request.ContentFields.Strings[i];
   end; 
   LocalArqUpLoad := 'C:TMP';
   Arq := ValorArquivoMultipartFormData(Request.Content, Request.ContentFields.Strings[0], ContType);
   TamArq := Length(Arq);
   AssignFile(F, LocalArqUpLoad + NomeOriginalArqMultipartFormData(Request.Content, Request.ContentFields.Strings[0]));
   Rewrite(F, 1);
   for TamW := 1 to TamArq do
    begin
     BlockWrite(F, arq[TamW], 1);
    end;
 finally
  CloseFile(f);
 end;
 RESPONSE.CONTENT := 'UPLOAD EFETUADO COM SUCESSO!!!';
 HANDLED := TRUE;
END;

{AS OUTRAS FUNÇÕES VÃO SER PASSADAS CONFORME O DESCRITO NA EXPLICAÇÃODE CADA FUNÇÃO
ESPERO TER AJUDADO E VOTEM NA DICA, CASO VOCÊS NÃO TENHAM ENTENDIDO, POR FAVOR NÃO PONTUE O POST COM UM VALOR BAIXO
ATT. FELIPE LEAL
}
//-----------------------

DELPHI - Boleto - Codigo de Barras e Linha Digitavel

Reações: 


// ATLabs - Postado no site planetadelphi.com.br + de 35.000  views - Gostaria da divisão de lucros dos ADSENSE da pagina que foi postada
{
Saudações queridos colegas programadores;
Já que não achei nenuma solução na web que funcionasse corretamente, decidi criar a minha baseada no componente de boletos da GBSoft
Creio que baixei este componente aqui da do site do planeta delphi...
Esta dica contém as funções/procedures abaixo:
Modulo10, Modulo11, Formatar, CalcularFatorVencimento, CorrigeSTR, GeraCodBarras, GeraLinhaDigitavel
Para explicar melhor para aqueles que vão ler esta mensagem:
Primeiro gera-se o código de barras depois gera-se a linha digitável, um depende do outro
}

///////////// Inicio - retirados do componente da GBSoft

function Modulo10(Valor: String) : string;
{
   Rotina usada para cálculo de alguns dígitos verificadores
   Pega-se cada um dos dígitos contidos no parâmetro VALOR, da direita para a
   esquerda e multiplica-se por 2121212...
   Soma-se cada um dos subprodutos. Caso algum dos subprodutos tenha mais de um
   dígito, deve-se somar cada um dos dígitos. (Exemplo: 7*2 = 14 >> 1+4 = 5)
   Divide-se a soma por 10.
   Faz-se a operação 10-Resto da divisão e devolve-se o resultado dessa operação
   como resultado da função Modulo10.
   Obs.: Caso o resultado seja maior que 9, deverá ser substituído por 0 (ZERO).
}

var

   Auxiliar : string;
   Contador, Peso : integer;
   Digito : integer;
begin
   Auxiliar := '';
   Peso := 2;
   for Contador := Length(Valor) downto 1 do
   begin
      Auxiliar := IntToStr(StrToInt(Valor[Contador]) * Peso) + Auxiliar;
      if Peso = 1 then
         Peso := 2
      else
         Peso := 1;
   end;
   Digito := 0;
   for Contador := 1 to Length(Auxiliar) do
   begin
      Digito := Digito + StrToInt(Auxiliar[Contador]);
   end;
   Digito := 10 - (Digito mod 10);
   if (Digito > 9) then
      Digito := 0;
   Result := IntToStr(Digito);
end;

function Modulo11(Valor: String; Base: Integer = 9; Resto : boolean = false) : string;
{
   Rotina muito usada para calcular dígitos verificadores
   Pega-se cada um dos dígitos contidos no parâmetro VALOR, da direita para a
   esquerda e multiplica-se pela seqüência de pesos 2, 3, 4 ... até BASE.
   Por exemplo: se a base for 9, os pesos serão 2,3,4,5,6,7,8,9,2,3,4,5...
   Se a base for 7, os pesos serão 2,3,4,5,6,7,2,3,4...
   Soma-se cada um dos subprodutos.
   Divide-se a soma por 11.
   Faz-se a operação 11-Resto da divisão e devolve-se o resultado dessa operação
   como resultado da função Modulo11.
   Obs.: Caso o resultado seja maior que 9, deverá ser substituído por 0 (ZERO).
}
var
   Soma : integer;
   Contador, Peso, Digito : integer;
begin
   Soma := 0;
   Peso := 2;
   for Contador := Length(Valor) downto 1 do
   begin
      Soma := Soma + (StrToInt(Valor[Contador]) * Peso);
      if Peso < Base then
         Peso := Peso + 1
      else
         Peso := 2;
   end;
   if Resto then
      Result := IntToStr(Soma mod 11)
   else
   begin
      Digito := 11 - (Soma mod 11);
      if (Digito > 9) then
         Digito := 0;
      Result := IntToStr(Digito);
   end
end;

function Formatar(Texto : string; TamanhoDesejado : integer; AcrescentarADireita : boolean = true; CaracterAcrescentar : char = ' ') : string;
{
   OBJETIVO: Eliminar caracteres inválidos e acrescentar caracteres à esquerda ou à direita do texto original para que a string resultante fique com o tamanho desejado
   Texto : Texto original
   TamanhoDesejado: Tamanho que a string resultante deverá ter
   AcrescentarADireita: Indica se o carácter será acrescentado à direita ou à esquerda
      TRUE - Se o tamanho do texto for MENOR que o desejado, acrescentar carácter à direita
             Se o tamanho do texto for MAIOR que o desejado, eliminar últimos caracteres do texto
      FALSE - Se o tamanho do texto for MENOR que o desejado, acrescentar carácter à esquerda
             Se o tamanho do texto for MAIOR que o desejado, eliminar primeiros caracteres do texto
   CaracterAcrescentar: Carácter que deverá ser acrescentado
}
var
   QuantidadeAcrescentar,
   TamanhoTexto,
   PosicaoInicial,
   i : integer;
begin
   case CaracterAcrescentar of
      '0'..'9','a'..'z','A'..'Z' : ;{Não faz nada}
      else
         CaracterAcrescentar := ' ';
   end;
   Texto := Trim(AnsiUpperCase(Texto));
   TamanhoTexto := Length(Texto);
   for i := 1 to (TamanhoTexto) do
   begin
      if Pos(Texto[i],' 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ`~''"!@#$%^&*()_-+=|/{}[]:;,.<>') = 0 then
      begin
         case Texto[i] of
            'Á','À','Â','Ä','Ã' : Texto[i] := 'A';
            'É','È','Ê','Ë' : Texto[i] := 'E';
            'Í','Ì','Î','Ï' : Texto[i] := 'I';
            'Ó','Ò','Ô','Ö','Õ' : Texto[i] := 'O';
            'Ú','Ù','Û','Ü' : Texto[i] := 'U';
            'Ç' : Texto[i] := 'C';
            'Ñ' : Texto[i] := 'N';
            else Texto[i] := ' ';
         end;
      end;
   end;
   QuantidadeAcrescentar := TamanhoDesejado - TamanhoTexto;
   if QuantidadeAcrescentar < 0 then
      QuantidadeAcrescentar := 0;
   if CaracterAcrescentar = '' then
      CaracterAcrescentar := ' ';
   if TamanhoTexto >= TamanhoDesejado then
      PosicaoInicial := TamanhoTexto - TamanhoDesejado + 1
   else
      PosicaoInicial := 1;
   if AcrescentarADireita then
      Texto := Copy(Texto,1,TamanhoDesejado) + StringOfChar(CaracterAcrescentar,QuantidadeAcrescentar)
   else
      Texto := StringOfChar(CaracterAcrescentar,QuantidadeAcrescentar) + Copy(Texto,PosicaoInicial,TamanhoDesejado);
   Result := AnsiUpperCase(Texto);
end;
function CalcularFatorVencimento(DataDesejada : TDateTime) : string;
{O fator de vencimento é a quantidade de dias entre 07/Nov/1997 e a data de vencimento do título}
begin
   Result := IntToStr( Trunc(DataDesejada - EncodeDate(1997,10,07)));
end;
///////////// Fim - retirados do componente da GBSoft

function CorrigeSTR(Str : string; CaracTroca : string; CaracNovo : string) : string;
var i, int : integer;
S : string;
begin
i := 0;
int := 0;
 while i <= length(str) do
 begin
  if copy(Str,i,1) = CaracTroca then
   begin
    Delete(Str,i,1);
    s := copy(Str,1,i-1) + CaracNovo + copy(Str,i , length(str) - i + 1);
    str := s;
    inc(i);
    inc(int);
   end;
 inc(i);
 end;
 if int <> 0 then
 result := s
 else
 result := str;
end;

Function StrZero(S: String; Tam: Integer): String;
var
   wZeros : String;
   wCont  : Integer;
begin
wCont := 0;
wZeros := '';
     for wCont := 1 to tam - length(s) do
         wZeros := '0' + wZeros;
   Result := wZeros + S;
end;
/////////////////Inicio - Função alterada do componente da GBSoft

function GeraCodBarras(Banco, Moeda, AG, Operacao, Carteira, NNumero, Valor, Vencto: String):String;
var
AFatorVencimento, ACampoLivre, ACodigoBarras, ADigitoCodigoBarras : string;
begin
   {Primeira parte do código de barras}
   AFatorVencimento := Formatar(CalcularFatorVencimento(StrToDate(Vencto)),4,false,'0');
   //Valor; {Formata o valor com 10 dígitos, incluindo as casas decimais, mas não mostra o ponto decimal}
   {Segunda parte do código de barras - Campo livre - Varia de acordo com o banco}
   ACampoLivre := StrZero(AG,4) +
                  StrZero(Carteira,3) +
                  StrZero(Operacao,7) +
                  StrZero(NNumero +  Modulo10(AG + Carteira + NNumero),11);
   {Calcula o dígito e completa o código de barras}
   ACodigoBarras := StrZero(Banco,3) +
                    StrZero(Moeda,1) +
                    StrZero(AFatorVencimento,4) +
                    StrZero(CorrigeSTR(Valor,',',''),10) +
                    ACampoLivre;
   ADigitoCodigoBarras := Modulo11(ACodigoBarras,9);
   if ADigitoCodigoBarras = '0' then
      ADigitoCodigoBarras := '1';
   Result := Copy(ACodigoBarras,1,4) + ADigitoCodigoBarras + Copy(ACodigoBarras,5,length(ACodigoBarras)-4);
// *)
end;

function GeraLinhaDigitavel(Banco, Moeda, AG, Operacao, Carteira, NNumero, Valor, Vencto : string):String;
var
   p1, p2, p3, p4, p5, p6,
   Campo1, Campo2, Campo3, Campo4, Campo5,
   Codigo : string;
begin
  Codigo := GeraCodBarras(Banco, Moeda, AG, Operacao, Carteira, NNumero, Valor, Vencto);
   p1 := Copy(Codigo,1,4);
   p2 := Copy(Codigo,20,5);
   p3 := Modulo10(p1+p2);
   p4 := p1+p2+p3;
   p5 := Copy(p4,1,5);
   p6 := Copy(p4,6,5);
   Campo1 := p5+'.'+p6;
   {
      Campo 2 - composto pelas posiçoes 6 a 15 do campo livre
      e DV (modulo10) deste campo
   }
   p1 := Copy(Codigo,25,10);
   p2 := Modulo10(p1);
   p3 := p1+p2;
   p4 := Copy(p3,1,5);
   p5 := Copy(p3,6,6);
   Campo2 := p4+'.'+p5;
   {
      Campo 3 - composto pelas posicoes 16 a 25 do campo livre
      e DV (modulo10) deste campo
   }
   p1 := Copy(Codigo,35,10);
   p2 := Modulo10(p1);
   p3 := p1+p2;
   p4 := Copy(p3,1,5);
   p5 := Copy(p3,6,6);
   Campo3 := p4+'.'+p5;
   {
      Campo 4 - digito verificador do codigo de barras
   }
   Campo4 := Copy(Codigo,5,1);
   {
      Campo 5 - composto pelo valor nominal do documento, sem indicacao
      de zeros a esquerda e sem edicao (sem ponto e virgula). Quando se
      tratar de valor zerado, a representacao deve ser 000 (tres zeros).
   }
   Campo5 := Copy(Codigo,6,14);
   Result := Campo1 + ' ' + Campo2 + ' ' + Campo3 + ' ' + Campo4 + ' ' + Campo5;
End;

/////////////////Fim - Função alterada do componente da GBSoft
{
Vou dar o resultado da linha digitavel com os seguintes parametros:
Banco = 623
Moeda = 9 // 9 para real (creio que seja para a moeda local), e 0 para outras
AG = 1
Operacao = 27
Carteira = 121
NNumero = 0260279393

Valor = 153,39
Vencto = 21/09/2009
Linha digitavel = 62390.00117 21000.002705 26027.939367 1 43670000015339
Cod de barras = 62391436700000153390001121000002702602793936
Obs.
No rave reports o código de barras de nome "I2of5BarCode" é o código de barras do boleto
ele está na guia "Bar Code" ele é o segundo item
bem, o resto agora é voce colocar os valores da variavél as funcoes:
GeraCodBarras e GeraLinhaDigitavel e exibi-las
Separei as funções pois fica a critério da pessoa enviar o boleto com o código de barras ou informar somente a linha digitável (via fone por ex)
Espero que tenham gostado.
Atte:
Felipe Leal
}
//-------------- 

DELPHI - Ping com IdIcmpClient (Indy 10) - Plataformas aceitas: Win32, Win64, Android, OS X, iOS

Reações: 


// Corrigida em 14-06-2012 - Testada na mesma data


unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  IdBaseComponent, IdComponent // Objeto Base Indy
  , IdRawBase, IdRawClient, IdIcmpClient, // Objeto para Ping
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    _PingOK : Boolean;
    procedure ICMPStatus(ASender: TObject; const AStatus: TIdStatus; const                 AStatusText: string);
    procedure ICMPReply(ASender: TComponent; const AReplyStatus: TReplyStatus);

    Function Ping(HostName: String): boolean;
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation


{$R *.dfm}
procedure TForm1.ICMPReply(ASender: TComponent;
  const AReplyStatus: TReplyStatus);
begin
  try
    if AReplyStatus.BytesReceived > 0 then    
    _PingOK := True
    else
    _PingOK := False;
  except
    _PingOK := False;
  end;
end;


procedure TForm1.ICMPStatus(ASender: TObject; const AStatus: TIdStatus;
  const AStatusText: string);
begin
  Exit;
  try
    _PingOK := True;
  except
    _PingOK := False;
  end;
end;

Function TForm1.Ping(HostName: String): boolean;
var
 ICMP : TIdIcmpClient;
begin
try

  ICMP := TIdIcmpClient.Create(Application);
  try
   ICMP.OnStatus       := Form1.ICMPStatus;
   ICMP.OnReply        := Form1.ICMPReply;
   ICMP.Host           := HostName;
   ICMP.ReceiveTimeout := 500;
   ICMP.port           := 80;
    {$IFDEF ANDROID}
     {$DEFINE LINUX}
       ICMP.Ping;
     {$UNDEF LINUX}
   {$ELSE}
     ICMP.Ping;
   {$ENDIF}
   Sleep(1);
   Application.ProcessMessages;
   Result := _PingOK;
  except
   result := false;
  end;

finally
 FreeAndNil(ICMP);
end;

rnd;


procedure TForm1.Button1Click(Sender: TObject);
const
  Host = 'www.google.com.br';
begin
 if Ping(Host) then
 showmessage(host + ' OK')
 else
  showmessage(host + ' ERR');
end;

end.
//-------------

DELPHI - Acesso ao ClipBoard

Reações: 


// ATLabs 02/06/2012

// Lendo a area de transferencia do pc:
// Declarar na USES:
Clipbrd
//Para acessar basta ler o objeto:

ClipBoard.AsText;
//ou
ClipBoard.Assign(image1.picture);
//----------------------

sexta-feira, 1 de junho de 2012

DELPHI - Validação de endereço de E-Mail

Reações: 


// ATLabs 01-06-2012
function ValidaEnderecoEMailATLabs(S: String): Boolean;
var
  X : String;
  I : Integer;
begin
  Result := True;
  if S = '' then exit;
  i := 0;
  X := S;
  while (Pos('@', X) > 0) do
  begin
    X := StringReplace(X, '@', '', [rfIgnoreCase]);
    Inc(i);
  end;
  if  (Pos(' ', S) > 0) // Espaco
   or (Pos('@', S) = 0) // @
   or (Pos('.', S) = 0) // Ponto
   or (Copy(S, 1, 1) = '@') // Item antes do @
   or (Copy(S, Pos('@', S) + 1, 1) = '') // Item pos  @
   or (Copy(S, Pos('.', S) - 1, 1) = '@') // Item antes do .
   or (Copy(S, Pos('.', S) + 1, 1) = '') // Item Pos .
   or (Pos('.', Copy(S, Pos('@', S) + 1, Length(S))) = 0) // valida . depois do @
   or (I > 1) // I Conta a quantidade de @ no texto
   then
  begin
    Result := False;
    ShowMessage('O formato de endereço de E-Mail deve seguir o seguinte padrão: "usuario@dominio.ext". Cancelado.');
  end;
end;
//-----------------

Max Gehringer