delphi-functions..for API and other stuff..

Verfügbare Informationen zu "delphi-functions..for API and other stuff.."

Qualität des Beitrags:

Beteiligte Poster: bellerophones24

Forum: APD - Associated Programers Division

Forenbeschreibung: APD - Delphi and Visual Basic Community

aus dem Unterforum: Windows API

Antworten: 1

Forum gestartet am: Samstag 13.01.2007

Sprache: englisch

Link zum Originaltopic: delphi-functions..for API and other stuff..

Letzte Antwort: vor 16 Jahren, 8 Monaten, 16 Tagen, 3 Stunden, 11 Minuten

Alle Beiträge und Antworten zu "delphi-functions..for API and other stuff.."

Re: delphi-functions..for API and other stuff..

bellerophones24 - 08.08.2007, 18:47

delphi-functions..for API and other stuff..
function GetSpecialFolder(hWindow: HWND; Folder: Integer): String;
var
pMalloc: IMalloc;
pidl: PItemIDList;
Path: PChar;
begin
// get IMalloc interface pointer
if (SHGetMalloc(pMalloc) <> S_OK) then
begin
MessageBox(hWindow, 'Couldn''t get pointer to IMalloc interface.',
'SHGetMalloc(pMalloc)', 16);
Exit;
end;

// retrieve path
SHGetSpecialFolderLocation(hWindow, Folder, pidl);
GetMem(Path, MAX_PATH);
SHGetPathFromIDList(pidl, Path);
Result := Path;
FreeMem(Path);

// free memory allocated by SHGetSpecialFolderLocation
pMalloc.Free(pidl);
end;

procedure Delay(Milliseconds: Integer);
var
Tick: DWord;
Event: THandle;
begin
Event := CreateEvent(nil, False, False, nil);
try
Tick := GetTickCount + DWord(Milliseconds);
while (Milliseconds > 0) and
(MsgWaitForMultipleObjects(1, Event, False, Milliseconds, QS_ALLINPUT) <> WAIT_TIMEOUT) do
begin
Application.ProcessMessages;
if Application.Terminated then Exit;
Milliseconds := Tick - GetTickcount;
end;
finally
CloseHandle(Event);
end;
end;




procedure GetProcessList(const AProcesslist:Tstrings);
var Snap:Thandle;
ProcessE:TProcessEntry32;
begin
aProcesslist.Clear;
Snap:=CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS,0);
try
Processe.dwSize:=Sizeof(Processe);
if Process32First(Snap,ProcessE) then
begin
repeat
aProcesslist.Add(Processe.szExeFile);
until not Process32Next(snap,processE)end
else
RaiselastOSError;
finally
Closehandle(snap);
end;
end;


function putfile(server, username, password, localfile, remotefile: string; port: word = 21): boolean;
var
hopen, hconnect: HINTERNET;
begin
hopen := InternetOpen('myagent', INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);
hconnect := InternetConnect(hopen, pchar(server), port, pchar(username), pchar(password), INTERNET_SERVICE_FTP, INTERNET_FLAG_PASSIVE, 0);
Result := FtpPutFile(hconnect, pchar(localfile), pchar(remotefile), FTP_TRANSFER_TYPE_UNKNOWN, 0);
InternetCloseHandle(hconnect);
end;

function FtpDownloadFile(strHost, strUser, strPwd: string;
Port: Integer; ftpDir, ftpFile, TargetFile: string; ProgressBar: TProgressBar): Boolean;

function FmtFileSize(Size: Integer): string;
begin
if Size >= $F4240 then
Result := Format('%.2f', [Size / $F4240]) + ' Mb'
else
if Size < 1000 then
Result := IntToStr(Size) + ' bytes'
else
Result := Format('%.2f', [Size / 1000]) + ' Kb';
end;

const
READ_BUFFERSIZE = 4096; // or 256, 512, ...
var
hNet, hFTP, hFile: HINTERNET;
buffer: array[0..READ_BUFFERSIZE - 1] of Char;
bufsize, dwBytesRead, fileSize: DWORD;
sRec: TWin32FindData;
strStatus: string;
LocalFile: file;
bSuccess: Boolean;
begin
Result := False;

{ Open an internet session }
hNet := InternetOpen('Program_Name', // Agent
INTERNET_OPEN_TYPE_PRECONFIG, // AccessType
nil, // ProxyName
nil, // ProxyBypass
0); // or INTERNET_FLAG_ASYNC / INTERNET_FLAG_OFFLINE

{
Agent contains the name of the application or
entity calling the Internet functions
}


{ See if connection handle is valid }
if hNet = nil then
begin
ShowMessage('Unable to get access to WinInet.Dll');
Exit;
end;

{ Connect to the FTP Server }
hFTP := InternetConnect(hNet, // Handle from InternetOpen
PChar(strHost), // FTP server
port, // (INTERNET_DEFAULT_FTP_PORT),
PChar(StrUser), // username
PChar(strPwd), // password
INTERNET_SERVICE_FTP, // FTP, HTTP, or Gopher?
0, // flag: 0 or INTERNET_FLAG_PASSIVE
0);// User defined number for callback

if hFTP = nil then
begin
InternetCloseHandle(hNet);
ShowMessage(Format('Host "%s" is not available',[strHost]));
Exit;
end;

{ Change directory }
bSuccess := FtpSetCurrentDirectory(hFTP, PChar(ftpDir));

if not bSuccess then
begin
InternetCloseHandle(hFTP);
InternetCloseHandle(hNet);
ShowMessage(Format('Cannot set directory to %s.',[ftpDir]));
Exit;
end;

{ Read size of file }
if FtpFindFirstFile(hFTP, PChar(ftpFile), sRec, 0, 0) <> nil then
begin
fileSize := sRec.nFileSizeLow;
// fileLastWritetime := sRec.lastWriteTime
end else
begin
InternetCloseHandle(hFTP);
InternetCloseHandle(hNet);
ShowMessage(Format('Cannot find file ',[ftpFile]));
Exit;
end;

{ Open the file }
hFile := FtpOpenFile(hFTP, // Handle to the ftp session
PChar(ftpFile), // filename
GENERIC_READ, // dwAccess
FTP_TRANSFER_TYPE_BINARY, // dwFlags
0); // This is the context used for callbacks.

if hFile = nil then
begin
InternetCloseHandle(hFTP);
InternetCloseHandle(hNet);
Exit;
end;

{ Create a new local file }
AssignFile(LocalFile, TargetFile);
{$i-}
Rewrite(LocalFile, 1);
{$i+}

if IOResult <> 0 then
begin
InternetCloseHandle(hFile);
InternetCloseHandle(hFTP);
InternetCloseHandle(hNet);
Exit;
end;

dwBytesRead := 0;
bufsize := READ_BUFFERSIZE;

while (bufsize > 0) do
begin
Application.ProcessMessages;

if not InternetReadFile(hFile,
@buffer, // address of a buffer that receives the data
READ_BUFFERSIZE, // number of bytes to read from the file
bufsize) then Break; // receives the actual number of bytes read

if (bufsize > 0) and (bufsize <= READ_BUFFERSIZE) then
BlockWrite(LocalFile, buffer, bufsize);
dwBytesRead := dwBytesRead + bufsize;

{ Show Progress }
ProgressBar.Position := Round(dwBytesRead * 100 / fileSize);
Form1.Label1.Caption := Format('%s of %s / %d %%',[FmtFileSize(dwBytesRead),FmtFileSize(fileSize) ,ProgressBar.Position]);
end;

CloseFile(LocalFile);

InternetCloseHandle(hFile);
InternetCloseHandle(hFTP);
InternetCloseHandle(hNet);
Result := True;
end;


function InstallExt(Extension, ExtDescription, FileDescription,
OpenWith, ParamString: string; IconIndex: Integer = 0): Boolean;
var
Reg: TRegistry;
begin
Result := False;
if Extension <> '' then
begin
if Extension[1] <> '.' then
Extension := '.' + Extension;

Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CLASSES_ROOT;
if Reg.OpenKey(Extension, True) then
begin
Reg.WriteString('', ExtDescription);
if Reg.OpenKey('\' + ExtDescription, True) then
begin
Reg.WriteString('', FileDescription);
if Reg.OpenKey('DefaultIcon', True) then
begin
Reg.WriteString('', Format('%s,%d', [OpenWith, IconIndex]));
if Reg.OpenKey('\' + ExtDescription + '\Shell\Open\Command', True) then
begin
Reg.WriteString('', Format('"%s" "%s"', [OpenWith, ParamString]));
Result:=True;
end;
end;
end;
end;
finally
Reg.Free;
end;
end;
end;







procedure TForm1.WMDROPFILES (var Msg: TMessage);
var i, anzahl, size: integer;
Dateiname: PChar;
begin
inherited;
anzahl := DragQueryFile(Msg.WParam, $FFFFFFFF, Dateiname, 255);
for i := 0 to (anzahl - 1) do
begin
size := DragQueryFile(Msg.WParam, i , nil, 0) + 1;
Dateiname:= StrAlloc(size);
DragQueryFile(Msg.WParam,i , Dateiname, size);
tls.items.add(StrPas(Dateiname));
StrDispose(Dateiname);
end;
DragFinish(Msg.WParam);
end;

function IsOnline: Boolean;
Var
dlvFlag : DWord;
begin
Result:=False;
dlvFlag := Internet_Connection_Modem + Internet_Connection_Lan + Internet_Connection_Proxy;
If InternetGetConnectedState ( @dlvFlag, 0 ) = True Then
Result:=dlvFlag = 81;
End;


function GetPreviousDirectory(const APath: String): String;
var
i: Integer;
begin
Result:=APath;
i:=Length(APath);
If i>3 Then
Begin
Repeat
Dec(i);
Until (APath[i] = '\') OR (i=1);
If APath[i]='\' Then
Result:=Copy(APath,1,i);
End;
end;


function IsExeRunning(const AExeName: string): boolean;
var
h: THandle;
p: TProcessEntry32;
begin
Result := False;
p.dwSize := SizeOf(p);
h := CreateToolHelp32Snapshot(TH32CS_SnapProcess, 0);
try
Process32First(h, p);
repeat
Result := AnsiUpperCase(AExeName) = AnsiUpperCase(p.szExeFile);
until Result or (not Process32Next(h, p));
finally
CloseHandle(h);
end;
end;

procedure WriteText(TransText: string);
var
MyHand: HWND;
MyDc: HDC;
MyCanvas: TCanvas;
begin
MyHand := GetDesktopWindow;
MyDc := GetWindowDC(MyHand);
MyCanvas := TCanvas.Create;
MyCanvas.Handle := MyDC;
BeginPath(MyCanvas.Handle);
MyCanvas.Font.Color := clRed;
MyCanvas.Font.Name := 'Courier New';
MyCanvas.Font.Size := 15;
SetBkMode(MyCanvas.Handle,TRANSPARENT);
EndPath(MyCanvas.Handle);
MyCanvas.TextOut((screen.width div 2 ), (screen.Height div 2 ), TransText); //Hier die Positionsdaten mit X und Y, wo der Text beginnen soll
end;

function CreateLink(const AFilename, ALNKFilename, ADescription: String) : Boolean;
var
psl : IShellLink;
ppf : IPersistFile;
wsz : PWideChar;
begin
result:=false;
if SUCCEEDED(CoCreateInstance(CLSID_ShellLink, nil,
CLSCTX_inPROC_SERVER, IID_IShellLinkA, psl)) then
begin
psl.SetPath(PChar(AFilename));
psl.SetDescription(PChar(ADescription));
psl.SetWorkingDirectory(PChar(ExtractFilePath(AFilename)));
if SUCCEEDED(psl.QueryInterface(IPersistFile, ppf)) then
begin
GetMem(wsz, MAX_PATH*2);
try
MultiByteToWideChar(CP_ACP, 0, PChar(ALNKFilename), -1, wsz, MAX_PATH);
ppf.Save(wsz, true);
result:=true;
finally
FreeMem(wsz, MAX_PATH*2);
end;
end;
end;
end;

function GetLocalIPs(const Lines:TStrings):Boolean;
type
PPInAddr= ^PInAddr;
var
wsaData: TWSAData;
HostInfo: PHostEnt;
HostName: Array[0..255] of Char;
Addr: PPInAddr;
begin
Result:=False;
Lines.Clear;
if WSAStartup($0102, wsaData)=0 then
try
if gethostname(HostName, SizeOf(HostName)) = 0 then Begin
HostInfo:= gethostbyname(HostName);
if HostInfo<>nil then Begin
Addr:=Pointer(HostInfo^.h_addr_list);
if (Addr<>nil) AND (Addr^<>nil) then
Repeat
Lines.Add(StrPas(inet_ntoa(Addr^^)));
inc(Addr);
Until Addr^=nil;
end;
end;
Result:=True;
finally
WSACleanup;
end;
end;



have fun.. :arrow:

---

Mit folgendem Code, können Sie den Beitrag ganz bequem auf ihrer Homepage verlinken

<a href="http://www.iphpbb.com/foren-archiv/3/150400/150240/delphifunctionsfor-api-and-other-stuff-32050352-74696-15.html" target="_blank">delphi-functions..for API and other stuff..</a>

---

Weitere Beiträge aus dem Forum APD - Associated Programers Division

Little Mouse Program - gepostet von marcx goes cbr1000rr am Freitag 09.02.2007

---

Ähnliche Beiträge wie "delphi-functions..for API and other stuff.."

No plans for anymore musicals says Benny news date Jan 2007 - abbademosuk (Samstag 06.01.2007)
Help me and vote! - Bemme (Mittwoch 14.06.2006)
I'll be right here waiting for you... - Sweet-Girl (Donnerstag 16.03.2006)
STO (only for Trekkies) - Mila (Freitag 11.08.2006)
application for hidden forum - draups (Mittwoch 31.10.2007)
Game: 'Game over for G-Unit!' - nici2280 (Mittwoch 28.09.2005)
abba advert for number ones cd - jenlovesabba1982 (Samstag 11.11.2006)
gone for a while.. i guess - Nerazh (Donnerstag 06.12.2007)
PvP for Dummies - Scythe (Mittwoch 11.10.2006)
What CD's and items do u have of ELT ? - Bright Light (Donnerstag 06.01.2005)