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;
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.
Colocar 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;
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
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;
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;
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.
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.
procedure TForm1.Button1Click(Sender: TObject);
var Mail : String;
begin
Mail := 'mailto:weberley@starmedia.com';
ShellExecute(GetDesktopWindow,'open',pchar(Mail),nil,nil,sw_ShowNormal);
end;
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 adicionar
// 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;
PlaySound('Path\Som.Wav',SND_ASYNC,0);