Delphi Http Https 最好的解决方法(一)

最新推荐文章于 2025-11-16 22:57:11 发布

原创最新推荐文章于 2025-11-16 22:57:11 发布 · 3.5k 阅读

10 ·

CC 4.0 BY-SA版权

文章标签：

#windows #microsoft

Delphi 专栏收录该内容

26 篇文章

订阅专栏

当前文章主要解决Delphi调用http、https的常见报错。

开发工具: Delphi XE 10.1 Berlin版本

可能所需的控件包： QDAC 请自行下载。

1. 接口描述

dll_init 接口初始化，程序启动时调用，主要是对工具类实例的创建
dll_post 发送post请求，支持http、https
dll_get 发送get请求，支持http、https
dll_uninit 接口释放，程序关闭时调用，主要是对工具类实例的释放

2. 参数说明

function dll_post(sUrl, sJson, sHeader: PWideChar; var sOut: PWideChar): Byte; stdcall;

function dll_get(sUrl, sJson, sHeader: PWideChar; var sOut: PWideChar): Byte; stdcall;

sUrl: 请求地址

sJson: 请求的入参，JSON格式如下(这个json只是一个例子，也可以是其他复杂json入参):

{ 
    "loginName": "*****",
    "loginPass": "*****"
}

sHeader: 请求头，固定格式如下，如果没有请求头，传空值:

{
    "params":[
        {"key":"key1","value":"value1"},
        {"key":"key2","value":"value2"},
    ]
}

sOut: 输出请求返回的数据信息

请求返回值 Byte类型 0 失败 1 成功

3. 完整代码如下

3.1 工具类

工具类实际就是内部创建了indy对象，一个用于http请求，一个用于https请求。

unit unt_objects;

interface

uses
  Winapi.Windows, Winapi.Messages, IdHTTP, IdSSLOpenSSL, System.SysUtils,
  System.Classes, System.IniFiles, System.StrUtils, System.Variants,
  Winapi.Security.Cryptography, Winapi.WinRT, Winapi.CommonTypes, System.Win.WinRT,
  Contnrs, Vcl.ExtCtrls, System.DateUtils;

const
  Err_02= '创建对象失败...';
  GFileName= 'set.ini';

type
  //普通Http请求
  TTools= class
  private
    FDebug    : Boolean;            //调试模式
    FHttp     : TIdHTTP;            //HTTP专用
    FHttps    : TIdHTTP;            //HTTPS专用
    FBusy     : Boolean;            //是否忙碌
    FIdSSL    : TIdSSLIOHandlerSocketOpenSSL;
    procedure DisConnect(bHttps: Boolean);
  published
    property _debug: Boolean read FDebug write FDebug;
    property _Https: TIdHTTP read FHttps write FHttps;
    property _Http: TIdHTTP read FHttp write FHttp;
    property _Busy: Boolean read FBusy write FBusy;
  public
    constructor Create();
    destructor Destroy; override;

    //发送Post请求
    function SendPost(bHttps: Boolean; sUrl, sJson: PWideChar; var sOut: PWideChar): Byte;
    //发送Get请求
    function SendGet(bHttps: Boolean; sUrl, sJson: PWideChar; var sOut: PWideChar): Byte;
  end;

implementation

uses uPub;

{ TTools }

constructor TTools.Create;
var
  sIni: TIniFile;
begin
  FHttp  := Tidhttp.Create(nil);
  FHttp.HTTPOptions := [hoKeepOrigProtocol];          //关键参数， 关系到编码自动转换
  FHttp.HandleRedirects:= True;
  FHttp.ProtocolVersion:= pv1_1;
  FHttp.Request.Accept:= '*/*';
  FHttp.Request.ContentType:= 'application/json;charset=UTF-8';
  FHttp.Request.Connection:= 'close';
  FHttp.ReadTimeout:= 30* 1000;
  FHttp.ConnectTimeout:= 30* 1000;

  FHttps  := Tidhttp.Create(nil);
  FHttps.HTTPOptions := [hoKeepOrigProtocol];
  FHttps.HandleRedirects:= True;
  FHttps.ProtocolVersion:= pv1_1;
  FHttps.Request.Accept:= '*/*';
  FHttps.Request.ContentType:= 'application/json;charset=UTF-8';
  FHttps.Request.Connection:= 'close';
  FHttps.ReadTimeout:= 30* 1000;
  FHttps.ConnectTimeout:= 30* 1000;

  FIdSSL  := TIdSSLIOHandlerSocketOpenSSL.Create(nil);
  FIdSSL.SSLOptions.Method:= sslvSSLv23;
  FIdSSL.SSLOptions.Mode:= sslmClient;

  if FileExists(ExtractFilePath(Paramstr(0))+GFileName) then
  begin
    sIni:= TIniFile.Create(ExtractFilePath(Paramstr(0))+GFileName);
    try
      case sIni.ReadInteger('hq','sslver',1) of
        0: FIdSSL.SSLOptions.Method:= sslvSSLv2;
        1: FIdSSL.SSLOptions.Method:= sslvSSLv23;
        2: FIdSSL.SSLOptions.Method:= sslvSSLv3;
        3: FIdSSL.SSLOptions.Method:= sslvTLSv1;
        4: FIdSSL.SSLOptions.Method:= sslvTLSv1_1;
        5: FIdSSL.SSLOptions.Method:= sslvTLSv1_2;
      end;
    finally
      FreeAndNil(sIni);
    end;
  end;

  FHttps.IOHandler:= FIdSSL;
end;

destructor TTools.Destroy;
begin
  if Assigned(FHttps) then
    FreeAndNil(FHttps);
  if Assigned(FHttp) then
    FreeAndNil(FHttp);
  inherited;
end;

procedure TTools.DisConnect(bHttps: Boolean);
begin
  if bHttps then
  begin
    if FHttps.Connected then
      FHttps.Disconnect;
  end
  else
  begin
    if FHttp.Connected then
      FHttp.Disconnect;
  end;
end;

function TTools.SendGet(bHttps: Boolean; sUrl, sJson: PWideChar; var sOut: PWideChar): Byte;
var
  ResponseStream: TStringStream;
begin
  Result:= 0;
  sOut:= '';
  DisConnect(bHttps);
  ResponseStream:= TStringStream.Create('', TEncoding.UTF8);
  try
    try
      systemLog('Snd: '+ sJson);
      FHttps.Get(sUrl, ResponseStream);
      sOut:= PWideChar(UTF8Decode(AnsiToUtf8(ResponseStream.DataString)));
      systemLog('Rcv: '+ sOut);
      Result:= 1;
    except
      on e: Exception do
      begin
        systemLog('exp: '+ e.Message);
      end;
    end;
  finally
    DisConnect(bHttps);
  end;
end;

function TTools.SendPost(bHttps: Boolean; sUrl, sJson: PWideChar; var sOut: PWideChar): Byte;
var
  ResquestStream,ResponseStream : TStringStream;
begin
  Result:= 0;
  sOut:= '';
  DisConnect(bHttps);
  try
    systemLog('Snd: '+ sJson);
    ResquestStream := TStringStream.Create(UTF8Encode(sJson));
    ResponseStream := TStringStream.Create('', TEncoding.UTF8);
    //ResponseStream := TStringStream.Create('');
    try
      if bHttps then
        FHttps.Post(sUrl, ResquestStream, ResponseStream)
      else
        FHttp.Post(sUrl, ResquestStream, ResponseStream);
      sOut := PWideChar(UTF8Decode(AnsiToUtf8(ResponseStream.DataString)));
      //sOut := PWideChar(UTF8Decode(WideString(ResponseStream.DataString)));
      systemLog('Rcv: '+ sOut);
      Result:= 1;
    except
      on e: Exception do
        systemLog('Exp: '+ e.Message);
    end;
  finally
    DisConnect(bHttps);
  end;
end;


end.

3.2 公共类

unit uPub;

interface

uses
  System.SysUtils, System.Classes, qaes, qstring, IdHashMessageDigest, IdHash;

type
  TMD5= class(TIdHashMessageDigest5);

  TAppPara = class
  public
    class function AppPath: string;
    class function AppName: string;
  end;

  TFilePath = class(TAppPara)
  public
    class function IniFile: string;
  end;

//写日志
procedure systemLog(Msg: AnsiString);
//AES对象初始化
procedure InitEncrypt(sKey, sIv: PWideChar; aesModel, keyType, paddingmodel: integer; var AES: TQAES);
//字符串转MD5
function StrToMD5(sIn: WideString): WideString;

implementation

procedure systemLog(Msg: AnsiString);
var
  F: TextFile;
  FileName: string;
  ExeRoad: string;
begin
  try
    ExeRoad := ExtractFilePath(ParamStr(0));
    if ExeRoad[Length(ExeRoad)] = '\' then
      SetLength(ExeRoad, Length(ExeRoad) - 1);
    if not DirectoryExists(ExeRoad + 'log') then
    begin
      CreateDir(ExeRoad + '\log');
    end;
    FileName := ExeRoad + '\log\DLL_Log' + FormatDateTime('YYMMDD', NOW) + '.txt';
    if not FileExists(FileName) then
    begin
      AssignFile(F, FileName);
      ReWrite(F);
    end
    else
      AssignFile(F, FileName);
    Append(F);
    Writeln(F, FormatDateTime('HH:NN:SS.zzz ', Now) + Msg);
    CloseFile(F);
  except
    //可能在事务中调用,避免意外
    Exit;
  end;
end;

procedure InitEncrypt(sKey, sIv: PWideChar; aesModel, keyType, paddingmodel: integer; var AES: TQAES);
var
  AInitVector: TQAESBuffer;
  AKeyType: TQAESKeyType;
  I: Integer;
begin
  case keyType of
    0:
      AKeyType := kt128;
    1:
      AKeyType := kt192;
    2:
      AKeyType := kt256;
  end;
  if aesModel= 0 then
    AES.AsECB(sKey, AKeyType)
  else
  begin
    for I := 1 to Length(sIv) do
      AInitVector[I-1]:= byte(sIv[I-1]);
    AES.AsCBC(AInitVector, sKey, AKeyType);
  end;
  //AES.PaddingMode在AES.AsECB  AES.AsCBC中是默认值的 所以在以下进行单独设置
  case paddingmodel of
    0:
      AES.PaddingMode:= pmZero;
    1:
      AES.PaddingMode:= pmPKCS5;
    2:
      AES.PaddingMode:= pmPKCS7;
  end;
end;

//字符串转MD5
function StrToMD5(sIn: WideString): WideString;
var
  Md5Encode: TMD5;
begin
  Md5Encode:= TMD5.Create;
  result:= Md5Encode.HashToHex(Md5Encode.HashString(UTF8Encode(sIn)));
  Md5Encode.Free;
end;

{ TAppPara }

class function TAppPara.AppName: string;
begin
  Result := ExtractFileName(ParamStr(0));
end;

class function TAppPara.AppPath: string;
begin
  Result := ExtractFilePath(ParamStr(0));
end;

{ TFilePath }

class function TFilePath.IniFile: string;
begin
  Result := AppPath + 'set.ini';
end;

end.

3.3 接口类

unit InterfaceDll;

interface

uses
  unt_objects, Winapi.Windows, System.SysUtils, System.Classes, EncdDecd, Qjson;

var
  tool: TTools;
  pools: THttpConnectopnPool;

//----------------------------------测试部分------------------------------------
//>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

//测试
function dll_test: Byte; stdcall;

//<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<

//-------------------------普通 网络请求部分------------------------------------
//>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

//初始化
function dll_init: Byte; stdcall;
//Post
function dll_post(sUrl, sJson, sHeader: PWideChar; var sOut: PWideChar): Byte; stdcall;
//Get
function dll_get(sUrl, sJson, sHeader: PWideChar; var sOut: PWideChar): Byte; stdcall;
//释放
function dll_uninit: Byte; stdcall;

//<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<

implementation

uses uPub, uSuperObject, qaes;

//测试
function dll_test: Byte; stdcall;
begin
  Result:= 1;
end;

//-------------------------普通 网络请求部分------------------------------------
//>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

//初始化
function dll_init: Byte;
begin
  Result:= 0;
  if not Assigned(tool) then
    tool:= TTools.Create;
  Result:= 1;
end;

/// <summary>
///   POST请求
/// </summary>
function dll_post(sUrl, sJson, sHeader: PWideChar; var sOut: PWideChar): Byte;
var
  json, jsArr: TQjson;
  I:integer;
  bHttps: Boolean;
begin
  Result:= 0;
  bHttps:= (Pos('https:', sUrl)>0);
  if Assigned(tool) then
  begin
    if tool._debug then
      systemLog('[dll_post]: '+ AnsiString(sJson));
    json:= TQJson.Create;
    try
      json.Parse(sHeader);
      tool._Https.Request.CustomHeaders.Clear;
      jsArr:= json.ItemByName('params');
      if jsArr<> nil then
      begin
        for I := 0 to jsArr.Count- 1 do
          tool._Https.Request.CustomHeaders.Values[jsArr.Items[I].ValueByName('key','')]:= jsArr.Items[I].ValueByName('value','')
      end;
    finally
      FreeAndNil(json);
    end;
    Result:= tool.SendPost(bHttps, sUrl, sJson, sOut);
  end
  else
  begin
    systemLog('[dll_post]: '+ Err_02);
    Exit;
  end;
end;

//Get
function dll_get(sUrl, sJson, sHeader: PWideChar; var sOut: PWideChar): Byte;
var
  json: ISuperObject;
  jsArr: TSuperArray;
  I:integer;
  bHttps: Boolean;
begin
  Result:= 0;
  sOut:= '';
  bHttps:= (Pos('https:', sUrl)>0);
  if Assigned(tool) then
  begin
    if tool._debug then
      systemLog('[dll_post]: '+ AnsiString(sJson));
    if sHeader<>'' then
      json:= SO(sHeader);
    if json<>nil then
    begin
      tool._Https.Request.CustomHeaders.Clear;
      jsArr:= json.O['headers'].AsArray;
      for I := 0 to jsArr.Length- 1 do
      begin
        if bHttps then
          tool._Https.Request.CustomHeaders.Values[jsArr.O[I].S['key']]:= jsArr.O[I].S['value']
        else
          tool._Https.Request.CustomHeaders.Values[jsArr.O[I].S['key']]:= jsArr.O[I].S['value'];
      end;
    end;
    Result:= tool.SendGet(bHttps, sUrl, sJson, sOut);
  end
  else
  begin
    systemLog('[dll_get]: '+ Err_02);
    Exit;
  end;
end;

//释放
function dll_uninit: Byte;
begin
  result:= 0;
  if Assigned(tool) then
    FreeAndNil(tool);
  result:= 1;
end;

//<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<


end.

3.4 工程文件

uses
  System.SysUtils,
  System.Classes,
  unt_objects in 'unt_objects.pas',
  uPub in 'uPub.pas',
  InterfaceDll in 'InterfaceDll.pas' {$R *.res},
  uSuperObject in '..\public\uSuperObject.pas';

{$R *.res}

exports

  dll_init,
  dll_post,
  dll_get,
  dll_uninit;

begin
end.

4. Demo引用

const
  dllName= 'HelpTool.dll';

  //普通网络请求部分

  function dll_init: Byte; stdcall; external dllName;

  function dll_post(sUrl, sJson, sHeader: PWideChar; var sOut: PWideChar): Byte; stdcall; external dllName;

  function dll_get(sUrl, sJson, sHeader: PWideChar; var sOut: PWideChar): Byte; stdcall; external dllName;

  function dll_uninit: Byte; stdcall; external dllName;

当前运用于实际项目中，跑了2个月了，运行正常，检查日志无报错。

有需要的朋友可以自行修改设计成自己需要的。

代码虽然贴出来了，但是还是希望能够自己敲下，加深理解。

如果有好的建议，或发现问题，请留言，我也好改进、学习.