Gravar imagem JPG em Tabela Paradox



Procedure Grava_Imagem_JPEG(Tabela:TTable; Campo:TBlobField; 
Foto:TImage; Dialog:TOpenPictureDialog);
var BS:TBlobStream;
MinhaImagem:TJPEGImage;
Begin
Dialog.InitialDir := 'c:\temp';
Dialog.Execute;
if Dialog.FileName <> '' Then
Begin
if not (Tabela.State in [dsEdit, dsInsert]) Then
Tabela.Edit;
BS := TBlobStream.Create((Campo as TBlobField), BMWRITE);
MinhaImagem := TJPEGImage.Create;
MinhaImagem.LoadFromFile(Dialog.FileName);
MinhaImagem.SaveToStream(BS);
Foto.Picture.Assign(MinhaImagem);
BS.Free;
MinhaImagem.Free;
Tabela.Post;
DBISaveChanges(Tabela.Handle);
End;
End;
procedure TForm1.Button1Click(Sender: TObject);
begin
Grava_Imagem_JPEG(TbClientes,TbClientesCli_Foto, Image1, 
OpenPictureDialog1);
// TbClientes é o nome de alguma Tabela
// TbClientesCli_Foto é um variavel da tabela do tipo Blob
// Image1 é um componente

// OpenPictureDialog1 é o componente para abrir a figura
end;

{Ler imagem JPG da tabela Paradox}

Procedure Le_Imagem_JPEG(Campo:TBlobField; Foto:TImage);
var BS:TBlobStream;
MinhaImagem:TJPEGImage;
Begin
if Campo.AsString <> '' Then
Begin
BS := TBlobStream.Create((Campo as TBlobField), BMREAD);
MinhaImagem := TJPEGImage.Create;
MinhaImagem.LoadFromStream(BS);
Foto.Picture.Assign(MinhaImagem);
BS.Free;
MinhaImagem.Free;
End
Else Foto.Picture.LoadFromFile('c:\temp\limpa.jpg');
End;
procedure TForm1.Button1Click(Sender: TObject);
begin
Le_Imagem_JPEG(TbClientesCli_Foto, Image1);
// TbClientesCli_Foto é um variavel da tabela do tipo Blob
// Image1 é um componente

end;

 


 

 

 

Como saber se o ano é Bisexto



function TForm1.AnoBiSexto(AYear: Integer): Boolean;
begin
Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or 
(AYear mod 400 = 0));
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if AnoBiSexto(1999) Then
ShowMessage('Ano de 1999 é Bisexto')
Else ShowMessage('Ano de 1999 não é Bisexto');
end;

 


 

 

 

Colocar o mês por extenso



unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
function MesExtenso( Mes:Word ) : string;
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
function TForm1.MesExtenso( Mes:Word ) : string;
const meses : array[0..11] of PChar = ('Janeiro', 'Fevereiro', 'Março',
'Abril', 'Maio', 'Junho', 'Julho',
'Agosto', 'Setembro','Outubro',
'Novembro', 'Dezembro');
begin
result := meses[mes-1];
End;
procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := MesExtenso(3);
end;
end. 

 

 


 

 

 

Como cancelar um Loop (While, For ou Repeat)



unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
btIniciar: TButton; // um botão para Iniciar
btCancelar: TButton; // um botão para cancelar
Label1: TLabel;
Label2: TLabel;
procedure btIniciarClick(Sender: TObject);
procedure btCancelarClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
cancelar : Boolean;
implementation
{$R *.DFM}
procedure TForm1.btIniciarClick(Sender: TObject);
var I :Integer;
begin
For I:= 1 to 100000 do 
Begin
Label1.Caption := 'Registros : '+IntToStr(I);
Application.ProcessMessages; 
if Cancelar Then
Begin
Cancelar := False;
if MessageDlg('Deseja Cancelar ?',mtConfirmation,
[mbYes,mbNo],0) = mrYes Then
Begin
Label2.Caption := 'Registro cancelado';
Abort;
End;
End;
End;
end;
procedure TForm1.btCancelarClick(Sender: TObject);
begin
Cancelar := True;
end;
end. 

 

 


 

 

 

 

Inserir Tabelas no Word



unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Db, DBTables;
type
TForm1 = class(TForm)
btIniciar: TButton;
Query1: TQuery;
Query1Cid_Codigo: TIntegerField;
Query1Cid_Descricao: TStringField;
Query1Cid_UF: TStringField;
procedure btIniciarClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses OleAuto;
{$R *.DFM}
procedure TForm1.btIniciarClick(Sender: TObject);
var Word : Variant;
NumCol,I : Integer;
begin
NumCol := Query1.FieldCount;
Word := CreateOleObject('Word.Basic');
word.appshow;
word.filenew;
While not Query1.EOF do
Begin
For I:=1 to Query1.fieldcount-1 do
word.Insert(Query1.fields[i].AsString+#9);
Query1.Next;
End;
Word.editselectall;
Word.TextToTable(ConvertFrom := , NumColumns := NumCol);
word.TableSelectTable;
Word.TableSelectRow;
Word.TableHeadings(1);
Word.TableAutoFormat(Format:=16,HeadingRows:=1);
Word.edit;
end;
end. 

 


 

 

 

 

Chamar um e-mail pelo Delphi



procedure TForm1.Button1Click(Sender: TObject);
var Mail : String;
begin
Mail := 'mailto:portalfontes@ieg.com.br';
ShellExecute(GetDesktopWindow,'open',pchar(Mail),nil,nil,sw_ShowNormal);
end;

 


 

 

Fazer o Formulário Redondo



procedure TForm1.FormCreate(Sender: TObject);
var Hd : THandle;
begin
Hd := CreateEllipticRgn(0,0,400,400);
SetWindowRgn(Handle,Hd,True);
end;

 

 


 

 

Imprimir em impressora matricial em modo caracter via Rede



 {Esta rotina lê todas as impressoras instaladas no windows e coloca dentro de um ComboBox e não se esqueça de adiciona  na cláusula uses a unit Printers}
procedure TForm1.FormShow(Sender: TObject);
var I : Integer;
begin
ComboBox1.Items.Clear;
For I:= 1 to Printer.Printers.Count do
Begin
if Pos('LPT', printer.Printers.Strings[I-1]) > 0Then
ComboBox1.Items.Add('LPT1')
Else if Pos('\\', printer.Printers.Strings[I-1]) > 0 Then
ComboBox1.Items.Add(Copy(printer.Printers.Strings[I-1],
Pos('\\', printer.Printers.Strings[I-1]),
length(printer.Printers.Strings[I-1]) -
Pos('\\', printer.Printers.Strings[I-1]) + 1));
End; 
End;
// e quando apertar o botao imprimir, o evento pega qual a impressora
// que você escolheu atravéz do ComboBox e Imprimi.

procedure TForm1.btImprimirClick(Sender: TObject);
var I:Integer;
Arquivo : TextFile;
begin
AssignFile(Arquivo,ComboBox1.Value);
Rewrite(Arquivo);
WriteLn(Arquivo, 'TESTE DE IMPRESSAO - 1'); 
WriteLn(Arquivo, 'TESTE DE IMPRESSAO - 2'); 
WriteLn(Arquivo, 'TESTE DE IMPRESSAO - 3'); 
WriteLn(Arquivo, 'TESTE DE IMPRESSAO - 4'); 
CloseFile(Arquivo);
end; 

 


 

 

Evitando a saída de Formulário



No evento OnCloseQuerie do form escreva o seguinte código:

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
CanClose:=False;
if messagebox(handle,'Deseja realmente fechar esta janela ?',
'Aviso', mb_IconInformation + mb_YesNo + mb_DefButton2 ) = idYes then
CanClose := True;
end;

 


 

 

Escondendo o Butão Iniciar



procedure hideStartbutton(visi:boolean);
Var
Tray, Child : hWnd;
C : Array[0..127] of Char;
S : String;
Begin
Tray := FindWindow('Shell_TrayWnd', NIL);
Child := GetWindow(Tray, GW_CHILD);
While Child <> 0
do Begin
If GetClassName(Child, C, SizeOf(C)) > 0
Then Begin
S := StrPAS(C);
If UpperCase(S) = 'BUTTON'
then begin
startbutton_handle:=child;
If Visi
then ShowWindow(Child, 1)
else ShowWindow(Child, 0);
end;
End;
Child := GetWindow(Child, GW_HWNDNEXT);
End;
End;

 


 

 

Resetando o Windows



procedure TMainForm.ResetWindowsBtnClick(Sender: TObject);
begin
if not ExitWindows(EW_RestartWindows, 0) then
ShowMessage('Aplicação esta finalizada');
end;


procedure TMainForm.RebootWindowsBtnClick(Sender: TObject);
begin
if not ExitWindows(EW_RebootSystem, 0) then
ShowMessage('Aplicação esta finalizada');
end;

 


 

 

Deixando o Form principal Invisivel



procedure TMainForm.FormCreate(Sender: TObject);
begin
Application.OnMinimize:=AppMinimize;
Application.OnRestore:=AppMinimize;
Application.Minimize;
AppMinimize(@Self);
end;

procedure TMainForm.AppMinimize(Sender: TObject);
begin
ShowWindow(Application.Handle, SW_HIDE);
end;


 


 

 

 

Enviando Textos para outros Aplicativos



unit Unit1;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormKeyPress(Sender: TObject; var Key: Char);
private
AppInst: THandle;
AppWind: THandle;
public
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

uses ShellAPI;


procedure SendShift(H: HWnd; Down: Boolean);
var vKey, ScanCode, wParam: Word;
lParam: longint;
begin
vKey:= $10;
ScanCode:= MapVirtualKey(vKey, 0);
wParam:= vKey or ScanCode shl 8;
lParam:= longint(ScanCode) shl 16 or 1;
if not(Down) then lParam:= lParam or $C0000000;

SendMessage(H, WM_KEYDOWN, vKey, lParam);
end;

procedure SendCtrl(H: HWnd; Down: Boolean);
var vKey, ScanCode, wParam: Word;
lParam: longint;
begin
vKey:= $11;
ScanCode:= MapVirtualKey(vKey, 0);
wParam:= vKey or ScanCode shl 8;
lParam:= longint(ScanCode) shl 16 or 1;
if not(Down) then lParam:= lParam or $C0000000;
SendMessage(H, WM_KEYDOWN, vKey, lParam);
end;

procedure SendKey(H: Hwnd; Key: char);
var vKey, ScanCode, wParam: Word;
lParam, ConvKey: longint;
Shift, Ctrl: boolean;
begin
ConvKey:= OemKeyScan(ord(Key));
Shift:= (ConvKey and $00020000) <> 0;
Ctrl:= (ConvKey and $00040000) <> 0;
ScanCode:= ConvKey and $000000FF or $FF00;
vKey:= ord(Key);
wParam:= vKey;
lParam:= longint(ScanCode) shl 16 or 1;
if Shift then SendShift(H, true);
if Ctrl then SendCtrl(H, true);
SendMessage(H, WM_KEYDOWN, vKey, lParam);
SendMessage(H, WM_CHAR, vKey, lParam);
lParam:= lParam or $C0000000;
SendMessage(H, WM_KEYUP, vKey, lParam);
if Shift then SendShift(H, false);
if Ctrl then SendCtrl(H, false);
end;

function EnumFunc(Handle: HWnd; TF: TForm1): Bool; Far;
begin
TF.AppWind:= 0;
if GetWindowWord(Handle, GWW_HINSTANCE) = TF.AppInst then
TF.AppWind:= Handle;
result:= (TF.AppWind = 0);
end;

procedure TForm1.Button1Click(Sender: TObject);
var Text: Array[0..255] of char;
begin
AppInst:= ShellExecute(Handle, 'open', 'notepad.exe', nil, '', SW_NORMAL);
EnumWindows(@EnumFunc, longint(self));
AppWind:= GetWindow(AppWind, GW_CHILD);
end;


procedure TForm1.Button2Click(Sender: TObject);
begin
SendKey(AppWind, 'T');
SendKey(AppWind, 'e');
SendKey(AppWind, 's');
SendKey(AppWind, 't');
end;

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
if AppWind <> 0 then SendKey(AppWind, Key);
end;

end.

 


 

 

 

Associando um tipo de Aplicação a uma extensão



var
INIFile: TIniFile;
begin
try
INIFile := TInifile.Create('WIN.INI');
INIFile.WriteString('Extensions','txt','c:\windows\notepad.exe ^.txt');
finally
INIFile.Free;
end;
end;


var
INIFile: TIniFile;
begin
try
INIFile := TInifile.Create('WIN.INI');
INIFile.WriteString('Extensions','map','c:\myapps\myapp.exe ^.map');
finally
INIFile.Free;
end;
end;


{Caminho / diretório do Meu Computador}

procedure TForm1.Button1Click(Sender: TObject);
var
PIDL: Pointer;
Path: LPSTR;
const
CSIDL_RECENT = $0008;
begin
Path := StrAlloc(MAX_PATH);
SHGetSpecialFolderLocation(Handle, CSIDL_RECENT, @PIDL);
if SHGetPathFromIDList(PIDL, Path) then
part of file system
begin
OpenDialog1.InitialDir := Path;
OpenDialog1.Execute;
end;
StrDispose(Path);
end;

 


 

 

Evitando os Acentos



O Delphi suporta muito bem todas as letras acentuadas da lingua portuguesa. Desde a digitação ao
armazenamento em bases de dados. Entretanto por vezes necessitamos filtrar os acentos, ou não permitindo sua
digitação ou retirando estes acentos quando apropriado. 

Dois casos clássicos em que os acentos são indesejáveis são na impressão direta para a impressora e na geração
de arquivos texto para transferência de dados para outros sistemas em DOS ou em máquinas de grande porte. 

{Vamos então a duas rotinas.} 

A primeira pega um string e retira todas as letras acentuadas substituindo-as por letras correspondentes sem
acento: 

function AnsiToAscii ( str: String ): String; 
var i: Integer; 
begin 
for i := 1 to Length ( str ) do 
case str[i] of 
'á': str[i] := 'a'; 
'é': str[i] := 'e'; 
'í': str[i] := 'i'; 
'ó': str[i] := 'o'; 
'ú': str[i] := 'u'; 
'à': str[i] := 'a'; 
'è': str[i] := 'e'; 
'ì': str[i] := 'i'; 
'ò': str[i] := 'o'; 
'ù': str[i] := 'u'; 
'â': str[i] := 'a'; 
'ê': str[i] := 'e'; 
'î': str[i] := 'i'; 
'ô': str[i] := 'o'; 
'û': str[i] := 'u'; 
'ä': str[i] := 'a'; 
'ë': str[i] := 'e'; 
'ï': str[i] := 'i'; 
'ö': str[i] := 'o'; 
'ü': str[i] := 'u'; 
'ã': str[i] := 'a'; 
'õ': str[i] := 'o'; 
'ñ': str[i] := 'n'; 
'ç': str[i] := 'c'; 
'Á': str[i] := 'A'; 
'É': str[i] := 'E'; 
'Í': str[i] := 'I'; 
'Ó': str[i] := 'O'; 
'Ú': str[i] := 'U'; 
'À': str[i] := 'A'; 
'È': str[i] := 'E'; 
'Ì': str[i] := 'I'; 
'Ò': str[i] := 'O'; 
'Ù': str[i] := 'U'; 
'Â': str[i] := 'A'; 
'Ê': str[i] := 'E'; 
'Î': str[i] := 'I'; 
'Ô': str[i] := 'O'; 
'Û': str[i] := 'U'; 
'Ä': str[i] := 'A'; 
'Ë': str[i] := 'E'; 
'Ï': str[i] := 'I'; 
'Ö': str[i] := 'O'; 
'Ü': str[i] := 'U'; 
'Ã': str[i] := 'A'; 
'Õ': str[i] := 'O'; 
'Ñ': str[i] := 'N'; 
'Ç': str[i] := 'C'; 
end; 

Result := str; 
end; 

Ao utilizar a rotina acima, não se esqueça de incluir a declaração da mesma na sessão interface da unit em que ela
for inserida. 

A segunda evita a digitação dos acentos fazendo a substituição no momento em que o usuário digita: 

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char); 
begin 
case str[i] of 
'á': Key := 'a'; 
'é': Key := 'e'; 
'í': Key := 'i'; 
'ó': Key := 'o'; 
... 
end; 
end; 

Note que a rotina não está completa. Para completá-la, use o case da primera rotina substituindo todos os str[i]
por Key. 

Esta segunda rotina é na verdade um event handler que você deve usar para o evento OnKeyPress do formulário.
Não se esqueça de colocar true na proprieade KeyPreview do formulário para que este filtre as teclas digitadas
antes delas irem para o controle focado.

 


Home   1 - 2 - 3 - 4 - 5 - 6  - 7-  8    Proxima     - 10

                         fontesbrasil.com® Todos os direitos reservados.


Redirecinar:  http://www.fontesbrasil.com      Melhor visualização 800 x 600