win32

首页win32
27
Sep
0

实现程序只运行一次和打开正在运行的那个

实现程序运行一次的方法有四个:
全部都需要windows,forms单元

  1. 创建互斥对象法 关键函数如下:

    var

    hAppMutex: THandle; //声明互斥变量

    begin

    hAppMutex := CreateMutex(nil, false,’projectname’);
    if ( (hAppMutex <> 0) and (GetLastError() = ERROR_ALREADY_EXISTS)) then
    begin
    MessageBox('程序已经运行, 按确定关闭此窗口!','提示!', MB_OK);
    end

    end;
    

2.查找窗口法(查找要找的窗口,找到就运行了,反之)

Hwnd:=FindWindow(‘TForm1’,’Form1’);
If Hwnd<>0 then
begin
  MessageBox('程序已经运行, 按确定关闭此窗口!','提示!', MB_OK);
end

3.全局原子法,利用WINDOWS内建的全局原子,和互斥比较像,需要手工删除全局原子

const
  iAtom=‘application’; //可以是任意一个唯一标示该程序的原子量
begin
 if GlobalFindAtom(iAtom)=0 then
  begin
    GlobalAddAtom(iAtom); //添加全局原子
    Application.Initialize;
    Application.CreateForm(TForm1,Form1);
    Application.Run;
    GlobalDeleteAtom(GlobalFindAtom(iAtom));//删除添加的全局原子
   end
end

4.共享内存技术(创建内存映射文件,能打开则已经运行,失败则第一次运行)

const
  MapFileName = '{CAF49BBB-AF40-4FDE-8757-51D5AEB5BBBF}';
type
  //共享内存
  PShareMem = ^TShareMem;
  TShareMem = record
    AppHandle: THandle;  //保存程序的句柄
  end;
var
  hMapFile: THandle;
  PSMem: PShareMem;
procedure CreateMapFile;
begin
  hMapFile := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(MapFileName));
  if hMapFile = 0 then
  begin
    hMapFile := CreateFileMapping($FFFFFFFF, nil, PAGE_READWRITE, 0,
      SizeOf(TShareMem), MapFileName);
    PSMem := MapViewOfFile(hMapFile, FILE_MAP_WRITE or FILE_MAP_READ, 0, 0, 0);
    if PSMem = nil then
    begin
      CloseHandle(hMapFile);
      Exit;
    end;
    PSMem^.AppHandle := 0;
  end
  else begin
    PSMem := MapViewOfFile(hMapFile, FILE_MAP_WRITE or FILE_MAP_READ, 0, 0, 0);
    if PSMem = nil then
    begin
      CloseHandle(hMapFile);
    end
  end;
end;
procedure FreeMapFile;
begin
  UnMapViewOfFile(PSMem);
  CloseHandle(hMapFile);
end;

二.打开正在执行的程序 这个和上面的第四种方法结合的完整代码吧 解决了主窗体隐藏,最小化情况下激活的问题

unit wdRunOnce;
interface
function AppHasRun(AppHandle: THandle): Boolean;
implementation
uses
  Windows, Messages;
const
  MapFileName = '{CAF49BBB-AF40-4FDE-8757-51D5AEB5BBBF}';
type
  PShareMem = ^TShareMem;
  TShareMem = record
    AppHandle: THandle;  //保存程序的句柄
  end;
var
  hMapFile: THandle;
  PSMem: PShareMem;
procedure CreateMapFile;
begin
  hMapFile := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(MapFileName));
  if hMapFile = 0 then
  begin
    hMapFile := CreateFileMapping($FFFFFFFF, nil, PAGE_READWRITE, 0,
      SizeOf(TShareMem), MapFileName);
    PSMem := MapViewOfFile(hMapFile, FILE_MAP_WRITE or FILE_MAP_READ, 0, 0, 0);
    if PSMem = nil then
    begin
      CloseHandle(hMapFile);
      Exit;
    end;
    PSMem^.AppHandle := 0;
  end
  else begin
    PSMem := MapViewOfFile(hMapFile, FILE_MAP_WRITE or FILE_MAP_READ, 0, 0, 0);
    if PSMem = nil then
    begin
      CloseHandle(hMapFile);
    end
  end;
end;

procedure FreeMapFile;
begin
  UnMapViewOfFile(PSMem);
  CloseHandle(hMapFile);
end;

function AppHasRun(AppHandle: THandle): Boolean;
var
  TopWindow: HWnd;
begin
  Result := False;
  if PSMem <> nil then
  begin
    if PSMem^.AppHandle <> 0 then
    begin
      SendMessage(PSMem^.AppHandle, WM_SYSCOMMAND, SC_RESTORE, 0);
      TopWindow := GetLastActivePopup(PSMem^.AppHandle);
      if (TopWindow <> 0) and (TopWindow <> PSMem^.AppHandle) and
        IsWindowVisible(TopWindow) and IsWindowEnabled(TopWindow) then
        SetForegroundWindow(TopWindow);
      Result := True;
    end
    else
      PSMem^.AppHandle := AppHandle;
  end;
end;

initialization
  CreateMapFile;
finalization
  FreeMapFile;
end.

调用如下:

program Project1;
uses
  Forms,
  Unit1 in 'Unit1.pas' {Form1}
  wdRunOnce in 'wdRunOnce.pas',
  Unit2 in 'Unit2.pas' {Form2}
{$R *.res}
begin
  Application.Initialize;
  if not AppHasRun(Application.Handle) then
    Application.CreateForm(TForm1, Form1);
  Application.Run;
end.
31
May
0

防止刷新时闪烁的终极解决办法

{ 防止刷新时闪烁的终极解决办法(对付双缓冲无效时) }
Perform($000B, 0, 0); //锁屏幕 防止闪烁

// 做一些会发生严重闪烁的事情..

//解锁屏幕并重画
Perform($000B, 1, 0);
RedrawWindow(Handle, nil, 0, RDW_FRAME + RDW_INVALIDATE + RDW_ALLCHILDREN + RDW_NOINTERNALPAINT);

23
Mar
0

多CPU下的同步函数

InterlockedCompareExchange是把目标操作数(第1参数所指向的内存中的数)与一个值(第3参数)比较,如果相等,则用另一个值(第2参数)与目标操作数(第1参数所指向的内存中的数)交换;InterlockedExchange是不比较直接交换。

整个操作过程是锁定内存的,其它处理器不会同时访问内存,从而实现多处理器环境下的线程互斥。
InterlockedCompareExchange属于Interlocked系列互锁函数之一,常用于多线程编程。类似的还有下面的几个:
增减
(1) LONG InterlockedIncrement(IN OUT LONG volatile *lpAddend);
lpAddend为长整型变量的地址,返回值为原始值。这个函数的主要作用是原子性自增(相当于++操作)。
(2) LONG InterlockedDecrement(IN OUT LONG volatile *lpAddend);
lpAddend为长整型变量的地址,返回值为原始值。这个函数的主要作用是原子性自减(相当于--操作)。
(3) LONG InterlockedExchangeAdd( LPLONG Addend, LONG Increment );
Addend为长整型变量的地址,Increment为想要在Addend指向的长整型变量上增加的数值(可以是负数)。这个函数的主要作用是保证这个加操作为一个原子访问。
交换
(1) LONG InterlockedExchange( LPLONG Target, LONG Value );
(2) PVOID InterlockedExchangePointer( PVOID *Target, PVOID Value );
用第二个参数的值取代第一个参数指向的值。函数返回值为原始值。
比较交换
(1) LONG InterlockedCompareExchange(
LPLONG Destination, LONG Exchange, LONG Comperand );
(2) PVOID InterlockedCompareExchangePointer(
PVOID *Destination, PVOID Exchange, PVOID Comperand );
如果第三个参数与第一个参数指向的值相同,那么用第二个参数取代第一个参数指向的值。函数返回值为原始值。
参数编辑
[in, out] Destination
对目标指针的值。 该符号被忽略。
[in] Exchange 交换值。 该符号被忽略。
[in] ExchangeHigh 目标的高部分交换值。
[in] ExchangeLow 目标的下半部分交换值。
[in] Comparand 比较的值与目标。 该符号被忽略。

备注编辑
请注意,生成内部展开,需要使用 /Oi。 /Oi 提示与 /O2。
若要声明一个互锁的函数用作内部,必须声明函数使用反斜前导下划线,并且新的函数必须出现在 #pragma 内部 语句。 为了方便起见,函数的内部版本。 #define 语句中声明出现在源代码,而无需这个前导下划线。
_InterlockedCompareExchange 执行 Destination 值的基本比较与 Comparand 值。 如果 Destination 值与 Comparand 值相等, Exchange值。 Destination指定的地址存储。 否则,不执行操作。
有关此示例演示如何使用 _InterlockedCompareExchange,请参见 InterlockedDecrement。
具有根据数据类型所涉及在 _InterlockedCompareExchange 的多种变体,并处理器特定是否可捕获或使用语义版本。
当 _InterlockedCompareExchange 函数对长整数值时, _InterlockedCompareExchange16 对短整型值,并_InterlockedCompareExchange64 对 64 位整数值。 由于 _InterlockedCompareExchange64 使用 cmpxchg8b 命令,则不能在之前 Pentium 处理器,如 486。
IPF 特定 _InterlockedCompareExchange_acq、 _InterlockedCompareExchange16_acq和 _InterlockedCompareExchange64_acq 内部函数是不 acq 后缀,但操作的相应功能执行获取语义,很有用,在输入临界区时的行为相同。
_InterlockedCompareExchange_rel、 _InterlockedCompareExchange16_rel和 _InterlockedCompareExchange64_rel 内部函数是不rel 后缀,但操作的相应函数执行与版本语义,很有用,在离开临界区时的行为相同。
这些功能的行为就如同读写内存屏障 有关更多信息,请参见 ReadWriteBarrier。
这些实例只能用作内部。

11
Mar
0
24
Feb
0

DELPHI用原生WinINet.DLL调用HTTPS

///下网页
function PostData(url, data, Len, Auth: string):string;
var
hInt, hConn, hreq: HINTERNET;
buffer: PChar;
dwRead, dwFlags: cardinal;
port: Word;
uri: TIdURI;
proto, host, path: string;
header:string;
res :TStringStream;
IsSue:LongBool;
ErrorNum:Integer;
value: DWORD;
begin
res := TStringStream.Create;
try

uri := TIdURI.Create(url);
try
  host := uri.Host;
  path := uri.Path + uri.Document + uri.Params;
  proto := uri.Protocol;
finally
  FreeAndNil(uri);
end;
if UpperCase(proto) = 'HTTPS' then
begin
  port := INTERNET_DEFAULT_HTTPS_PORT;
  dwFlags := INTERNET_FLAG_SECURE;
end
else
begin
  port := INTERNET_INVALID_PORT_NUMBER;
  dwFlags := INTERNET_FLAG_RELOAD;
end;
hInt := InternetOpen('Delphi', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
hConn := InternetConnect(hInt, PChar(host), port, nil, nil, INTERNET_SERVICE_HTTP, 0, 0);
hreq := HttpOpenRequest(hConn, 'POST', PChar(Path), 'HTTP/1.1', nil, nil, dwFlags, 0);
GetMem(buffer, 65536);
try
  header:='Content-Length:'+len+
          #13'Accept:application/json'+
          #13'Content-Type:application/json'+
          #13'Authorization:'+auth +
          #13'User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.2; SV1; .NET CLR 1.1.4322; .NET CLR 2.0.50727)'+
          #13'Connection:close';
  IsSue := HttpSendRequestW(hReq, PWideChar(header), Length(header), PChar(UTF8Encode(data)), Length(UTF8Encode(data)));
  if IsSue then
  begin
    dwRead := 0;
    repeat
      InternetReadFile(hreq, buffer, 65536, dwRead);
      if dwRead <> 0 then
        res.Write(buffer^, dwRead);
    until dwRead = 0;
  end
  else
  begin
    ErrorNum := GetLastError();
  end;
  InternetCloseHandle(hreq);
  InternetCloseHandle(hConn);
  InternetCloseHandle(hInt);
finally
  FreeMem(buffer);
end;
res.Position := 0;
Result := UTF8ToString( res.DataString);

finally

FreeAndNil(res);

end;
end;
////下图片
function DownQRCodeImg(url: string;aDataStream:TMemoryStream):Boolean;
var
hInt,hConn,hreq:HINTERNET;
buffer:PChar;
dwRead, dwFlags:cardinal;
port: Word;
uri: TIdURI;
proto, host, path: string;
begin
Result := False;
uri := TIdURI.Create(url);
host := uri.Host;
path := uri.Path + uri.Document;
proto := uri.Protocol;
uri.Free;
if UpperCase(proto) = 'HTTPS' then
begin

port := INTERNET_DEFAULT_HTTPS_PORT;
dwFlags := INTERNET_FLAG_SECURE;

end
else
begin

port := INTERNET_INVALID_PORT_NUMBER;
dwFlags := INTERNET_FLAG_RELOAD;

end;
Path := Copy(url,pos('/upay/',url),maxint);
hInt := InternetOpen('Delphi',INTERNET_OPEN_TYPE_PRECONFIG,nil,nil,0);
hConn := InternetConnect(hInt,PChar(host),port,nil,nil,INTERNET_SERVICE_HTTP,0,0);
hreq := HttpOpenRequest(hConn,'POST',PChar(Path),'HTTP/1.1',nil,nil,dwFlags,0);
GetMem(buffer, 655360000);
if HttpSendRequest(hReq,nil,0,nil,0) then
begin

dwRead:=0;
repeat
  InternetReadFile(hreq,buffer,655360000,dwRead);
  if dwRead<>0 then
    aDataStream.Write(buffer^, dwRead);
until dwRead=0;

end;
InternetCloseHandle(hreq);
InternetCloseHandle(hConn);
InternetCloseHandle(hInt);
FreeMem(buffer);
Result := True;
end;
/////////////////////////////////////////////////////////////////////////////////////
interface

uses Classes, WinINet,Sysutils,windows, IDURI;

procedure Get(url: string;res: TStream); overload;
procedure Post(url, data:string;res:TStream); overload;
function Get(url: string): string; overload;
function Post(url, data: string): string; overload;

implementation

function Get(url: string): string;
var
s: TStringStream;
begin
s := TStringStream.Create('');
try

Get(url, s);
result := s.DataString;

finally

s.Free;

end;
end;

function Post(url, data: string): string;
var
s: TStringStream;
begin
s := TStringStream.Create('');
try

Get(url, s);
result := s.DataString;

finally

s.Free;

end;
end;

procedure Post(url, data:string;res:TStream);
var
hInt,hConn,hreq:HINTERNET;
buffer:PChar;
dwRead, dwFlags:cardinal;
port: Word;
uri: TIdURI;
proto, host, path: string;
begin
uri := TIdURI.Create(url);
host := uri.Host;
path := uri.Path + uri.Document;
proto := uri.Protocol;
uri.Free;
if UpperCase(proto) = 'HTTPS' then
begin

port := INTERNET_DEFAULT_HTTPS_PORT;
dwFlags := INTERNET_FLAG_SECURE;

end
else
begin

port := INTERNET_INVALID_PORT_NUMBER;
dwFlags := INTERNET_FLAG_RELOAD;

end;
hInt := InternetOpen('Delphi',INTERNET_OPEN_TYPE_PRECONFIG,nil,nil,0);
hConn := InternetConnect(hInt,PChar(host),port,nil,nil,INTERNET_SERVICE_HTTP,0,0);
hreq := HttpOpenRequest(hConn,'POST',PChar(Path),'HTTP/1.1',nil,nil,dwFlags,0);
GetMem(buffer, 65536);
if HttpSendRequest(hReq,nil,0,PChar(data),Length(data)) then
begin

dwRead:=0;
repeat
  InternetReadFile(hreq,buffer,65536,dwRead);
  if dwRead<>0 then
    res.Write(buffer^, dwRead);
until dwRead=0;

end;
InternetCloseHandle(hreq);
InternetCloseHandle(hConn);
InternetCloseHandle(hInt);
FreeMem(buffer);
end;

procedure Get(url: string;res: TStream);
var
hInt,hUrl:HINTERNET;
buffer:PChar;
dwRead:cardinal;
begin
GetMem(buffer, 65536);
hInt := InternetOpen('Delphi',INTERNET_OPEN_TYPE_PRECONFIG,nil,nil,0);
dwRead:=0;
hurl:=InternetOpenUrl(hInt,PChar(url),nil,0,INTERNET_FLAG_RELOAD,0);
repeat
InternetReadFile(hUrl,buffer,1000,dwRead);
if dwRead<>0 then

 res.Write(buffer^, dwRead);

until dwRead=0;
InternetCloseHandle(hUrl);
InternetCloseHandle(hInt);
FreeMem(buffer);
end;

end.
//======设置一下option,就能正常访问证书有问题的站点了=======
var value: DWORD;

value = SECURITY_FLAG_IGNORE_CERT_CN_INVALID or

    SECURITY_FLAG_IGNORE_CERT_DATE_INVALID or
    SECURITY_FLAG_IGNORE_UNKNOWN_CA or
    SECURITY_FLAG_IGNORE_CERT_WRONG_USAGE;

WinHttpSetOption(hreq, WINHTTP_OPTION_SECURITY_FLAGS, @value, SizeOf(value));

//================使用IdHttp 获取 HttpsURL内容 需要相关的DLL文件==========================
uses IdHTTP, IdSSLOpenSSL;

function HttpsGet(const aURL, aContentFile: string): Boolean;
var
vIdHTTP: TIdHTTP;
vSSL: TIdSSLIOHandlerSocket;
vMemory: TMemoryStream;
begin
try

vIdHTTP := TIdHTTP.Create(nil);
vSSL := TIdSSLIOHandlerSocket.Create(nil);
vMemory := TMemoryStream.Create;
try
  vIdHTTP.IOHandler := vSSL;
  vSSL.SSLOptions.Method := sslvSSLv3;
  vIdHTTP.Get(aURL, vMemory);
  vMemory.SaveToFile(aContentFile);
  Result := True;
finally
  vMemory.Free;
  vSSL.Free;
  vIdHTTP.Free;
end;

except

Result := False;

end;
end;

//=====================自定义头文件和POST DATA=================
//引用了WinINet,IDURI单元,其中CnMD5,CnBase64是认证业务需要加入的cnpack中的单元
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, CnMD5,
CnBase64,WinINet,IDURI,Dialogs, StdCtrls;

type
TForm2 = class(TForm)

Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var
Form2: TForm2;

implementation

{$R *.dfm}

procedure Post(url, data, Len, Auth: string; res: TStream);
var
hInt, hConn, hreq: HINTERNET;
buffer: PChar;
dwRead, dwFlags: cardinal;
port: Word;
uri: TIdURI;
proto, host, path: string;
header:string;
begin
uri := TIdURI.Create(url);
host := uri.Host;
path := uri.Path + uri.Document + uri.Params;
proto := uri.Protocol;
uri.Free;
if UpperCase(proto) = 'HTTPS' then
begin

port := INTERNET_DEFAULT_HTTPS_PORT;
dwFlags := INTERNET_FLAG_SECURE;

end
else
begin

port := INTERNET_INVALID_PORT_NUMBER;
dwFlags := INTERNET_FLAG_RELOAD;

end;
hInt := InternetOpen('Delphi', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
hConn := InternetConnect(hInt, PChar(host), port, nil, nil, INTERNET_SERVICE_HTTP, 0, 0);
hreq := HttpOpenRequest(hConn, 'POST', PChar(Path), 'HTTP/1.1', nil, nil, dwFlags, 0);
GetMem(buffer, 65536);
header:='Content-Length:'+len+

#13'Accept:application/json'+
#13'Content-Type:application/json'+
#13'Authorization:'+auth;

if HttpSendRequest(hReq, PAnsiChar(header), Length(header), PChar(data), Length(data)) then
begin

dwRead := 0;
repeat
  InternetReadFile(hreq, buffer, 65536, dwRead);
  if dwRead <> 0 then
    res.Write(buffer^, dwRead);
until dwRead = 0;

end;
InternetCloseHandle(hreq);
InternetCloseHandle(hConn);
InternetCloseHandle(hInt);
FreeMem(buffer);
end;

procedure TForm2.Button1Click(Sender: TObject);
var
s: string;
sig: string;
b64: string;
t: string;
l,content: string;
Responses: TStringStream;
begin
t := formatdatetime('yyyyMMddHHnnss', Now);

sig := UpperCase(MD5Print(MD5String('123123123' + '234234234234' + t)));
Base64Encode('2221232321:' + t, b64);

content:=AnsiToUtf8('{"from":"13155555555","to":"18822225555"}');

l := IntToStr(Length(content));

Responses := TStringStream.Create('');
s := 'https://www.good.com:856/Callback?sig=' + sig + '';
Post(s, content,l,b64, Responses);

Memo1.text := Utf8ToAnsi(Responses.DataString);
Responses.Free;
end;

end.