C++ ile Asm
//---------------------------------------------------------------------------
void __fastcall TForm1::Button1Click(TObject *Sender)
{
int a, b, c, d;
String id1, id2;
asm
{
mov eax,1 // eax registeri cpuid komutunun parametresidir.
db 0x0F, 0XA2 // cpuid komutu. komutu direk yazmadigimiz icin kodunu yaziyor.
mov a, EAX
mov b, EBX
mov c, ECX
mov d, EDX
}
id1=IntToHex(a,8)+IntToHex(b,8)+IntToHex(d,8)+IntToHex(c,8);
ShowMessage("CPU ID 1 = "+id1);
asm
{
mov eax,2
db 0X0F, 0XA2
mov a, EAX
mov b, EBX
mov c, ECX
mov d, ED
X
}
id2=IntToHex(a,8)+IntToHex(b,8)+IntToHex(d,8)+IntToHex(c,8);
ShowMessage("CPU ID 2 = "+id2);
}
//--------------------------------------------------------------
-------------
// cpu numaras%
C++ Builder - .....................................
re: delphide program yazma hatası
tabloyu active yapmadığından dolayı hatayla karşılaşıyosun.
yada önceki yaptığın bi işlemde tablon kapanıyo olabilir. onları bi kontrol et
istersen.. bide burası forum değil.
lütfen dikkatli kullanalaım sadece kod yaplaşalım
iyi çalışmalar
Delphi - .....................................
re: delphide program yazma hatası
tabloyu active yapmadığından dolayı hatayla karşılaşıyosun.
yada önceki yaptığın bi işlemde tablon kapanıyo olabilir. onları bi kontrol et
istersen.. bide burası forum değil.
lütfen dikkatli kullanalaım sadece kod yaplaşalım
iyi çalışmalar
Delphi - .....................................
String içindeki formatlı kısımların değiştirilmesi
Sometimes you probably have written something like this:
s := Format('Hello %s, your name is %s %s', [FirstName, FirstName, LastName]);
(an admittedly stupid example ;-) )
And if you do, you probably found it annoying that you need to specify the FirstName parameter
twice, in particular if there are lots of similar lines.
But this isn't necessary because you can specify the parameter position to use for the placeholder
in the format string like this:
s := Format('Hello %0:s, your name is %0:s %1:s', [FirstName, LastName]);
Just one more example from a code generator I am currently writing:
TableName := 'Customer';
...
s := Format(' f%0:sTableAuto := T%0:sTableAuto.Create(f%0:Table);', [TableName]);
which results in
s := ' fCustomerTableAuto := TCustomerTableAuto.Create(fCustmerTable);';
{********************************************************************}
Manchmal schreibt man solche Dinge wie:
s := Format('Hallo %s, Dein Name ist %s %s', [Vorname, Vorname, Nachname]);
(Ok, doofes Beispiel. 
)
Und aergert sich dann, insbesondere, wenn man es sehr haeufig schreibt, dass man den Parameter
Vorname mehrfach angeben muss.
Das ist jedoch gar nicht notwendig, denn man kann im Format-String bei einem Platzhalter auch
angeben, welcher Parameter dort eingefuegt werden soll:
s := Format('Hallo %0:s, Dein Name ist %0:s %1:s', [Vorname, Nachname]);
Hier noch ein etwas sinnvolleres Beispiel aus einem Code-Generator, den ich gerade schreibe:
TableName := 'Kunden';
...
s := Format(' f%0:sTableAuto := T%0:sTableAuto.Create(f%0:Table);', [TableName]);
soll ergeben:
s := ' fKundenTableAuto := TKundenTableAuto.Create(fKundenTable);'
Delphi - .....................................
String içindeki formatlı kısımların değiştirilmesi
Sometimes you probably have written something like this:
s := Format('Hello %s, your name is %s %s', [FirstName, FirstName, LastName]);
(an admittedly stupid example ;-) )
And if you do, you probably found it annoying that you need to specify the FirstName parameter
twice, in particular if there are lots of similar lines.
But this isn't necessary because you can specify the parameter position to use for the placeholder
in the format string like this:
s := Format('Hello %0:s, your name is %0:s %1:s', [FirstName, LastName]);
Just one more example from a code generator I am currently writing:
TableName := 'Customer';
...
s := Format(' f%0:sTableAuto := T%0:sTableAuto.Create(f%0:Table);', [TableName]);
which results in
s := ' fCustomerTableAuto := TCustomerTableAuto.Create(fCustmerTable);';
{********************************************************************}
Manchmal schreibt man solche Dinge wie:
s := Format('Hallo %s, Dein Name ist %s %s', [Vorname, Vorname, Nachname]);
(Ok, doofes Beispiel. )
Und aergert sich dann, insbesondere, wenn man es sehr haeufig schreibt, dass man den Parameter
Vorname mehrfach angeben muss.
Das ist jedoch gar nicht notwendig, denn man kann im Format-String bei einem Platzhalter auch
angeben, welcher Parameter dort eingefuegt werden soll:
s := Format('Hallo %0:s, Dein Name ist %0:s %1:s', [Vorname, Nachname]);
Hier noch ein etwas sinnvolleres Beispiel aus einem Code-Generator, den ich gerade schreibe:
TableName := 'Kunden';
...
s := Format(' f%0:sTableAuto := T%0:sTableAuto.Create(f%0:Table);', [TableName]);
soll ergeben:
s := ' fKundenTableAuto := TKundenTableAuto.Create(fKundenTable);'
Delphi - .....................................
2 stringin benzerlik oranının bulunması
Örnekler:
var
Percent: byte;
begin
Percent := CompareStringsInPercent('this is a test', 'This is another test'); // 37%
Percent := CompareStringsInPercent('this is some string', 'and yet another some string'); // 24%
Percent := CompareStringsInPercent('abcde', 'fghij'); // 0%
Percent := CompareStringsInPercent('1.jpg', '2.jpg'); // 81%
.......
--------------------------------------------------------------------
function CompareStringsInPercent(Str1, Str2: string): Byte;
type
TLink = array[0..1] of Byte;
var
tmpPattern: TLink;
PatternA, PatternB: array of TLink;
IndexA, IndexB, LengthStr: Integer;
begin
Result := 100;
// Building pattern tables
LengthStr := Max(Length(Str1), Length(Str2));
for IndexA := 1 to LengthStr do
begin
if Length(Str1) >= IndexA then
begin
SetLength(PatternA, (Length(PatternA) + 1));
PatternA[Length(PatternA) - 1][0] := Byte(Str1[IndexA]);
PatternA[Length(PatternA) - 1][1] := IndexA;
end;
if Length(Str2) >= IndexA then
begin
SetLength(PatternB, (Length(PatternB) + 1));
PatternB[Length(PatternB) - 1][0] := Byte(Str2[IndexA]);
PatternB[Length(PatternB) - 1][1] := IndexA;
end;
end;
// Quick Sort of pattern tables
IndexA := 0;
IndexB := 0;
while ((IndexA < (Length(PatternA) - 1)) and (IndexB < (Length(PatternB) - 1))) do
begin
if Length(PatternA) > IndexA then
begin
if PatternA[IndexA][0] < PatternA[IndexA + 1][0] then
begin
tmpPattern[0] := PatternA[IndexA][0];
tmpPattern[1] := PatternA[IndexA][1];
PatternA[IndexA][0] := PatternA[IndexA + 1][0];
PatternA[IndexA][1] := PatternA[IndexA + 1][1];
PatternA[IndexA + 1][0] := tmpPattern[0];
PatternA[IndexA + 1][1] := tmpPattern[1];
if IndexA > 0 then Dec(IndexA);
end
else
Inc(IndexA);
end;
if Length(PatternB) > IndexB then
begin
if PatternB[IndexB][0] < PatternB[IndexB + 1][0] then
begin
tmpPattern[0] := PatternB[IndexB][0];
tmpPattern[1] := PatternB[IndexB][1];
PatternB[IndexB][0] := PatternB[IndexB + 1][0];
PatternB[IndexB][1] := PatternB[IndexB + 1][1];
PatternB[IndexB + 1][0] := tmpPattern[0];
PatternB[IndexB + 1][1] := tmpPattern[1];
if IndexB > 0 then Dec(IndexB);
end
else
Inc(IndexB);
end;
end;
// Calculating simularity percentage
LengthStr := Min(Length(PatternA), Length(PatternB));
for IndexA := 0 to (LengthStr - 1) do
begin
if PatternA[IndexA][0] = PatternB[IndexA][0] then
begin
if Max(PatternA[IndexA][1], PatternB[IndexA][1]) - Min(PatternA[IndexA][1],
PatternB[IndexA][1]) > 0 then Dec(Result,
((100 div LengthStr) div (Max(PatternA[IndexA][1], PatternB[IndexA][1]) -
Min(PatternA[IndexA][1], PatternB[IndexA][1]))))
else if Result < 100 then Inc(Result);
end
else
Dec(Result, (100 div LengthStr))
end;
SetLength(PatternA, 0);
SetLength(PatternB, 0);
end;
Delphi - .....................................
2 stringin benzerlik oranının bulunması
Örnekler:
var
Percent: byte;
begin
Percent := CompareStringsInPercent('this is a test', 'This is another test'); // 37%
Percent := CompareStringsInPercent('this is some string', 'and yet another some string'); // 24%
Percent := CompareStringsInPercent('abcde', 'fghij'); // 0%
Percent := CompareStringsInPercent('1.jpg', '2.jpg'); // 81%
.......
--------------------------------------------------------------------
function CompareStringsInPercent(Str1, Str2: string): Byte;
type
TLink = array[0..1] of Byte;
var
tmpPattern: TLink;
PatternA, PatternB: array of TLink;
IndexA, IndexB, LengthStr: Integer;
begin
Result := 100;
// Building pattern tables
LengthStr := Max(Length(Str1), Length(Str2));
for IndexA := 1 to LengthStr do
begin
if Length(Str1) >= IndexA then
begin
SetLength(PatternA, (Length(PatternA) + 1));
PatternA[Length(PatternA) - 1][0] := Byte(Str1[IndexA]);
PatternA[Length(PatternA) - 1][1] := IndexA;
end;
if Length(Str2) >= IndexA then
begin
SetLength(PatternB, (Length(PatternB) + 1));
PatternB[Length(PatternB) - 1][0] := Byte(Str2[IndexA]);
PatternB[Length(PatternB) - 1][1] := IndexA;
end;
end;
// Quick Sort of pattern tables
IndexA := 0;
IndexB := 0;
while ((IndexA < (Length(PatternA) - 1)) and (IndexB < (Length(PatternB) - 1))) do
begin
if Length(PatternA) > IndexA then
begin
if PatternA[IndexA][0] < PatternA[IndexA + 1][0] then
begin
tmpPattern[0] := PatternA[IndexA][0];
tmpPattern[1] := PatternA[IndexA][1];
PatternA[IndexA][0] := PatternA[IndexA + 1][0];
PatternA[IndexA][1] := PatternA[IndexA + 1][1];
PatternA[IndexA + 1][0] := tmpPattern[0];
PatternA[IndexA + 1][1] := tmpPattern[1];
if IndexA > 0 then Dec(IndexA);
end
else
Inc(IndexA);
end;
if Length(PatternB) > IndexB then
begin
if PatternB[IndexB][0] < PatternB[IndexB + 1][0] then
begin
tmpPattern[0] := PatternB[IndexB][0];
tmpPattern[1] := PatternB[IndexB][1];
PatternB[IndexB][0] := PatternB[IndexB + 1][0];
PatternB[IndexB][1] := PatternB[IndexB + 1][1];
PatternB[IndexB + 1][0] := tmpPattern[0];
PatternB[IndexB + 1][1] := tmpPattern[1];
if IndexB > 0 then Dec(IndexB);
end
else
Inc(IndexB);
end;
end;
// Calculating simularity percentage
LengthStr := Min(Length(PatternA), Length(PatternB));
for IndexA := 0 to (LengthStr - 1) do
begin
if PatternA[IndexA][0] = PatternB[IndexA][0] then
begin
if Max(PatternA[IndexA][1], PatternB[IndexA][1]) - Min(PatternA[IndexA][1],
PatternB[IndexA][1]) > 0 then Dec(Result,
((100 div LengthStr) div (Max(PatternA[IndexA][1], PatternB[IndexA][1]) -
Min(PatternA[IndexA][1], PatternB[IndexA][1]))))
else if Result < 100 then Inc(Result);
end
else
Dec(Result, (100 div LengthStr))
end;
SetLength(PatternA, 0);
SetLength(PatternB, 0);
end;
Delphi - .....................................
Programım bellekte ne kadar yer kaplıyor
uses psAPI;
procedure TForm1.Button1Click(Sender: TObject);
var
pmc: PPROCESS_MEMORY_COUNTERS;
cb: Integer;
begin
cb := SizeOf(_PROCESS_MEMORY_COUNTERS);
GetMem(pmc, cb);
pmc^.cb := cb;
if GetProcessMemoryInfo(GetCurrentProcess(), pmc, cb) then
Label1.Caption := IntToStr(pmc^.WorkingSetSize) + ' Byte yer kaplıyor'
else
Label1.Caption := 'Bellek kullanım miktarı hesaplanamıyor';
FreeMem(pmc);
end;
Delphi - .....................................
Programım bellekte ne kadar yer kaplıyor
uses psAPI;
procedure TForm1.Button1Click(Sender: TObject);
var
pmc: PPROCESS_MEMORY_COUNTERS;
cb: Integer;
begin
cb := SizeOf(_PROCESS_MEMORY_COUNTERS);
GetMem(pmc, cb);
pmc^.cb := cb;
if GetProcessMemoryInfo(GetCurrentProcess(), pmc, cb) then
Label1.Caption := IntToStr(pmc^.WorkingSetSize) + ' Byte yer kaplıyor'
else
Label1.Caption := 'Bellek kullanım miktarı hesaplanamıyor';
FreeMem(pmc);
end;
Delphi - .....................................
Klavye ve fare bufferlarını(tampon bellek) sıfırlamak
procedure EmptyKeyQueue;
var
Msg: TMsg;
begin
while PeekMessage(Msg, 0, WM_KEYFIRST, WM_KEYLAST,
PM_REMOVE or PM_NOYIELD) do;
end;
procedure EmptyMouseQueue;
var
Msg: TMsg;
begin
while PeekMessage(Msg, 0, WM_MOUSEFIRST, WM_MOUSELAST,
PM_REMOVE or PM_NOYIELD) do;
end;
Delphi - .....................................
Klavye ve fare bufferlarını(tampon bellek) sıfırlamak
procedure EmptyKeyQueue;
var
Msg: TMsg;
begin
while PeekMessage(Msg, 0, WM_KEYFIRST, WM_KEYLAST,
PM_REMOVE or PM_NOYIELD) do;
end;
procedure EmptyMouseQueue;
var
Msg: TMsg;
begin
while PeekMessage(Msg, 0, WM_MOUSEFIRST, WM_MOUSELAST,
PM_REMOVE or PM_NOYIELD) do;
end;
Delphi - .....................................
İki program arasında veri aktarımı sağlanması
{
The WM_COPYDATA messages makes it possible to transfer information
between processes. It does this by passing the data through the kernel.
Space is allocated in the receiving process to hold the information that is copied,
by the kernel, from the source process to the target process.
The sender passes a pointer to a COPYDATASTRUCT, which is defined as a structure
of the following:
}
{
Mit der Windows-Nachricht WM_COPYDATA ist es unter 32 Bit-Windows möglich,
Daten verschiedenster Natur zwischen unterschiedlichen Prozessen auszutauschen.
Eine Windows-interne Funktionalität ermöglicht bei Verwendung von WM_COPYDATA die Nutzung
eines gemeinsamen Speicherbereichs über eine Datenstruktur COPYDATASTRUCT,
die wie folgt aussieht:
}
type
TCopyDataStruct = packed record
dwData: DWORD; // anwendungsspezifischer Wert
cbData: DWORD; // Byte-Länge der zu übertragenden Daten
lpData: Pointer; // Adresse der Daten
end;
{
Dabei geschieht der Datenaustausch auf folgende Weise
(Zitat aus J. Richter, "Windows Programmierung für Experten",
Microsoft Press 1997, S. 524):
"Beim Senden einer Meldung des Typs WM_COPYDATA reserviert die Funktion SendMessage
einen Speicherbereich der angegebenen Größe (cbData Bytes) und kopiert die Daten
vom Adreßraum ihres Prozesses in eben diesen Speicherbereich. Danach sendet SendMessage
die Meldung an das ausgewählte Fenster. Wenn schließlich die empfangende Fensterprozedur
mit der Bearbeitung der Meldung beginnt, verweist der Parameter lParam auf eine
COPYDATASTRUCT-Struktur im Adreßraum des empfangenden Prozesses.
Die lpData-Komponente der Struktur verweist auf den gemeinsamen
Speicherbereich, dessen Adresse jedoch an den Adreßraum des
empfangenden Prozesses angepaßt worden ist.
}
}
{ Sender Application }
{ Sender Applikation }
unit SenderApp;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Button2: TButton;
Image1: TImage;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
procedure SendCopyData(hTargetWnd: HWND; ACopyDataStruct:TCopyDataStruct);
public
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
// Sender: Send data
// Sender: Daten schicken
procedure TForm1.SendCopyData(hTargetWnd: HWND; ACopyDataStruct:TCopyDataStruct);
begin
if hTargetWnd <> 0 then
SendMessage(hTargetWnd, WM_COPYDATA, Longint(Handle), Longint(@ACopyDataStruct))
else
ShowMessage('No Recipient found!');
end;
// Send Text from Edit1 to other app
// Text von Edit1 an andere Anwendung schicken
procedure TForm1.Button1Click(Sender: TObject);
var
MyCopyDataStruct: TCopyDataStruct;
hTargetWnd: HWND;
begin
// Set up a COPYDATASTRUCT structure for use with WM_COPYDATA
// TCopyDataStruct mit den Sende-Daten Infos ausfüllen
with MyCopyDataStruct do
begin
dwData := 0; // may use a value do identify content of message
cbData := StrLen(PChar(Edit1.Text)) + 1; //Need to transfer terminating #0 as well
lpData := PChar(Edit1.Text)
end;
// Find the destination window for the WM_COPYDATA message
// Empfänger Fenster anhand des Titelzeilentextes suchen
hTargetWnd := FindWindow(nil,PChar('Message Receiver'));
// send the structure to the receiver
// Die Struktur an den Empfänger schicken
SendCopyData(hTargetWnd, MyCopyDataStruct);
end;
// Send Image1 to other app
// Image1 an andere Anwendung schicken
procedure TForm1.Button2Click(Sender: TObject);
var
ms: TMemoryStream;
MyCopyDataStruct: TCopyDataStruct;
hTargetWnd: HWND;
begin
ms := TMemoryStream.Create;
try
image1.Picture.Bitmap.SaveToStream(ms);
with MyCopyDataStruct do
begin
dwData := 1;
cbData := ms.Size;
lpData := ms.Memory;
end;
// Search window by the window title
// Empfänger Fenster anhand des Titelzeilentextes suchen
hTargetWnd := FindWindow(nil,PChar('Message Receiver'));
// Send the Data
// Daten Senden
SendCopyData(hTargetWnd,MyCopyDataStruct);
finally
ms.Free;
end;
end;
end.
{*********************************************************************}
{ Receiver Application }
{ Empfänger Application }
unit ReceiverApp;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls;
type
TForm1 = class(TForm)
Image1: TImage;
Label1: TLabel;
private
procedure WMCopyData(var Msg: TWMCopyData); message WM_COPYDATA;
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WMCopyData(var Msg: TWMCopyData);
var
sText: array[0..99] of Char;
ms: TMemoryStream;
begin
case Msg.CopyDataStruct.dwData of
0: { Receive Text, Text empfangen}
begin
StrLCopy(sText, Msg.CopyDataStruct.lpData, Msg.CopyDataStruct.cbData);
label1.Caption := sText;
end;
1: { Receive Image, Bild empfangen}
begin
ms := TMemoryStream.Create;
try
with Msg.CopyDataStruct^ do
ms.Write(lpdata^, cbdata);
ms.Position := 0;
image1.Picture.Bitmap.LoadFromStream(ms);
finally
ms.Free;
end;
end;
end;
end;
end.
Delphi - .....................................
İki program arasında veri aktarımı sağlanması
{
The WM_COPYDATA messages makes it possible to transfer information
between processes. It does this by passing the data through the kernel.
Space is allocated in the receiving process to hold the information that is copied,
by the kernel, from the source process to the target process.
The sender passes a pointer to a COPYDATASTRUCT, which is defined as a structure
of the following:
}
{
Mit der Windows-Nachricht WM_COPYDATA ist es unter 32 Bit-Windows möglich,
Daten verschiedenster Natur zwischen unterschiedlichen Prozessen auszutauschen.
Eine Windows-interne Funktionalität ermöglicht bei Verwendung von WM_COPYDATA die Nutzung
eines gemeinsamen Speicherbereichs über eine Datenstruktur COPYDATASTRUCT,
die wie folgt aussieht:
}
type
TCopyDataStruct = packed record
dwData: DWORD; // anwendungsspezifischer Wert
cbData: DWORD; // Byte-Länge der zu übertragenden Daten
lpData: Pointer; // Adresse der Daten
end;
{
Dabei geschieht der Datenaustausch auf folgende Weise
(Zitat aus J. Richter, "Windows Programmierung für Experten",
Microsoft Press 1997, S. 524):
"Beim Senden einer Meldung des Typs WM_COPYDATA reserviert die Funktion SendMessage
einen Speicherbereich der angegebenen Größe (cbData Bytes) und kopiert die Daten
vom Adreßraum ihres Prozesses in eben diesen Speicherbereich. Danach sendet SendMessage
die Meldung an das ausgewählte Fenster. Wenn schließlich die empfangende Fensterprozedur
mit der Bearbeitung der Meldung beginnt, verweist der Parameter lParam auf eine
COPYDATASTRUCT-Struktur im Adreßraum des empfangenden Prozesses.
Die lpData-Komponente der Struktur verweist auf den gemeinsamen
Speicherbereich, dessen Adresse jedoch an den Adreßraum des
empfangenden Prozesses angepaßt worden ist.
}
}
{ Sender Application }
{ Sender Applikation }
unit SenderApp;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Button2: TButton;
Image1: TImage;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
procedure SendCopyData(hTargetWnd: HWND; ACopyDataStruct:TCopyDataStruct);
public
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
// Sender: Send data
// Sender: Daten schicken
procedure TForm1.SendCopyData(hTargetWnd: HWND; ACopyDataStruct:TCopyDataStruct);
begin
if hTargetWnd <> 0 then
SendMessage(hTargetWnd, WM_COPYDATA, Longint(Handle), Longint(@ACopyDataStruct))
else
ShowMessage('No Recipient found!');
end;
// Send Text from Edit1 to other app
// Text von Edit1 an andere Anwendung schicken
procedure TForm1.Button1Click(Sender: TObject);
var
MyCopyDataStruct: TCopyDataStruct;
hTargetWnd: HWND;
begin
// Set up a COPYDATASTRUCT structure for use with WM_COPYDATA
// TCopyDataStruct mit den Sende-Daten Infos ausfüllen
with MyCopyDataStruct do
begin
dwData := 0; // may use a value do identify content of message
cbData := StrLen(PChar(Edit1.Text)) + 1; //Need to transfer terminating #0 as well
lpData := PChar(Edit1.Text)
end;
// Find the destination window for the WM_COPYDATA message
// Empfänger Fenster anhand des Titelzeilentextes suchen
hTargetWnd := FindWindow(nil,PChar('Message Receiver'));
// send the structure to the receiver
// Die Struktur an den Empfänger schicken
SendCopyData(hTargetWnd, MyCopyDataStruct);
end;
// Send Image1 to other app
// Image1 an andere Anwendung schicken
procedure TForm1.Button2Click(Sender: TObject);
var
ms: TMemoryStream;
MyCopyDataStruct: TCopyDataStruct;
hTargetWnd: HWND;
begin
ms := TMemoryStream.Create;
try
image1.Picture.Bitmap.SaveToStream(ms);
with MyCopyDataStruct do
begin
dwData := 1;
cbData := ms.Size;
lpData := ms.Memory;
end;
// Search window by the window title
// Empfänger Fenster anhand des Titelzeilentextes suchen
hTargetWnd := FindWindow(nil,PChar('Message Receiver'));
// Send the Data
// Daten Senden
SendCopyData(hTargetWnd,MyCopyDataStruct);
finally
ms.Free;
end;
end;
end.
{*********************************************************************}
{ Receiver Application }
{ Empfänger Application }
unit ReceiverApp;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls;
type
TForm1 = class(TForm)
Image1: TImage;
Label1: TLabel;
private
procedure WMCopyData(var Msg: TWMCopyData); message WM_COPYDATA;
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WMCopyData(var Msg: TWMCopyData);
var
sText: array[0..99] of Char;
ms: TMemoryStream;
begin
case Msg.CopyDataStruct.dwData of
0: { Receive Text, Text empfangen}
begin
StrLCopy(sText, Msg.CopyDataStruct.lpData, Msg.CopyDataStruct.cbData);
label1.Caption := sText;
end;
1: { Receive Image, Bild empfangen}
begin
ms := TMemoryStream.Create;
try
with Msg.CopyDataStruct^ do
ms.Write(lpdata^, cbdata);
ms.Position := 0;
image1.Picture.Bitmap.LoadFromStream(ms);
finally
ms.Free;
end;
end;
end;
end;
end.
Delphi - .....................................
Klasör paylaştırılmış mı?
{Following code needs to use ShlObj, ComObj, ActiveX Units}
function TForm1.IfFolderShared(FullFolderPath: string): Boolean;
//Convert TStrRet to string
function StrRetToString(PIDL: PItemIDList; StrRet: TStrRet; Flag: string = ''): string;
var
P: PChar;
begin
case StrRet.uType of
STRRET_CSTR:
SetString(Result, StrRet.cStr, lStrLen(StrRet.cStr));
STRRET_OFFSET:
begin
P := @PIDL.mkid.abID[StrRet.uOffset - SizeOf(PIDL.mkid.cb)];
SetString(Result, P, PIDL.mkid.cb - StrRet.uOffset);
end;
STRRET_WSTR:
if Assigned(StrRet.pOleStr) then
Result := StrRet.pOleStr
else
Result := '';
end;
{ This is a hack bug fix to get around Windows Shell Controls returning
spurious "?"s in date/time detail fields }
if (Length(Result) > 1) and (Result[1] = '?') and (Result[2] in ['0'..'9']) then
Result := StringReplace(Result, '?', '', [rfReplaceAll]);
end;
//Get Desktop's IShellFolder interface
function DesktopShellFolder: IShellFolder;
begin
OleCheck(SHGetDesktopFolder(Result));
end;
//delete the first ID from IDList
function NextPIDL(IDList: PItemIDList): PItemIDList;
begin
Result := IDList;
Inc(PChar(Result), IDList^.mkid.cb);
end;
//get the length of IDList
function GetPIDLSize(IDList: PItemIDList): Integer;
begin
Result := 0;
if Assigned(IDList) then
begin
Result := SizeOf(IDList^.mkid.cb);
while IDList^.mkid.cb <> 0 do
begin
Result := Result + IDList^.mkid.cb;
IDList := NextPIDL(IDList);
end;
end;
end;
//get ID count from IDList
function GetItemCount(IDList: PItemIDList): Integer;
begin
Result := 0;
while IDList^.mkid.cb <> 0 do
begin
Inc(Result);
IDList := NextPIDL(IDList);
end;
end;
//create an ItemIDList object
function CreatePIDL(Size: Integer): PItemIDList;
var
Malloc: IMalloc;
begin
OleCheck(SHGetMalloc(Malloc));
Result := Malloc.Alloc(Size);
if Assigned(Result) then
FillChar(Result^, Size, 0);
end;
function CopyPIDL(IDList: PItemIDList): PItemIDList;
var
Size: Integer;
begin
Size := GetPIDLSize(IDList);
Result := CreatePIDL(Size);
if Assigned(Result) then
CopyMemory(Result, IDList, Size);
end;
//get the last ItemID from AbsoluteID
function RelativeFromAbsolute(AbsoluteID: PItemIDList): PItemIDList;
begin
Result := AbsoluteID;
while GetItemCount(Result) > 1 do
Result := NextPIDL(Result);
Result := CopyPIDL(Result);
end;
//remove the last ID from IDList
procedure StripLastID(IDList: PItemIDList);
var
MarkerID: PItemIDList;
begin
MarkerID := IDList;
if Assigned(IDList) then
begin
while IDList.mkid.cb <> 0 do
begin
MarkerID := IDList;
IDList := NextPIDL(IDList);
end;
MarkerID.mkid.cb := 0;
end;
end;
//if Flag include Element
function IsElement(Element, Flag: Integer): Boolean;
begin
Result := Element and Flag <> 0;
end;
var
P: Pointer;
NumChars, Flags: LongWord;
ID, NewPIDL, ParentPIDL: PItemIDList;
ParentShellFolder: IShellFolder;
begin
Result := False;
NumChars := Length(FullFolderPath);
P := StringToOleStr(FullFolderPath);
//get the folder's full ItemIDList
OleCheck(DesktopShellFolder.ParseDisplayName(0, nil, P, NumChars, NewPIDL, Flags));
if NewPIDL <> nil then
begin
ParentPIDL := CopyPIDL(NewPIDL);
StripLastID(ParentPIDL); //get the folder's parent object's ItemIDList
ID := RelativeFromAbsolute(NewPIDL); //get the folder's relative ItemIDList
//get the folder's parent object's IShellFolder interface
OleCheck(DesktopShellFolder.BindToObject(ParentPIDL, nil, IID_IShellFolder,
Pointer(ParentShellFolder)));
if ParentShellFolder <> nil then
begin
Flags := SFGAO_SHARE;
//get the folder's attributes
OleCheck(ParentShellFolder.GetAttributesOf(1, ID, Flags));
if IsElement(SFGAO_SHARE, Flags) then Result := True;
end;
end;
end;
//KULLANIMI
procedure TForm1.Button1Click(Sender: TObject);
begin
if IfFolderShared('C:My DocumentsWinPopup') then ShowMessage('paylaştırılmış')
else
ShowMessage('yaplaştırılmamış');
end;
Delphi - .....................................
Klasör paylaştırılmış mı?
{Following code needs to use ShlObj, ComObj, ActiveX Units}
function TForm1.IfFolderShared(FullFolderPath: string): Boolean;
//Convert TStrRet to string
function StrRetToString(PIDL: PItemIDList; StrRet: TStrRet; Flag: string = ''): string;
var
P: PChar;
begin
case StrRet.uType of
STRRET_CSTR:
SetString(Result, StrRet.cStr, lStrLen(StrRet.cStr));
STRRET_OFFSET:
begin
P := @PIDL.mkid.abID[StrRet.uOffset - SizeOf(PIDL.mkid.cb)];
SetString(Result, P, PIDL.mkid.cb - StrRet.uOffset);
end;
STRRET_WSTR:
if Assigned(StrRet.pOleStr) then
Result := StrRet.pOleStr
else
Result := '';
end;
{ This is a hack bug fix to get around Windows Shell Controls returning
spurious "?"s in date/time detail fields }
if (Length(Result) > 1) and (Result[1] = '?') and (Result[2] in ['0'..'9']) then
Result := StringReplace(Result, '?', '', [rfReplaceAll]);
end;
//Get Desktop's IShellFolder interface
function DesktopShellFolder: IShellFolder;
begin
OleCheck(SHGetDesktopFolder(Result));
end;
//delete the first ID from IDList
function NextPIDL(IDList: PItemIDList): PItemIDList;
begin
Result := IDList;
Inc(PChar(Result), IDList^.mkid.cb);
end;
//get the length of IDList
function GetPIDLSize(IDList: PItemIDList): Integer;
begin
Result := 0;
if Assigned(IDList) then
begin
Result := SizeOf(IDList^.mkid.cb);
while IDList^.mkid.cb <> 0 do
begin
Result := Result + IDList^.mkid.cb;
IDList := NextPIDL(IDList);
end;
end;
end;
//get ID count from IDList
function GetItemCount(IDList: PItemIDList): Integer;
begin
Result := 0;
while IDList^.mkid.cb <> 0 do
begin
Inc(Result);
IDList := NextPIDL(IDList);
end;
end;
//create an ItemIDList object
function CreatePIDL(Size: Integer): PItemIDList;
var
Malloc: IMalloc;
begin
OleCheck(SHGetMalloc(Malloc));
Result := Malloc.Alloc(Size);
if Assigned(Result) then
FillChar(Result^, Size, 0);
end;
function CopyPIDL(IDList: PItemIDList): PItemIDList;
var
Size: Integer;
begin
Size := GetPIDLSize(IDList);
Result := CreatePIDL(Size);
if Assigned(Result) then
CopyMemory(Result, IDList, Size);
end;
//get the last ItemID from AbsoluteID
function RelativeFromAbsolute(AbsoluteID: PItemIDList): PItemIDList;
begin
Result := AbsoluteID;
while GetItemCount(Result) > 1 do
Result := NextPIDL(Result);
Result := CopyPIDL(Result);
end;
//remove the last ID from IDList
procedure StripLastID(IDList: PItemIDList);
var
MarkerID: PItemIDList;
begin
MarkerID := IDList;
if Assigned(IDList) then
begin
while IDList.mkid.cb <> 0 do
begin
MarkerID := IDList;
IDList := NextPIDL(IDList);
end;
MarkerID.mkid.cb := 0;
end;
end;
//if Flag include Element
function IsElement(Element, Flag: Integer): Boolean;
begin
Result := Element and Flag <> 0;
end;
var
P: Pointer;
NumChars, Flags: LongWord;
ID, NewPIDL, ParentPIDL: PItemIDList;
ParentShellFolder: IShellFolder;
begin
Result := False;
NumChars := Length(FullFolderPath);
P := StringToOleStr(FullFolderPath);
//get the folder's full ItemIDList
OleCheck(DesktopShellFolder.ParseDisplayName(0, nil, P, NumChars, NewPIDL, Flags));
if NewPIDL <> nil then
begin
ParentPIDL := CopyPIDL(NewPIDL);
StripLastID(ParentPIDL); //get the folder's parent object's ItemIDList
ID := RelativeFromAbsolute(NewPIDL); //get the folder's relative ItemIDList
//get the folder's parent object's IShellFolder interface
OleCheck(DesktopShellFolder.BindToObject(ParentPIDL, nil, IID_IShellFolder,
Pointer(ParentShellFolder)));
if ParentShellFolder <> nil then
begin
Flags := SFGAO_SHARE;
//get the folder's attributes
OleCheck(ParentShellFolder.GetAttributesOf(1, ID, Flags));
if IsElement(SFGAO_SHARE, Flags) then Result := True;
end;
end;
end;
//KULLANIMI
procedure TForm1.Button1Click(Sender: TObject);
begin
if IfFolderShared('C:My DocumentsWinPopup') then ShowMessage('paylaştırılmış')
else
ShowMessage('yaplaştırılmamış');
end;
Delphi - .....................................
Windows kapanış diyalog kutusunun ekrana getirilmesi
uses ComObj;
{....}
procedure TForm1.Button1Click(Sender: TObject);
var
shell: Variant;
begin
shell := CreateOleObject('Shell.Application');
shell.ShutdownWindows;
end;
Delphi - .....................................
Windows kapanış diyalog kutusunun ekrana getirilmesi
uses ComObj;
{....}
procedure TForm1.Button1Click(Sender: TObject);
var
shell: Variant;
begin
shell := CreateOleObject('Shell.Application');
shell.ShutdownWindows;
end;
Delphi - .....................................
Aktif pencerenin başlığının alınması
function ActiveCaption: string;
var
Handle: THandle;
Len: LongInt;
Title: string;
begin
Result := '';
Handle := GetForegroundWindow;
if Handle <> 0 then
begin
Len := GetWindowTextLength(Handle) + 1;
SetLength(Title, Len);
GetWindowText(Handle, PChar(Title), Len);
ActiveCaption := TrimRight(Title);
end;
end;
Formunuza timer nesnesi ekleyin
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Label1.Caption := ActiveCaption;
end;
Delphi - .....................................
)