Visualizar imagem em um DBGrid 



Para visualizar uma imagem em um DBGrid, você vai ter que criar um descendente dele que aceite essas figuras. O
código está abaixo: 


unit DBPicGrd; 

interface 

uses 
DBGrids, DB, DBTables, Grids, WinTypes, Classes, Graphics; 

type 
TDBPicGrid = class (TDBGrid) 
protected 
procedure DrawDataCell(const Rect: TRect; Field: TField; State:
TGridDrawState); override; 
public 
constructor Create (AOwner : TComponent); override; 
published 
property DefaultDrawing default False; 
end; 

procedure Register; 

implementation 

constructor TDBPicGrid.Create (AOwner : TComponent); 
begin 
inherited Create (AOwner); 
DefaultDrawing := False; 
end; 

procedure TDBPicGrid.DrawDataCell (const Rect: TRect; Field: TField;
State: TGridDrawState); 
var 
bmp : TBitmap; 
begin 
with Canvas do 
begin 
FillRect(Rect); 
if Field is TGraphicField then 
try 
bmp := TBitmap.Create; 
bmp.Assign (Field); 
Draw (Rect.Left, Rect.Top, bmp); 
finally 
bmp.Free; 
end 
else 
TextOut (Rect.Left, Rect.Top, Field.Text); 
end; 
end; 

procedure Register; 
begin 
RegisterComponents ('Custom', [TDBPicGrid]); 
end; 

end. 




 


Imprimir com precisão Milimétrica 





O objeto Canvas que está na classe Printer é uma ferramenta que ajuda muito a imprimir qualquer tipo de dados,
sejam eles texto ou gráficos. O problema é que a largura e a altura são determinadas em pixels, e esses valores
variam de acordo com a resolução da impressora. Para converter de milímetros para pixels, use as funções abaixo,
sendo que MMtoPixelX é para a resolução horizontal e MMtoPixelY é para a resolução vertical (porque na
impressora é possível uma resolução como 1440x720 dpi - 1440 dpi para a horizontal e 720 dpi para a vertical, por
exemplo): 

function MMtoPixelX (MM : Integer) : Longint; 
var 
mmPointX : Real; 
PageSize, OffSetUL : TPoint; 
begin 
mmPointX := Printer.PageWidth / GetDeviceCaps(Printer.Handle,HORZSIZE);

Escape (Printer.Handle,GETPRINTINGOFFSET,0,nil,@OffSetUL); 
Escape (Printer.Handle,GETPHYSPAGESIZE,0,nil,@PageSize); 
if MM > 0 then 
Result := round ((MM * mmPointX) - OffSetUL.X) 
else 
Result := round (MM * mmPointX); 
end; 

function MMtoPixelY (MM : Integer) : Longint; 
var 
mmPointY : Real; 
PageSize, OffSetUL : TPoint; 
begin 
mmPointY := Printer.PageHeight /
GetDeviceCaps(Printer.Handle,VERTSIZE); 
Escape (Printer.Handle,GETPRINTINGOFFSET,0,nil,@OffSetUL); 
Escape (Printer.Handle,GETPHYSPAGESIZE,0,nil,@PageSize); 
if MM > 0 then 
Result := round ((MM * mmPointY) - OffSetUL.Y) 
else 
Result := round (MM * mmPointY); 
end; 




 


 

 

Alterar caption da janela de Preview do QuickReport 





Para mudar o título da barra de título da janela de Preview de seus relatórios, use o seguinte comando: 

QRPrinter.PreviewCaption := 'Visualização do Relatório'; 




 


Listar tamanho de papéis disponíveis para a Impressora 





Para listar os tamanhos de papel disponíveis para sua impressora, use a procedure abaixo (primeiramente crie um
Memo chamado Memo1): 

procedure ListPaperSizes; 
type 
TPaperName = array [0..63] of char; 
TPaperNameArray = array [1..High (Cardinal) div Sizeof (TPaperName)] of
TPaperName; 
PPapernameArray = ^TPaperNameArray; 

var 
Device, Driver, Port : array [0..255] of char; 
hDevMode : THandle; 
I, numPaperformats : Integer; 
pPaperFormats : PPapernameArray; 

begin 
Printer.PrinterIndex := -1; 
Printer.GetPrinter (Device, Driver, Port, hDevmode); 
numPaperformats := WinSpool.DeviceCapabilities (Device, Port,
DC_PAPERNAMES, nil, nil); 
if numPaperformats > 0 then 
begin 
GetMem (pPaperformats, numPaperformats * Sizeof (TPapername)); 
try 
WinSpool.DeviceCapabilities (Device, Port, DC_PAPERNAMES,
Pchar(pPaperFormats), nil); 
Memo1.Clear; 
for I := 1 to numPaperformats do 
Memo1.Lines.Add (pPaperformats^[I]); 
finally 
FreeMem (pPaperformats); 
end; 
end; 
end; 




 


Texto com fundo transparente pelo Canvas 





Quando eu desenho em um canvas que já tem uma imagem de fundo (ex: o desktop), sempre fica aquele retângulo
branco abaixo dele. Como resolver isso? Simples: 

SetBkMode (Canvas.Handle, Transparent); 





 

 

Detectando a saída do mouse de um Componente 





Todos os descendentes de TComponent mandam as mensagens CM_MOUSEENTER e
CM_MOUSELEAVE quando o mouse entra e sai do componente, respectivamente. Como responder ao
CM_MOUSELEAVE? Fácil: 

Em interface: 

procedure CMMouseLeave (var Msg : TMessage); message CM_MOUSELEAVE; 

Em implementation: 

procedure TButton1.CMMouseLeave (var Msg : TMessage); 
begin 
inherited; 
{faça aqui o que for preciso fazer com o componente} 
end; 





 

 

 

Adicionar Bitmap a um Menu 





var 
Bmp : TPicture; 
begin 
Bmp := TPicture.Create; 
Bmp.LoadFromFile ('C:\Pasta\Arquivo.bmp'); 
SetMenuItemBitmaps (MenuItemTest.Handle, 0, MF_BYPOSITION,
Bmp.Bitmap.Handle, Bmp.Bitmap.Handle); 
Bmp.Free; 
end; 





 

 

Colocar um menu PopUp dentro de outro em Run Time 





procedure TForm1.PopupMenu2Popup(Sender: TObject); 
var 
mi, msub: TMenuItem; 
begin 
with (Sender as TPopupMenu) do 
begin 
// Exclui todos os itens 
// while Items.Count > 0 do Items.delete(0); 
while Items.Count > 0 do 
Items[0].Free; 
mi := TMenuItem.Create(self); 
with mi do 
begin 
Caption := 'First'; 
OnClick := MyClick; 
end; 
Items.Insert(0, mi); 
// Cria um submenu "Sub" com dois itens: "Sub1" e "Sub2" 
mi := TMenuItem.Create(self); 
with mi do begin 
Caption := 'Sub'; 
msub := TMenuItem.Create(self); 
with msub do begin 
Caption := 'Sub1'; 
OnClick := MyClick; 
end; 
Insert(0, msub); 
msub := TMenuItem.Create(self); 
with msub do begin 
Caption := 'Sub2'; 
OnClick := MyClick; // O evento ao clicar 
end; 
Insert(1, msub); 
end; 
Items.Insert(1, mi); 
end; 
end; 

procedure TForm1.MyClick(Sender: TObject); 
begin 
Beep; 
end; 




 


Colocar imagem lado a lado em um Form MDI





procedure TForm.OnPaint(Sender: TObject); 
procedure Tile(c:TCanvas;b:TBitMap); 
var 
x,y,h,w,i,j:integer; 
begin 
with b do begin 
h:=b.height; 
w:=b.width; 
end; 
y:=0; 
with c.Cliprect do begin 
i:=bottom-top-1; //altura 
j:=right-left-1; //largura 
end; 
while y
x:=0; 
while x
c.draw(x,y,b); 
inc(x,w); 
end; 
inc(y,h); 
end; 
end; 

begin 
if Sender is TForm then 
Tile(TForm(Sender).Canvas,fTileWith); 
end; 




 


Verificação de PIS 




function vpis(Dado: String):boolean;
var
i,wsoma,wm11,wdv,wdigito: integer;
begin
if Trim(Dado) <> ‘’ then
begin
wdv := StrToInt(copy(Dado,11,1));
wsoma := 0;
wm11 := 2;
for i := 1 to 10 do
begin
wsoma := wsoma + (wm11 * StrToInt(Copy(Dado, 
11 -i, 1)));
if wm11 < 9 then
wm11 := wm11+1
else
wm11 := 2;
end;
wdigito := 11 - (wsoma mod 11);
if wdigito > 9 then
wdigito := 0;
if wdv = wdigito then
begin
Application.MessageBox('Valor válido!', 
'Aviso !', mb_IconStop+mb_ok);
vpis := True;
end
else
begin
Application.MessageBox('Valor informado não 
é válido!', 'Atenção!', mb_IconStop+mb_ok);
vpis := false;
end;
end;
end; 


 


 


Descobrir tamanho de um Arquivo 





procedure TForm1.Button1Click(Sender: TObject);
var
F : File of Byte; 
begin
if OpenDialog1.Execute then
begin
AssignFile(F,OpenDialog1.FileName);
Reset(F);
Label1.Caption := 'O Tamanho do arquivo ' +OpenDialog1.FileName+ ' é '
+ FloatToStr(FileSize(F));
CloseFile(F);
end;
end; 





 

 

Alterar cor do item selecionado do RadioGroup 





procedure TForm1.RadioGroup1Click(Sender: TObject);
var
i : Integer;
begin
for i := 0 to RadioGroup1.Items.Count-1 do begin
TRadioButton(RadioGroup1.Controls[i]).Font.Color := clBlack;
TRadioButton(RadioGroup1.Controls[i]).Font.Style := [];
end;
TRadioButton(RadioGroup1.Controls
[RadioGroup1.ItemIndex]).Font.Color := clRed;
TRadioButton(RadioGroup1.Controls
[RadioGroup1.ItemIndex]).Font.Style := [fsBold];
end; 





 

 

Retornar último dia do mês 





var
Present: TDateTime;
Data: TDateTime;
Ano, Mes, Dia : Word;
begin
Present:= StrToDate(Edit1.Text);;
DecodeDate(Present, Ano, Mes, Dia);
Label1.Caption := 'Hoje é dia ' + IntToStr(Dia) + ' do Mês ' +
IntToStr(Mes) + ' de ' + IntToStr(Ano);
Present := Present + (32 - Dia);
DecodeDate(Present, Ano, Mes, Dia);
Present := EncodeDate(Ano, Mes, 01 ) -1;
DecodeDate(Present, Ano, Mes, Dia);
Label2.Caption := 'Ultimo dia do Mês ' + IntToStr(Mes) + ' é ' + 
IntToStr(Dia);
end; 





 

 

Verificar se o número é par ou ímpar 





Function ParouImpar(num : integer): string;
If Num mod 2 = 0 then
result:= 'Par'
else
Result:= 'Ímpar';
end; 




 

 

Instalando Programas que utilizam Banco de Dados




O Delphi é capaz de gerar executáveis independente de DLLs, VBXs e OCXs. Porém, quando se trata de
manipulação de Banco de Dados, a história é outra. Ao utilizarmos o BDE (Borland Data Engine), necessitamos
instalar, juntamente com o executável e os arquivos .DB (ou .DBF) os arquivos do BDE, além de registrar a
instalação/chamadas para o BDE no registro do Windows 95. Na seção de DÚVIDAS de Delphi experience você
tem a informação de como obter programas de instalação que podem ser configurados para efetuar a instalação
desses arquivos e fazer as alterações no registro do Windows 95. 

Para facilitar, caso você utilize outro programa de instalação ou queira fazer um programa de instalação no próprio
DELPHI (o que é perfeitamente possível-porém, não deixe de enviar para nós o programa para analisarmos aqui!!
:), listamos os arquivos e alterações necessárias para fazer a instalação.

Arquivos do BDE necessários(geralmente a BDE está instalada dentro do diretório COMMOM FILES, do
diretório BORLAND):

Idapi32.dll
IdasciI32.dll
Idbat32.dll
Iddbas32.dll
Idapi32.cfg
Idpdx32.dll
Idr20009.dll
Blw32.dll
Usa.bll
Europe.bll

Alterações no registro do Windows 95, na chave HKEY_LOCAL_MACHINE:

Key=SOFTWARE\Borland\Database Engine
New Value=%IDAPI%
Value Name=DLLPATH

Key=SOFTWARE\Borland\Database Engine
New Value=%IDAPI%\IDAPI32.CFG
Value Name=CONFIGFILE01

Key=SOFTWARE\Borland\BLW32
New Value=%IDAPI%\USA.BLL
Value Name=LOCALE_LIB1

Key=SOFTWARE\Borland\BLW32
New Value=%IDAPI%\EUROPE.BLL
Value Name=LOCALE_LIB2

A variável %IDAPI% contem o nome do diretório que está instalado o BDE. 

Caso você possua o programa de instalação WISE INSTALLATION versão 5, envie-nos um e-mail solicitando o
SCRIPT pronto para fazer a instalação.


 


 

 

Como colocar um Bitmap num ComboBox




-Ajuste a propriedade Style do ComboBox para csOwnerDrawVariable.

var
Form1: TForm1;
Bmp1, Bmp2, Bmp3: TBitmap;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
Bmp1:=TBitmap.Create;
Bmp.Loadfromfile('c:\chip16.bmp'); 
Bmp1:=TBitmap.Create;
Bmp.Loadfromfile('c:\zoom.bmp');
Bmp1:=TBitmap.Create;
Bmp.Loadfromfile('c:\disk.bmp');
ComboBox1.Items.AddObject('Chip',Bmp1);
ComboBox1.Items.AddObject('Zoom',Bmp2);
ComboBox1.Items.AddObject('Disk',Bmp3);
end;

procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOWnerDrawState);
var
Bitmap: TBitmap;
Offset: Integer;
begin
with (Control as TComboBox).Canvas do begin
FillRect(Rect);
Bitmap:= TBitmap(ComboBox1.Items.Objects[index]);
if Bitmap nil then begin
BrushCopy(Bounds(Rect.Left + 2, Rect.Top + 2, Bitmap.Width,
Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width, Bitmap.Height), clRed);
Offset: Bitmap.width + 8;
end;
TextOut(Rect.Left + Offset, Rect.Top, ComboBox1.Items[index]);
end;
end;

procedure TForm1.ComboBox1MeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);
begin
Height:=20;
end;



 

 

Como conectar uma unidade de rede




procedure TForm1.Button1Click(Sender: TObject);
var
NRW: TNetResource;
begin
with NRW do
begin
dwType := RESOURCETYPE_ANY;
lpLocalName := 'G:';
lpRemoteName := '\\servidor\c';
lpProvider := '';
end;
WNetAddConnection2(NRW, 'MyPassword', 'MyUserName', CONNECT_UPDATE_PROFILE);
end;



 

 

Como desenhar um Bitmap no Formulário




var
Form1: TForm1;
Bmp: TBitmap;

implementation

{$R *.DFM} 

procedure TForm1.FormCreate(Sender: TObject);
begin
Bmp:=TBitmap.Create;
Bmp.Loadfromfile('c:\windows\nuvens.bmp');
end;

procedure TForm1.TForm1.FormPaint(Sender: TObject);
begin
Canvas.Draw(50,50,Bmp); 
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Bmp.Free;
end;
ExecuteProgram('C:\MSOFFICE\EXCEL\EXCEL.EXE',
'CONTAS.XLS');


{Liberada atualização do BDE}

Foi lançada a última versão do BDE, a 5.1, onde antigos problemas foram corrigidos, mais
especificamente em relação ao banco oracle 8. Aqueles programadores que possuem versões do BDE
anteriores a 5 devem realizar uma atualização completa. Em relação ao Oracle, a atualização foi criada
para resolver os seguintes problemas:

O comando RollBack quando acionado em transações explícitas desfaziam inserções/
edições/eliminações que
tinham sido disparadas antes do início da transação.

Quando SQLPASSTHRU MODE estava ajustado para SHARED AUTOCOMMIT os comandos Post não
eram efetivados até que o banco fosse fechado.

A atualização do BDE 510 pode ser obtida no endereço:
http://www.borland.com/devsupport/bde/ files/bde510en.exe 


 


 

 

Criar um nova Tabela a partir de uma estrutura de outra Tabela




O exemplo abaixo mostra como você pode a partir de uma tabela que já está sendo utilizada pelo seu
sistema, criar uma nova tabela com a mesma estrutura já vazia.
implementation
uses DB,DBTables;
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
TabOrigem, TabDestino: TTable;
begin
TabOrigem := TTable.create(self);
with TabOrigem do
begin
DatabaseName := 'ViewFarma';
TableName := 'Bairros.db';
open;
end;
TabDestino := TTable.create(self);
with TabDestino do
begin
DatabaseName := 'ViewFarma';
TableName := 'Bairros2.db';
FieldDefs.Assign(TabOrigem.FieldDefs);
IndexDefs.Assign(TabOrigem.IndexDefs);
CreateTable;
end;
TabOrigem.close;
end;


 


 

 

 

DBGrid - Verifica os Registros selecionados




O exemplo abaixo mostra como você pode verificar quais os registros que estão selecionados no
componente DBGrid. Para selecionar vários registros você deve primeiro alterar a sub-propriedade
dgMultiSelect que faz parte da propriedade Options para True. 
var
Form1: TForm1;
implementation
{$R *.DFM}
// Evento OnClick do componente BitBtn
procedure TForm1.BitBtn1Click(Sender: TObject);
begin
Table1.First;
While not Table1.Eof do
begin
if DBGrid1.SelectedRows.IndexOf(Table1.BookMark) >= 0 then
ShowMessage(‘Registro selecionado’);
Table1.Next;
end;
end;


 


 

 

Reproduzir um Arquivo MPG




Para testar o exemplo abaixo inclua no seu form um componente MediaPlayer, um componente Button
e um componente Panel.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, MPlayer;
type
TForm1 = class(TForm)
Button1: TButton;
MediaPlayer1: TMediaPlayer;
Panel1: TPanel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses mmsystem; // Deve-se declarar a unit mmsystem;
{$R *.DFM}
{ Evento OnClick do componente Button}
procedure TForm1.Button1Click(Sender: TObject);
begin
MediaPlayer1.Filename := 'C:\0\teste.mpg';
MediaPlayer1.Open;
MediaPlayer1.Display := Panel1;
MediaPlayer1.DisplayRect := Panel1.ClientRect;
MediaPlayer1.Play;
end;


 


 

 

Chamar um site pelo Delphi




Para testar o exemplo abaixo inclua no seu form um componente Button e inclua o código abaixo no
evento OnClick do componente Button.
implementation
uses UrlMon;
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
HlinkNavigateString(nil,’http://www.geocities.com’);
end; 

 


 

 

Adicionar ou remover a senha de uma Tabela Paradox




Para testar este exemplo inclua no seu form dois componentes TButton e um componente TEdit.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Grids, DBGrids, Db, DBTables, BDE;
type
TForm1 = class(TForm)
Button1: TButton;
Table1: TTable;
DataSource1: TDataSource;
DBGrid1: TDBGrid;
Edit1: TEdit;
Label1: TLabel;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
procedure AddMasterPassword(Table: TTable; pswd: string);
procedure RemoveMasterPassword(Table: TTable);
var
Form1: TForm1;
implementation
{$R *.DFM}
{ Adiciona a senha ao Banco de Dados}
procedure TForm1.Button1Click(Sender: TObject);
begin
Table1.Close;
Table1.Exclusive := True;
Table1.Open;
AddMasterPassword(Table1,Edit1.Text);
Table1.Close;
Table1.Exclusive := False;
Table1.Open;
end;


{ Remove a senha ao Banco de Dados}


procedure TForm1.Button2Click(Sender: TObject);
begin
Table1.Close;
Table1.Exclusive := True;
Table1.Open;
RemoveMasterPassword(Table1);
Table1.Close;
Table1.Exclusive := False;
Table1.Open;
end;


{ Esta função adiciona a senha ao banco de dados}


procedure AddMasterPassword(Table: TTable; pswd: string);
const RESTRUCTURE_TRUE = WordBool(1);
var TblDesc: CRTblDesc;
hDb: hDBIDb;
begin
if not Table.Active or not Table.Exclusive then
raise EDatabaseError.Create(‘Table must be opened in exclusive ‘ +
‘mode to add passwords’);
FillChar(TblDesc, SizeOf(CRTblDesc), #0);
with TblDesc do
begin
StrPCopy(szTblName, Table.TableName);
StrCopy(szTblType, szPARADOX);
StrPCopy(szPassword, pswd);
bProtected := RESTRUCTURE_TRUE;
end;
Check(DbiGetObjFromObj(hDBIObj(Table.Handle), objDATABASE, hDBIObj(hDb)));
Table.Close;
Check(DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, False));
Session.AddPassword(pswd);
Table.Open;
end;


{ Esta função remove a senha ao banco de dados}


procedure RemoveMasterPassword(Table: TTable);
const RESTRUCTURE_FALSE = WordBool(0);
var TblDesc: CRTblDesc;
hDb: hDBIDb;
begin
if (Table.Active = False) or (Table.Exclusive = False) then
raise EDatabaseError.Create(‘Table must be opened in exclusive mode to add passwords’);
FillChar(TblDesc, SizeOf(CRTblDesc), 0);
with TblDesc do
begin
StrPCopy(szTblName, Table.TableName);
StrCopy(szTblType, szPARADOX);
bProtected := RESTRUCTURE_FALSE;
end;
Check(DbiGetObjFromObj(hDBIObj(Table.Handle), objDATABASE, hDBIObj(hDb)));
Table.Close;
Check(DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, FALSE));
Table.Open;
end;
end. 

 


 

 

 

Arquivos AVI e WAV



O exemplo abaixo demonstra como gravar um arquivo .AVI ou .WAV dentro de um arquivo paradox.
Mostra também como reproduzir estes arquivos.
Para que o código abaixo funcione inclua em um Form 02 componentes Button, 01 componente Panel,
01 componente DBGrid, 01 componente Table, 01 componente DataSource e 01 componente
OpenDialog.
Crie um arquivo Paradox com a seguinte estrutura:
Nome Tipo Tamanho 
Codigo + 
Nome A 100 
Avi B 
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Db, DBTables, ExtCtrls, MPlayer, DBCtrls, Grids, DBGrids;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Table1: TTable;
DataSource1: TDataSource;
DBGrid1: TDBGrid;
Panel1: TPanel;
OpenDialog1: TOpenDialog;
Table1Codigo: TAutoIncField;
Table1Nome: TStringField;
Table1Avi: TBlobField;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;
var Form1: TForm1;
FileName : string;
MediaPlayer1 : TMediaPlayer;
implementation
{$R *.DFM}
{Esta função cria um arquivo temporário para o sistema}
function GetTemporaryFileName : string;
{$IFNDEF WIN32}
const MAX_PATH = 144;
{$ENDIF}
var
{$IFDEF WIN32}
lpPathBuffer : PChar;
{$ENDIF}
lpbuffer : PChar;
begin
{Get the file name buffer}
GetMem(lpBuffer, MAX_PATH);
{$IFDEF WIN32}
{Get the temp path buffer}
GetMem(lpPathBuffer, MAX_PATH); {Get the temp path}
GetTempPath(MAX_PATH, lpPathBuffer); {Get the temp file name}
GetTempFileName(lpPathBuffer,’tmp’,0,lpBuffer); 
FreeMem(lpPathBuffer, MAX_PATH);
{$ELSE} {Get the temp file name}
GetTempFileName(GetTempDrive(‘C’),’tmp’,0,lpBuffer);
{$ENDIF} {Create a pascal string containg}
{the temp file name and return it}
result := StrPas(lpBuffer);
{Free the file name buffer}
FreeMem(lpBuffer, MAX_PATH);
end;
{Grava AVI ou Wav no arquivo PARADOX}
procedure TForm1.Button1Click(Sender: TObject);
var FileStream: TFileStream; {para ler o arquivo avi}
BlobStream: TBlobStream; {para salvar no campo blob}
begin
Application.ProcessMessages;
Button1.Enabled := false;
Button2.Enabled := false;
if OpenDialog1.Execute then
FileStream := TFileStream.Create(OpenDialog1.FileName,fmOpenRead);
Table1.Append;
Table1Nome.Value := OpenDialog1.FileName;
BlobStream := TBlobStream.Create(Table1AVI, bmReadWrite);
BlobStream.Seek(0, soFromBeginning);
BlobStream.Truncate;
BlobStream.CopyFrom(FileStream, FileStream.Size);
FileStream.Free;
BlobStream.Free;
Table1.Post;
Button1.Enabled := true;
Button2.Enabled := true;
end;
{Reproduz o que está gravado no campo Blob}
procedure TForm1.Button2Click(Sender: TObject);
var FileStream: TFileStream; {a temp file}
BlobStream: TBlobStream; {the AVI Blob}
begin
BlobStream := TBlobStream.Create(Table1AVI, bmRead);
if BlobStream.Size = 0 then
begin
BlobStream.Free;
Exit;
end;
MediaPlayer1.Close; {Reset the file name}
MediaPlayer1.FileName := ‘’; {Refresh the play window}
MediaPlayer1.Display := Panel1;
Panel1.Refresh;
if FileName <> ‘’ then
DeleteFile(FileName); {Get a temp file name}
FileName := GetTemporaryFileName; {Create a temp file stream}
FileStream := TFileStream.Create(FileName,fmCreate or fmOpenWrite);
FileStream.CopyFrom(BlobStream, BlobStream.Size); {Free the streams}
FileStream.Free; BlobStream.Free;
MediaPlayer1.FileName := filename;
MediaPlayer1.DeviceType := dtAviVideo;
MediaPlayer1.Open;
MediaPlayer1.Play;
end;
{ Evento OnDestroy do Form}
procedure TForm1.FormDestroy(Sender: TObject);
begin
MediaPlayer1.Close;
MediaPlayer1.FileName := ‘’;
if FileName <> ‘’ then
DeleteFile(FileName);
end;
{ Evento OnShow do Form}
procedure TForm1.FormShow(Sender: TObject);
begin
MediaPlayer1 := TMediaPlayer.Create(self);
with MediaPlayer1 do
begin
Parent := self ;
Visible := False;
end;
Table1.Open;
end;
{ Evento OnClose do Form}
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Table1.Close;
end;
end.

 


 

 

Jogar uma imagem direto para um campo da Tabela



procedure TForm1.Button1Click(Sender: TObject);
var BMP: TBitMap;
begin
BMP := TBitMap.Create;
if OpenPictureDialog1.Execute then
begin
if Table1.State in [dsInsert, dsEdit] then
begin
BMP.LoadFromFile(OpenPictureDialog1.FileName);
Table1Graphic.Assign( BMP );
end;
end;
end; 

 


 

 

ShowMessage com quebra de linhas



procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(‘Primeira Linha’+#13+’Segunda Linha’+#13+’Terceira Linha’);
end;
ATENÇÃO. A quebra foi possível através do codigo #13.

 


 

 

Imprimir em Impressora Matricial em modo caracter



procedure TForm1.Button1Click(Sender: TObject);
var Arquivo : TextFile;
begin
AssignFile(Arquivo,’LPT1');
Rewrite(Arquivo);
Writeln(Arquivo,’Teste de impressao - Linha 0');
Writeln(Arquivo,’Teste de impressao - Linha 1');
Writeln(Arquivo,#27#15+’Teste de Impressão - Linha 2');
Writeln(Arquivo,’Teste de impressao - Linha 3');
Writeln(Arquivo,#27#18+’Teste de Impressão - Linha 4');
Writeln(Arquivo,’Teste de impressao - Linha 5');
Writeln(Arquivo,#12); // Ejeta a página
CloseFile(Arquivo);
end;

 


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

                    fontesbrasil.com® Todos os direitos reservados.


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