ActiveDelphi - Índice do Fórum ActiveDelphi
.: O site do programador Delphi! :.
 
 FAQFAQ   PesquisarPesquisar   MembrosMembros   GruposGrupos   RegistrarRegistrar 
 PerfilPerfil   Entrar e ver Mensagens ParticularesEntrar e ver Mensagens Particulares   EntrarEntrar 

Dicas para ajudar todos (Colaborem postando suas rotinas)
Ir à página Anterior  1, 2, 3 ... , 14, 15, 16  Próximo
 
Novo Tópico   Responder Mensagem    ActiveDelphi - Índice do Fórum -> Delphi
Exibir mensagem anterior :: Exibir próxima mensagem  
Autor Mensagem
natanbh1
Colaborador
Colaborador


Registrado: Terça-Feira, 15 de Março de 2011
Mensagens: 2898
Localização: Belo Horizonte - MG

MensagemEnviada: Qua Ago 10, 2016 10:51 am    Assunto: Responder com Citação

Formatar Valor estilo Caixa Eletrônico

Esta rotina formata valor como nos caixas eletrônicos, a digitação vem da direita para a esquerda.
Sendo permitida a entrada somente de números e acrescentado, automaticamente, os separadores de milhar e decimais.

Adicione StrUtils na uses do form.

Código:
function FormatarMoeda(valor: string): string;
var
  decimais, centena, milhar, milhoes, bilhoes, trilhoes, quadrilhoes: string;
  i: Integer;
begin
  Result := EmptyStr;

  for i := 0 to Length(valor) - 1 do
    if not(valor[i] in ['0' .. '9']) then
      delete(valor, i, 1);

  if copy(valor, 1, 1) = '0' then
    valor := copy(valor, 2, Length(valor));

  decimais := RightStr(valor, 2);
  centena := copy(RightStr(valor, 5), 1, 3);
  milhar := copy(RightStr(valor, 8), 1, 3);
  milhoes := copy(RightStr(valor, 11), 1, 3);
  bilhoes := copy(RightStr(valor, 14), 1, 3);
  trilhoes := copy(RightStr(valor, 17), 1, 3);
  quadrilhoes := LeftStr(valor, Length(valor) - 17);

  case Length(valor) of
    1:
      Result := '0,0' + valor;
    2:
      Result := '0,' + valor;
    6 .. 8:
      begin
        milhar := LeftStr(valor, Length(valor) - 5);
        Result := milhar + '.' + centena + ',' + decimais;
      end;
    9 .. 11:
      begin
        milhoes := LeftStr(valor, Length(valor) - 8);
        Result := milhoes + '.' + milhar + '.' + centena + ',' + decimais;
      end;
    12 .. 14:
      begin
        bilhoes := LeftStr(valor, Length(valor) - 11);
        Result := bilhoes + '.' + milhoes + '.' + milhar + '.' + centena + ',' + decimais;
      end;
    15 .. 17:
      begin
        trilhoes := LeftStr(valor, Length(valor) - 14);
        Result := trilhoes + '.' + bilhoes + '.' + milhoes + '.' + milhar + '.' + centena + ','
          + decimais;
      end;
    18 .. 20:
      begin
        quadrilhoes := LeftStr(valor, Length(valor) - 17);
        Result := quadrilhoes + '.' + trilhoes + '.' + bilhoes + '.' + milhoes + '.' + milhar + '.'
          + centena + ',' + decimais;
      end
  else
    Result := LeftStr(valor, Length(valor) - 2) + ',' + decimais;
  end;
end;


Exemplo de uso, coloque no evento OnChange do Edit o código:

Código:
Edit1.Text := FormatarMoeda(Edit1.Text);
Edit1.SelStart := Length(Edit1.Text);

_________________
''A persistência é o caminho para o êxito.''
Charlie Chaplin


Editado pela última vez por natanbh1 em Sex Nov 25, 2016 8:56 am, num total de 1 vez
Voltar ao Topo
Ver o perfil de Usuários Enviar Mensagem Particular Enviar E-mail
renanbg
Colaborador
Colaborador


Registrado: Quinta-Feira, 12 de Abril de 2012
Mensagens: 1155

MensagemEnviada: Qui Set 08, 2016 5:28 pm    Assunto: Responder com Citação

Legal a dica natanbh1.

No meu delphi xe 10.1 não consigo compilar.

Código:
Undeclared identifier: 'RightStr'
Voltar ao Topo
Ver o perfil de Usuários Enviar Mensagem Particular
natanbh1
Colaborador
Colaborador


Registrado: Terça-Feira, 15 de Março de 2011
Mensagens: 2898
Localização: Belo Horizonte - MG

MensagemEnviada: Qui Set 08, 2016 5:38 pm    Assunto: Responder com Citação

Esqueci de mencionar:

Adicione StrUtils na uses do form.
_________________
''A persistência é o caminho para o êxito.''
Charlie Chaplin
Voltar ao Topo
Ver o perfil de Usuários Enviar Mensagem Particular Enviar E-mail
renanbg
Colaborador
Colaborador


Registrado: Quinta-Feira, 12 de Abril de 2012
Mensagens: 1155

MensagemEnviada: Sex Set 09, 2016 1:24 pm    Assunto: Responder com Citação

Hum, agora sim executa.
O unico porem é que se o valor for na casa de milhar, ex: 1.200,00, gera erro ao gravar no banco.
Voltar ao Topo
Ver o perfil de Usuários Enviar Mensagem Particular
leo_cj
Colaborador
Colaborador


Registrado: Sábado, 26 de Março de 2011
Mensagens: 1335

MensagemEnviada: Sex Set 09, 2016 1:43 pm    Assunto: Responder com Citação

renanbg escreveu:
Hum, agora sim executa.
O unico porem é que se o valor for na casa de milhar, ex: 1.200,00, gera erro ao gravar no banco.


Provavelmente o erro ocorre pois você está tentando salvar com o separador de milhar, para salvar no banco tenta remover os pontos, deixando apenas a virgula

ex: 1200,00
Voltar ao Topo
Ver o perfil de Usuários Enviar Mensagem Particular
natanbh1
Colaborador
Colaborador


Registrado: Terça-Feira, 15 de Março de 2011
Mensagens: 2898
Localização: Belo Horizonte - MG

MensagemEnviada: Sex Set 09, 2016 2:14 pm    Assunto: Responder com Citação

Esta formatação é apenas para exibição. Se for gravar no banco, retire os pontos dos milhares com StringReplace.

Exemplo:
Código:
var
  Valor: string;
begin
  Valor := '1.200,00';
  Valor := StringReplace(Valor, '.', '', [rfReplaceAll, rfIgnoreCase]);
  ShowMessage(Valor); // Retorna 1200,00
end;

_________________
''A persistência é o caminho para o êxito.''
Charlie Chaplin
Voltar ao Topo
Ver o perfil de Usuários Enviar Mensagem Particular Enviar E-mail
marcieldeg
Colaborador
Colaborador


Registrado: Terça-Feira, 5 de Abril de 2011
Mensagens: 1015
Localização: Vitória - ES

MensagemEnviada: Sáb Set 17, 2016 9:42 pm    Assunto: Responder com Citação

Precisei criar uma série de classes para mapear objetos JSON. Para não criar uma a uma, criei a função abaixo. Ela lê o JSON e gera classes básicas em Delphi.

Foi feito pra um único uso, então não esperem um código bonito rs.

Delphi 2010.

Código:
unit UJSONToClass;

interface

function Convert(AClassName, AJsonText: String): String;

implementation

uses
  SysUtils, Classes, DBXJSON, Generics.Collections;

function Capitalize(Text: String): String;
begin
  Result := Text;
  if Result <> '' then
    Result := AnsiUpperCase(Copy(Result, 1, 1)) + Copy(Result, 2, Length(Result));
end;

function WorkAroundJsonStr(AJson: String): String;
begin
  Result := StringReplace(AJson, #13#10, '', [rfReplaceAll]);
  Result := StringReplace(Result, ' :', ':', [rfReplaceAll]);
  Result := StringReplace(Result, ': ', ':', [rfReplaceAll]);
end;

function Convert(AClassName, AJsonText: String): String;
var
  Json: TJSONObject;
  JsonPair: TJSONPair;
  JsonValue: TJSONValue;
  i: Integer;

  Subclasses: TList<String>;
  Subclass: String;

  PrivateSession, PublicSession: TStringBuilder;
  CapName, Subtype: String;
begin
  Subclasses := TList<String>.Create;
  PrivateSession := TStringBuilder.Create;
  PublicSession := TStringBuilder.Create;

  Json := TJSONObject.ParseJSONValue(TEncoding.ASCII.GetBytes(WorkAroundJsonStr(AJsonText)), 0) as TJSONObject;

  for i := 0 to Json.Size - 1 do
  begin
    JsonPair := Json.Get(i);
    CapName := Capitalize(JsonPair.JsonString.Value);
    PrivateSession.Append('    F' + CapName);
    PublicSession.Append('    property ' + CapName);

    if JsonPair.JsonValue is TJSONNumber then
    begin
      PrivateSession.Append(': Double;' + #13#10);
      PublicSession.Append(': Double read F' + CapName + ' write F' + CapName + ';' + #13#10);
    end
    else if JsonPair.JsonValue is TJSONString then
    begin
      PrivateSession.Append(': String;' + #13#10);
      PublicSession.Append(': String read F' + CapName + ' write F' + CapName + ';' + #13#10);
    end
    else if JsonPair.JsonValue is TJSONArray then
    begin
      if TJSONArray(JsonPair.JsonValue).Size > 0 then
      begin
        JsonValue := TJSONArray(JsonPair.JsonValue).Get(0);
        if JsonValue is TJSONNumber then
          Subtype := 'Double'
        else if JsonValue is TJSONString then
          Subtype := 'String'
        else if (JsonValue is TJSONTrue) or (JsonValue is TJSONFalse) then
          Subtype := 'Boolean'
        else if JsonValue is TJSONObject then
        begin
          Subtype := 'T' + Capitalize(JsonPair.JsonString.Value);
          Subclasses.Add(Convert(JsonPair.JsonString.Value, JsonValue.ToString));
        end;
      end;
      PrivateSession.Append(': TList<' + Subtype + '>;' + #13#10);
      PublicSession.Append(': TList<' + Subtype + '> read F' + CapName + ' write F' + CapName + ';' + #13#10);
    end
    else if (JsonPair.JsonValue is TJSONTrue) or (JsonPair.JsonValue is TJSONFalse) then
    begin
      PrivateSession.Append(': Boolean;' + #13#10);
      PublicSession.Append(': Boolean read F' + CapName + ' write F' + CapName + ';' + #13#10);
    end
    else if JsonPair.JsonValue is TJSONNull then
    begin
      PrivateSession.Append(': TObject;' + #13#10);
      PublicSession.Append(': TObject read F' + CapName + ' write F' + CapName + ';' + #13#10);
    end
    else if JsonPair.JsonValue is TJSONObject then
    begin
      PrivateSession.Append(': T' + Capitalize(JsonPair.JsonString.Value) + ';' + #13#10);
      PublicSession.Append(': T' + Capitalize(JsonPair.JsonString.Value)
          + ' read F' + CapName + ' write F' + CapName + ';' + #13#10);
      Subclasses.Add(Convert(JsonPair.JsonString.Value, JsonPair.JsonValue.ToString));
    end;
  end;

  Result := '  T' + Capitalize(AClassName) + ' = class;' + #13#10;
  Result := Result + '  private' + #13#10;
  Result := Result + PrivateSession.ToString;
  Result := Result + '  public' + #13#10;
  Result := Result + PublicSession.ToString;
  Result := Result + '  end;' + #13#10;

  for Subclass in Subclasses do
    Result := Result + #13#10 + Subclass;
end;

end.



Exemplo de arquivo de entrada:
Código:
{"id":"001","name":"Bulbasaur","types":["Grass","Poison"],"genre":2,"evolveTo":
{"level":16,"id":"002"},"attributes":
{"hp":45,"attack":49,"defense":49,"spAttack":65,"spDefense":65,"speed":45,"exp":64},"moves":
[{"level":0,"name":"Tackle"},{"level":4,"name":"Growl"},{"level":7,"name":"LeechSeed"},
{"level":10,"name":"VineWhip"},{"level":15,"name":"PoisonPowder"},{"level":15,"name":"SleepPowder"},
{"level":20,"name":"RazorLeaf"},{"level":25,"name":"SweetScent"},{"level":32,"name":"Growth"},
{"level":39,"name":"Synthesis"},{"level":46,"name":"SolarBeam"}]}


Saída:
Código:
  TTeste = class;
  private
    FId: String;
    FName: String;
    FTypes: TList<String>;
    FGenre: Double;
    FEvolveTo: TEvolveTo;
    FAttributes: TAttributes;
    FMoves: TList<TMoves>;
  public
    property Id: String read FId write FId;
    property Name: String read FName write FName;
    property Types: TList<String> read FTypes write FTypes;
    property Genre: Double read FGenre write FGenre;
    property EvolveTo: TEvolveTo read FEvolveTo write FEvolveTo;
    property Attributes: TAttributes read FAttributes write FAttributes;
    property Moves: TList<TMoves> read FMoves write FMoves;
  end;

  TEvolveTo = class;
  private
    FLevel: Double;
    FId: String;
  public
    property Level: Double read FLevel write FLevel;
    property Id: String read FId write FId;
  end;

  TAttributes = class;
  private
    FHp: Double;
    FAttack: Double;
    FDefense: Double;
    FSpAttack: Double;
    FSpDefense: Double;
    FSpeed: Double;
    FExp: Double;
  public
    property Hp: Double read FHp write FHp;
    property Attack: Double read FAttack write FAttack;
    property Defense: Double read FDefense write FDefense;
    property SpAttack: Double read FSpAttack write FSpAttack;
    property SpDefense: Double read FSpDefense write FSpDefense;
    property Speed: Double read FSpeed write FSpeed;
    property Exp: Double read FExp write FExp;
  end;

  TMoves = class;
  private
    FLevel: Double;
    FName: String;
  public
    property Level: Double read FLevel write FLevel;
    property Name: String read FName write FName;
  end;
Voltar ao Topo
Ver o perfil de Usuários Enviar Mensagem Particular
x7r3m3x
Aprendiz
Aprendiz


Registrado: Sexta-Feira, 7 de Fevereiro de 2014
Mensagens: 177

MensagemEnviada: Qua Set 28, 2016 4:36 am    Assunto: Solução com um bug no TOpenPictureDialog Responder com Citação

Olá Pessoal,

Eu estou postando aqui uma solução no qual demorei para encontrar e após muita procura consegui encontrar a solução em um fórum americano.

Um bug que ocorre na ferramenta TOpenPictureDialog no qual na hora da execução não aparece as extenções jpg, jpeg e acaba ocorrendo o seguinte erro:
Citação:
Unknown picture file extension (.jpg)


Solução:
Basta acrescentar um jpeg na uses do seu formulário onde está sendo utilizando a ferramenta.

Exemplo:
Código:

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, jpeg;


Espero ter ajudado!
Voltar ao Topo
Ver o perfil de Usuários Enviar Mensagem Particular
marcieldeg
Colaborador
Colaborador


Registrado: Terça-Feira, 5 de Abril de 2011
Mensagens: 1015
Localização: Vitória - ES

MensagemEnviada: Seg Out 03, 2016 1:25 pm    Assunto: Responder com Citação

Função para gerar senha mnemônica.

Se você usa um algoritmo para gerar senhas provisórias, uma ideia interessante é utilizar o método abaixo. Ele gera uma "palavra" como senha, não necessariamente existente, mas que é bem mais fácil de ser memorizada do que uma senha totalmente randômica:

Código:
function GeraSenha: String;
const
  a1: array [0 .. 27] of String = ('b', 'c', 'd', 'f', 'g', 'j', 'l', 'm', 'n', 'p', 'qu', 'r', 's', 't', 'v', 'x',
    'z', 'ch', 'lh', 'nh', 'br', 'cr', 'fr', 'gr', 'gl', 'pr', 'pl', 'tr');
  a2: array [0 .. 4] of String = ('a', 'e', 'i', 'o', 'u');
var
  i: Integer;
begin
  Result := '';
  for i := 0 to 4 do
    Result := Result + a1[Random(Length(a1))] + a2[Random(Length(a2))];
end;


Exemplo de saídas:
Código:
crubocazizu
progegecago
fideduprapo
pluvidoxaglo
covivabresa
Voltar ao Topo
Ver o perfil de Usuários Enviar Mensagem Particular
x7r3m3x
Aprendiz
Aprendiz


Registrado: Sexta-Feira, 7 de Fevereiro de 2014
Mensagens: 177

MensagemEnviada: Sex Out 21, 2016 10:18 pm    Assunto: Utilizando TDateTimePicker Responder com Citação

Como estilizar seu TDateTimePicker deixando ele "vazio" e inserir data se existir uma data:

Utilizar na uses CommCtrl.

1º Coloque na propriedade Format: / / . (sem o ponto) (Deixa o campo formatado somente com as barras) (Dica do nosso colega nathanbh1)

2º Coloque no OnChange
Código:
keybd_event(111, 0, 0, 0);
(Serve para enquanto o usuário digitar passa automaticamente.
Ex: digitou o dia passa para o mês, digitou o mês passa para o ano) (Dica do nosso colega nathanbh1)

3º Coloque
Código:
TDateTimePicker(Sender).Format := 'dd/MM/yyyy';
(Serve para o campo TDateTimePicker Identificar que é uma data). (Dica do nosso colega nathanbh1)

4º Percebi que era necessário clicar 2 vezes para entrar no campo TDateTimePicker e a função tab não fazia funcionar o TDateTimePicker, então resolvi colocando este mesmo código
Código:
TDateTimePicker(Sender).Format := 'dd/MM/yyyy';
no OnEnter e resolveu o problema.

5º Outra coisa que não achei em lugar algum era como constar que o TDateTimePicker está vazio e o usuário não preencheu nada, então encontrei uma forma de "zerar" ele.
Após Configurar o TDateTimePicker conforme o passo 1º ao 4º. Utilize este código para inserir ou não a data do seu TDateTimePicker.
Código:

if TDateTimePicker .Format = '  /  /    ' then
  begin
    datasource.DataSet.FieldByName('NASCIMENTO').Clear;
  end
  else
  begin
    datasource.DataSet.FieldByName('NASCIMENTO').AsDateTime := TDateTimePicker .Date;
  end;

Explicando:
Como o campo está com o formato " / / " se não for inserido nada no TDateTimePicker ele irá identificar o formato dele como " / / ".
Agora se tiver algo inserido no TDateTimePicker ele irá identificar o formato dele como "dd/MM/yyyy".
Então se não existe a data o formato será " / / " se existir a data o formato será "dd/MM/yyyy".

6º Ultimo passo e não menos importante, recoloque o formato " / / " após cada inserção para deixar o campo da forma padrão.
Código:
TDateTimePicker .Format := '  /  /    ';


Para preencher o campo novamente com o dado cadastrado caso queira utilizar para edição ou visualização zere a propriedade Format do TDateTimePicker antes de preencher o campo.
Ex:
Código:

if datasource.DataSet.FieldByName('NASCIMENTO').AsString <> EmptyStr then
  begin
    TDateTimePicker.Format := '';
    TDateTimePicker.DateTime := datasource.DataSet.FieldByName('NASCIMENTO').AsDateTime;
  end;


Espero ter ajudado!
Voltar ao Topo
Ver o perfil de Usuários Enviar Mensagem Particular
natanbh1
Colaborador
Colaborador


Registrado: Terça-Feira, 15 de Março de 2011
Mensagens: 2898
Localização: Belo Horizonte - MG

MensagemEnviada: Qui Nov 10, 2016 3:50 pm    Assunto: Responder com Citação

Formatação automática de CPF/CNPJ no mesmo Edit

Esta rotina formata a entrada de CPF ou CNPJ no mesmo Edit.
Acrescentado, automaticamente, os separadores (ponto, hífen ou barra).

Código:
function FormataCPFCNPJ(Texto: String): string;
var
  Parte1, Parte2, Parte3, Parte4, Parte5: String;
begin
  Result := EmptyStr;

  Texto := StringReplace(Texto, '.', '', [rfReplaceAll]);
  Texto := StringReplace(Texto, '-', '', [rfReplaceAll]);
  Texto := StringReplace(Texto, '/', '', [rfReplaceAll]);

  if Length(Texto) <= 11 then
  begin
    Parte1 := Copy(Texto, 1, 3);
    Parte2 := Copy(Texto, 4, 3);
    Parte3 := Copy(Texto, 7, 3);
    Parte4 := Copy(Texto, 10, 2);
  end
  else
  begin
    Parte1 := Copy(Texto, 1, 2);
    Parte2 := Copy(Texto, 3, 3);
    Parte3 := Copy(Texto, 6, 3);
    Parte4 := Copy(Texto, 9, 4);
    Parte5 := Copy(Texto, 13, 2);
  end;

  case Length(Texto) of
    0 .. 3:
      Result := Texto;
    4 .. 6:
      Result := Parte1 + '.' + Parte2;
    7 .. 9:
      Result := Parte1 + '.' + Parte2 + '.' + Parte3;
    10 .. 11:
      Result := Parte1 + '.' + Parte2 + '.' + Parte3 + '-' + Parte4;
    12:
      Result := Parte1 + '.' + Parte2 + '.' + Parte3 + '/' + Parte4;
  else
    Result := Parte1 + '.' + Parte2 + '.' + Parte3 + '/' + Parte4 + '-' + Parte5;
  end;
end;


Para usar, no evento OnChange do Edit coloque:

Código:
TEdit(Sender).Text := FormataCPFCNPJ(TEdit(Sender).Text);
TEdit(Sender).SelStart := Length(TEdit(Sender).Text);

_________________
''A persistência é o caminho para o êxito.''
Charlie Chaplin
Voltar ao Topo
Ver o perfil de Usuários Enviar Mensagem Particular Enviar E-mail
joemil
Moderador
Moderador


Registrado: Quinta-Feira, 25 de Março de 2004
Mensagens: 8904
Localização: Sinop-MT

MensagemEnviada: Sáb Nov 12, 2016 9:42 am    Assunto: Responder com Citação

Trocar Componentes e outras funcoes

blz galera? achei estepost, q explica como usar um recurso do delphi pra trocar componentes e outras funcoes q podem ser aplicadas nas units e forms.

http://www.rodrigomourao.com.br/migre-do-bde-anydac-e-dbx-para-firedac-com-um-duplo-clique/

vale a pena dar um confere
_________________
<b>SEMPRE COLOQUE [RESOLVIDO] NO SEU POST</b>
Enviar imagens: http://tinypic.com/
Voltar ao Topo
Ver o perfil de Usuários Enviar Mensagem Particular
marcieldeg
Colaborador
Colaborador


Registrado: Terça-Feira, 5 de Abril de 2011
Mensagens: 1015
Localização: Vitória - ES

MensagemEnviada: Seg Fev 13, 2017 10:57 pm    Assunto: Responder com Citação

Componente TConsoleMessageReceiver.

Exibe as mensagens javascript do WebBrowser, de forma similar ao F12 no navegador, aba Console, mas só com o output. Útil quando estiver debugando um aplicativo com um componente TWebBrowser.

Para quem não sabe instalar, basta criar um novo pacote, adicionar esse arquivo e instalar.

Para utilizar esse componente, na propriedade WebBrowser informe o TWebBrowser que deseja monitorar. Se quiser omitir as mensagens de informação, sete a propriedade ShowInfo = False.

Código:
unit UConsoleMessageReceiver;

interface

uses
  Windows, SysUtils, Variants, Classes, ActiveX, StdCtrls, SHDocVw, MSHTML, Controls;

type
{$IF NOT DECLARED(IDeveloperConsoleMessageReceiver)}
  _DEV_CONSOLE_MESSAGE_LEVEL = TOleEnum;

const
  DCML_INFORMATIONAL = $00000000;
  DCML_WARNING = $00000001;
  DCML_ERROR = $00000002;
  DEV_CONSOLE_MESSAGE_LEVEL_Max = $7FFFFFFF;

type
  IDeveloperConsoleMessageReceiver = interface(IUnknown)
    ['{30510808-98B5-11CF-BB82-00AA00BDCE0B}']
    function write(source: PWideChar; level: _DEV_CONSOLE_MESSAGE_LEVEL; messageId: SYSINT;
      messageText: PWideChar): HResult; stdcall;
    function WriteWithUrl(source: PWideChar; level: _DEV_CONSOLE_MESSAGE_LEVEL; messageId: SYSINT;
      messageText: PWideChar; fileUrl: PWideChar): HResult; stdcall;
    function WriteWithUrlAndLine(source: PWideChar; level: _DEV_CONSOLE_MESSAGE_LEVEL; messageId: SYSINT;
      messageText: PWideChar; fileUrl: PWideChar; line: LongWord): HResult; stdcall;
    function WriteWithUrlLineAndColumn(source: PWideChar; level: _DEV_CONSOLE_MESSAGE_LEVEL; messageId: SYSINT;
      messageText: PWideChar; fileUrl: PWideChar; line: LongWord; column: LongWord): HResult; stdcall;
  end;
{$IFEND}

  TConsoleMessageReceiver = class(TCustomMemo, IDeveloperConsoleMessageReceiver)
  private
    FWebBrowser: TWebBrowser;
    FShowInfo: Boolean;
    procedure RegisterMessageReceiver;
    function Write(source: PWideChar; level: _DEV_CONSOLE_MESSAGE_LEVEL; messageId: SYSINT;
      messageText: PWideChar): HResult; stdcall;
    function WriteWithUrl(source: PWideChar; level: _DEV_CONSOLE_MESSAGE_LEVEL; messageId: SYSINT;
      messageText: PWideChar; fileUrl: PWideChar): HResult; stdcall;
    function WriteWithUrlAndLine(source: PWideChar; level: _DEV_CONSOLE_MESSAGE_LEVEL; messageId: SYSINT;
      messageText: PWideChar; fileUrl: PWideChar; line: LongWord): HResult; stdcall;
    function WriteWithUrlLineAndColumn(source: PWideChar; level: _DEV_CONSOLE_MESSAGE_LEVEL; messageId: SYSINT;
      messageText: PWideChar; fileUrl: PWideChar; line: LongWord; column: LongWord): HResult; stdcall;
    procedure SetWebBrowser(AWebBrowser: TWebBrowser);
  public
    constructor Create(AOwner: TComponent); override;
    procedure Loaded; override;
  published
    property WebBrowser: TWebBrowser read FWebBrowser write SetWebBrowser;
    property ShowInfo: Boolean read FShowInfo write FShowInfo default True;
    property Align;
    property Alignment;
    property Anchors;
    property BevelEdges;
    property BevelInner;
    property BevelKind default bkNone;
    property BevelOuter;
    property BiDiMode;
    property BorderStyle;
    property Color;
    property Constraints;
    property Ctl3D;
    property DoubleBuffered;
    property Enabled;
    property Font;
    property HideSelection;
    property ImeMode;
    property ImeName;
    property OEMConvert;
    property ParentBiDiMode;
    property ParentColor;
    property ParentCtl3D;
    property ParentDoubleBuffered;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ScrollBars default ssVertical;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Touch;
    property Visible;
    property WantReturns;
    property WantTabs;
    property WordWrap;
    property OnChange;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnGesture;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseActivate;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
  end;

procedure Register;

implementation

procedure Register;
begin
  Classes.RegisterComponents('Internet', [TConsoleMessageReceiver]);
end;

{TConsoleMessageReceiver}
constructor TConsoleMessageReceiver.Create(AOwner: TComponent);
begin
  inherited;
  Self.FShowInfo := True;
  Self.ScrollBars := ssVertical;
  Self.ReadOnly := True;
  Self.ParentFont := False;
  Self.Font.Name := 'Courier';
end;

procedure TConsoleMessageReceiver.Loaded;
begin
  inherited;

  RegisterMessageReceiver;
end;

procedure TConsoleMessageReceiver.RegisterMessageReceiver;
const
  IDM_ADDCONSOLEMESSAGERECEIVER = 3800;
  CGID_MSHTML: TGUID = '{DE4BA900-59CA-11CF-9592-444553540000}';
var
  Comm: IOleCommandTarget;
begin
  if Assigned(Self.FWebBrowser) and not(csDesigning in ComponentState) then
  begin
    if not Assigned(Self.FWebBrowser.Document) then
      Self.FWebBrowser.Navigate('about:blank');
    if Supports(Self.FWebBrowser.Document, IOleCommandTarget, Comm) then
      Comm.Exec(@CGID_MSHTML, IDM_ADDCONSOLEMESSAGERECEIVER, OLECMDEXECOPT_DODEFAULT,
        IDeveloperConsoleMessageReceiver(Self), EmptyParam);
  end;
end;

procedure TConsoleMessageReceiver.SetWebBrowser(AWebBrowser: TWebBrowser);
begin
  Self.Lines.Clear;
  Self.FWebBrowser := AWebBrowser;
end;

function TConsoleMessageReceiver.Write(source: PWideChar; level: _DEV_CONSOLE_MESSAGE_LEVEL; messageId: SYSINT;
  messageText: PWideChar): HResult;
const
  MSG_MODEL = '%s'#9'Code %d - %s';
var
  LevelType: String;
begin
  Result := S_OK;
  case level of
    DCML_INFORMATIONAL:
      begin
        if not Self.FShowInfo then
          Exit;
        LevelType := 'INFO';
      end;
    DCML_WARNING:
      LevelType := 'WARN';
    DCML_ERROR:
      LevelType := 'ERROR';
  end;
  Self.Lines.Add(Format(MSG_MODEL, [LevelType, messageId, String(messageText)]));
end;

function TConsoleMessageReceiver.WriteWithUrl(source: PWideChar; level: _DEV_CONSOLE_MESSAGE_LEVEL; messageId: SYSINT;
  messageText, fileUrl: PWideChar): HResult;
const
  MSG_MODEL = '%s'#9'Code %d - %s'#13#10#9'> at %s';
var
  LevelType: String;
begin
  Result := S_OK;
  case level of
    DCML_INFORMATIONAL:
      begin
        if not Self.FShowInfo then
          Exit;
        LevelType := 'INFO';
      end;
    DCML_WARNING:
      LevelType := 'WARN';
    DCML_ERROR:
      LevelType := 'ERROR';
  end;
  Self.Lines.Add(Format(MSG_MODEL, [LevelType, messageId, String(messageText), String(fileUrl)]));
end;

function TConsoleMessageReceiver.WriteWithUrlAndLine(source: PWideChar; level: _DEV_CONSOLE_MESSAGE_LEVEL;
  messageId: SYSINT; messageText, fileUrl: PWideChar; line: LongWord): HResult;
const
  MSG_MODEL = '%s'#9'Code %d - %s'#13#10#9'> at %s'#13#10#9'> in line %d';
var
  LevelType: String;
begin
  Result := S_OK;
  case level of
    DCML_INFORMATIONAL:
      begin
        if not Self.FShowInfo then
          Exit;
        LevelType := 'INFO';
      end;
    DCML_WARNING:
      LevelType := 'WARN';
    DCML_ERROR:
      LevelType := 'ERROR';
  end;
  Self.Lines.Add(Format(MSG_MODEL, [LevelType, messageId, String(messageText), String(fileUrl), line]));
end;

function TConsoleMessageReceiver.WriteWithUrlLineAndColumn(source: PWideChar; level: _DEV_CONSOLE_MESSAGE_LEVEL;
  messageId: SYSINT; messageText, fileUrl: PWideChar; line, column: LongWord): HResult;
const
  MSG_MODEL = '%s'#9'Code %d - %s'#13#10#9'> at %s'#13#10#9'> in line %d, column %d';
var
  LevelType: String;
begin
  Result := S_OK;
  case level of
    DCML_INFORMATIONAL:
      begin
        if not Self.FShowInfo then
          Exit;
        LevelType := 'INFO';
      end;
    DCML_WARNING:
      LevelType := 'WARN';
    DCML_ERROR:
      LevelType := 'ERROR';
  end;
  Self.Lines.Add(Format(MSG_MODEL, [LevelType, messageId, String(messageText), String(fileUrl), line, column]));
end;

end.

_________________
"Olha a interface da IDE! Será que ela é? Será que ela é? DELPHI!"
Voltar ao Topo
Ver o perfil de Usuários Enviar Mensagem Particular
wahlfernando
Novato
Novato


Registrado: Quarta-Feira, 22 de Fevereiro de 2006
Mensagens: 40

MensagemEnviada: Ter Fev 14, 2017 8:29 am    Assunto: Marcar/desmarcar todos checks no listview Responder com Citação

Bom dia galeta para fazer essa operação vcs tem que negar o que ja foi feito, por exemplo:

Código:
procedure TForm1.Listview1ColumnClick(Sender: TObject;
  Column: TListColumn);
begin
   for I := 0 to Listview1.Items.Count - 1 do
   Listview1.Items.Item[I].Checked :=  not Listview1.Items.Item[I].Checked ;
end;


isso faz com que marca e desmarca todos os checkboxes do listview, bem interresante isso ai e é4 uma dica boa.

Qualquer cosia falem ai.


Até... Cool
_________________
=> Fernando Alexandre Wah <=l
** Programador Delphi Pleno **
Voltar ao Topo
Ver o perfil de Usuários Enviar Mensagem Particular Enviar E-mail
marcieldeg
Colaborador
Colaborador


Registrado: Terça-Feira, 5 de Abril de 2011
Mensagens: 1015
Localização: Vitória - ES

MensagemEnviada: Sáb Jun 10, 2017 6:21 pm    Assunto: Responder com Citação

Menu "Manter Janela no Topo"

Se você quer dar a opção para que a janela de sua aplicação fique sempre sobre as outras, você pode criar uma entrada no menu de sistema da própria janela com a opção.

Código:
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    procedure WmSysCommand(var Message:TWMSysCommand); message WM_SYSCOMMAND;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
const
  SYS_STAY_ON_TOP = Cardinal(-1);

procedure TForm1.FormCreate(Sender: TObject);
var
  SysMenu: THandle;
begin
  SysMenu := GetSystemMenu(Handle, False);
  AppendMenu(SysMenu, MF_SEPARATOR, 0, '');
  AppendMenu(SysMenu, MF_UNCHECKED, SYS_STAY_ON_TOP, 'Manter Janela no Topo');
end;

procedure TForm1.WmSysCommand(var Message: TWMSysCommand);
var
  SysMenu: THandle;
  MenuItemInfo: TMenuItemInfo;
  State: Cardinal;
begin
  if Message.CmdType = SYS_STAY_ON_TOP then
  begin
    SysMenu := GetSystemMenu(Handle, False);
    GetMenuItemInfo(SysMenu, SYS_STAY_ON_TOP, False, MenuItemInfo);
    State := GetMenuState(SysMenu, SYS_STAY_ON_TOP, MF_BYCOMMAND);
    if State and MF_CHECKED = MF_CHECKED then
    begin
      CheckMenuItem(SysMenu, SYS_STAY_ON_TOP, MF_BYCOMMAND or MF_UNCHECKED);
      SetWindowPos(Handle, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
    end
    else
    begin
      CheckMenuItem(SysMenu, SYS_STAY_ON_TOP, MF_BYCOMMAND or MF_CHECKED);
      SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
    end;
  end;

  inherited;
end;

end.


Ao selecionar a opção "Manter Janela no Topo", ela ficará sempre sobre as outras.


_________________
"Olha a interface da IDE! Será que ela é? Será que ela é? DELPHI!"
Voltar ao Topo
Ver o perfil de Usuários Enviar Mensagem Particular
Mostrar os tópicos anteriores:   
Novo Tópico   Responder Mensagem    ActiveDelphi - Índice do Fórum -> Delphi Todos os horários são GMT - 3 Horas
Ir à página Anterior  1, 2, 3 ... , 14, 15, 16  Próximo
Página 15 de 16

 
Ir para:  
Enviar Mensagens Novas: Proibido.
Responder Tópicos Proibido
Editar Mensagens: Proibido.
Excluir Mensagens: Proibido.
Votar em Enquetes: Proibido.


Powered by phpBB © 2001, 2005 phpBB Group
Traduzido por: Suporte phpBB