Delphi Twebbrowser télécharger le fichier de téléchargement échouer

Question

J'essaie de télécharger des fichiers avec twebbrowser dans Delphi 10.1 Berlin. Tout est ok mais quand j'essaye de charger des fichiers unicode, delphi me donne une erreur "Dépassement lors de la conversion de la variante de type (Word) en type (Byte)". Comment puis-je corriger les fichiers Unicode?

procedure UploadFilesHttpPost(const wb:TWebBrowser; const URLstring: string; names, values, nFiles, vFiles: array of string) ; 
    var 
    strData, n, v, boundary: string; 
    URL: OleVariant; 
    Flags: OleVariant; 
    PostData: OleVariant; 
    Headers: OleVariant; 
    idx: Integer; 

    ms: TMemoryStream; 
    ss: TStringStream; 
    List: TStringList; 
begin 
    if (Length(names) <> Length(values)) then 
    raise Exception.Create('UploadFilesHttpPost: Names and Values must have the same length.') ; 
    if (Length(nFiles) <> Length(vFiles)) then 
    raise Exception.Create('UploadFilesHttpPost: FileNames and FileValues must have the same length.') ; 

    URL := 'about:blank'; 
    Flags := NavNoHistory or NavNoReadFromCache or NavNoWriteToCache or NavAllowAutosearch; 
    wb.Navigate2(URL, Flags) ; 
    while (wb.ReadyState <> READYSTATE_COMPLETE) or (wb.busy) do Application.ProcessMessages; 

    // anything random that WILL NOT occur in the data. 
    boundary := '---------------------------123456789'; 

    strData := ''; 
    for idx := Low(names) to High(names) do 
    begin 
    n := names[idx]; 
    v := values[idx]; 

    strData := strData + '--' + boundary + #13#10 + 'Content-Disposition: form-data; name="' + n + '"' + #13#10#13#10 + v + #13#10; 
    end; 

    for idx := Low(nFiles) to High(nFiles) do 
    begin 
    n := nFiles[idx]; 
    v := vFiles[idx]; 

    strData := strData + '--' + boundary + #13#10 + 'Content-Disposition: form-data; name="' + n + '"; filename="' + v + '"' + #13#10; 

    if v = '' then 
    begin 
     strData := strData + 'Content-Transfer-Encoding: binary'#13#10#13#10; 
    end 
    else 
    begin 
     if (CompareText(ExtractFileExt(v), '.JPG') = 0) or (CompareText(ExtractFileExt(v), '.JPEG') = 0) then 
     begin 
     strData := strData + 'Content-Type: image/pjpeg'#13#10#13#10; 
     end 
     else if (CompareText(ExtractFileExt(v), '.PNG') = 0) then 
     begin 
     strData := strData + 'Content-Type: image/x-png'#13#10#13#10; 
     end 
     else if (CompareText(ExtractFileExt(v), '.PDF') = 0) then 
     begin 
     strData := strData + 'Content-Type: application/pdf'#13#10#13#10; 
     end 
     else if (CompareText(ExtractFileExt(v), '.HTML') = 0) then 
     begin 
     end; 

     strData := strData + 'Content-Type: text/html'#13#10#13#10; 


     ms := TMemoryStream.Create; 
     try 
     ms.LoadFromFile(v) ; 
     ss := TStringStream.Create('') ; 
     try 
      ss.CopyFrom(ms, ms.Size) ; 

      strData := strData + ss.DataString + #13#10; 
     finally 
      ss.Free; 
     end; 
     finally 
     ms.Free; 
     end;  
    end; 

    strData := strData + '--' + boundary + '--'#13#10; // FOOTER 
    end; 

    strData := strData + #0; 

    {2. you must convert a string into variant array of bytes and every character from string is a value in array} 
    PostData := VarArrayCreate([0, Length(strData) - 1], varByte) ; 

    { copy the ordinal value of the character into the PostData array} 
    for idx := 1 to Length(strData) do PostData[idx-1] := Ord(strData[idx]) ; 

    {3. prepare headers which will be sent to remote web-server} 
    Headers := 'Content-Type: multipart/form-data; boundary=' + boundary + #13#10; 

    {4. you must navigate to the URL with your script and send as parameters your array with POST-data and headers} 
    URL := URLstring; 
    wb.Navigate2(URL, Flags, EmptyParam, PostData, Headers) ; 
    while (wb.ReadyState <> READYSTATE_COMPLETE) or (wb.busy) do Application.ProcessMessages; 
end; 

procedure TForm1.Button6Click(Sender: TObject); 
begin 
UploadFilesHttpPost(
    WebBrowser1, 
    'http://www.example.com/upload.php', 
    [], 
    [], 
    ['fileupload'], 
    ['c:\test.jpg']); 

end; 

Le problème apparaît lors de la copie de la valeur ordinale du caractère dans le tableau PostData, mais ne sait pas comment le gérer.

Answer 1

Vous utilisez une version Unicode de Delphi, où string est un alias pour UnicodeString, codé en UTF-16.

Vous essayez de publier des données binaires 8 bits en utilisant des chaînes Unicode, et cela ne fonctionnera tout simplement pas. Vous devez à la place coder en base64 les données binaires et définir l'en-tête Content-Transfer-Encoding sur base64 au lieu de binary. Toutefois, tous les serveurs HTTP ne prennent pas en charge base64 dans un message multipart/form-data.

Puisque multipart/form-data peut gérer des données binaires sans avoir à utiliser base64, vous devriez simplement publier des données binaires réelles telles quelles et ne pas les traiter comme des chaînes. Débarrassez-vous complètement du TStringStream, puis mettez toutes vos données MIME (texte et binaire) dans le TMemoryStream puis convertissez-le en un tableau d'octets pour TWebBrowser à envoyer.

Par exemple:

procedure WriteStringToStream(Stream: TStream; const S: string); 
var 
    U: UTF8String; 
begin 
    U := UTF8String(S); 
    Stream.WriteBuffer(PAnsiChar(U)^, Length(U)); 
end; 

procedure WriteLineToStream(Stream: TStream; const S: string = ''); 
begin 
    WriteStringToStream(Stream, S); 
    WriteStringToStream(Stream, #13#10); 
end; 

procedure UploadFilesHttpPost(const wb:TWebBrowser; const URLstring: string; names, values, nFiles, vFiles: array of string) ; 
var 
    boundary, ext: string; 
    Flags, Headers, PostData: OleVariant; 
    idx: Integer; 
    ms: TMemoryStream; 
    fs: TFileStream; 
    Ptr: Pointer; 
begin 
    if Length(names) <> Length(values) then 
    raise Exception.Create('UploadFilesHttpPost: Names and Values must have the same length.') ; 
    if Length(nFiles) <> Length(vFiles) then 
    raise Exception.Create('UploadFilesHttpPost: FileNames and FileValues must have the same length.') ; 

    Flags := NavNoHistory or NavNoReadFromCache or NavNoWriteToCache or NavAllowAutosearch 

    wb.Navigate2('about:blank', Flags); 
    while (wb.ReadyState <> READYSTATE_COMPLETE) or (wb.busy) do Application.ProcessMessages; 

    // anything random that WILL NOT occur in the data. 
    boundary := '---------------------------123456789'; 

    ms := TMemoryStream.Create; 
    try 
    for idx := Low(names) to High(names) do 
    begin 
     WriteLineToStream(ms, '--' + boundary); 
     WriteLineToStream(ms, 'Content-Disposition: form-data; name=' + AnsiQuotedStr(names[idx], #34)); 
     WriteLineToStream(ms); 
     WriteLineToStream(values[idx]); 
    end; 

    for idx := Low(nFiles) to High(nFiles) do 
    begin 
     WriteLineToStream(ms, '--' + boundary); 
     WriteLineToStream(ms, 'Content-Disposition: form-data; name=' + AnsiQuotedStr(nFiles[idx], #34) + '; filename=' + AnsiQuotedStr(ExtractFileName(vFiles[idx]), #34)); 
     WriteLineToStream(ms, 'Content-Transfer-Encoding: binary');  

     WriteStringToStream(ms, 'Content-Type: '); 
     ext := ExtractFileExt(vFiles[idx]); 
     if SameText(ext, '.JPG') or SameText(ext, '.JPEG') then 
     begin 
     WriteStringToStream(ms, 'imag/pjpeg'); 
     end 
     else if SameText(ext, '.PNG') then 
     begin 
     WriteStringToStream(ms, 'image/x-png'); 
     end 
     else if SameText(ext, '.PDF') then 
     begin 
     WriteStringToStream(ms, 'application/pdf'); 
     end 
     else if SameText(ext, '.HTML') then 
     begin 
     WriteStringToStream(ms, 'text/html'); 
     end else 
     begin 
     WriteStringToStream(ms, 'application/octet-stream'); 
     end; 
     WriteLineToStream(ms); 

     WriteLineToStream(ms); 

     fs := TFileStream.Create(vFiles[idx], fmOpenRead or fmShareDenyWrite); 
     try 
     ms.CopyFrom(fs, 0); 
     finally 
     fs.Free; 
     end; 

     WriteLineToStream(ms); 
    end; 

    WriteLineToStream('--' + boundary + '--'); 

    PostData := VarArrayCreate([0, ms.Size-1], varByte); 
    Ptr := VarArrayLock(PostData); 
    try 
     Move(ms.Memory^, Ptr^, ms.Size); 
    finally 
     VarArrayUnlock(PostData); 
    end; 
    finally 
    ms.Free; 
    end; 

    Headers := 'Content-Type: multipart/form-data; boundary=' + boundary + #13#10; 

    wb.Navigate2(URLstring, Flags, EmptyParam, PostData, Headers); 
    while (wb.ReadyState <> READYSTATE_COMPLETE) or (wb.busy) do Application.ProcessMessages; 
end; 

procedure TForm1.Button6Click(Sender: TObject); 
begin 
    UploadFilesHttpPost(
    WebBrowser1, 
    'http://www.example.com/upload.php', 
    [], 
    [], 
    ['fileupload'], 
    ['c:\test.jpg'] 
); 
end; 

Cela dit, TWebBrowser est un composant visuel , vous devriez vraiment pas l'utiliser de cette manière pour commencer. Une meilleure option serait d'utiliser un composant HTTP non-visuel/bibliothèque à la place, comme composant d'Indy TIdHTTP:

uses 
    IdHTTP, IdMultipartFormDataStream; 

procedure UploadFilesHttpPost(const URLstring: string; names, values, nFiles, vFiles: array of string) ; 
var 
    idx: Integer; 
    HTTP: TIdHTTP; 
    PostData: TIdMultipartFormDataStream; 
begin 
    if Length(names) <> Length(values) then 
    raise Exception.Create('UploadFilesHttpPost: Names and Values must have the same length.') ; 
    if Length(nFiles) <> Length(vFiles) then 
    raise Exception.Create('UploadFilesHttpPost: FileNames and FileValues must have the same length.') ; 

    HTTP := TIdHTTP.Create; 
    try 
    PostData := TIdMultipartFormDataStream.Create; 
    try 
     for idx := Low(names) to High(names) do 
     begin 
     PostData.AddFormField(names[idx], values[idx]); 
     end; 
     for idx := Low(nFiles) to High(nFiles) do 
     begin 
     PostData.AddFile(nFiles[idx], vFiles[idx]); 
     end; 
     HTTP.Post(URLstring, PostData); 
    finally 
     PostData.Free; 
    end; 
    finally 
    HTTP.Free; 
    end; 
end; 

procedure TForm1.Button6Click(Sender: TObject); 
begin 
    UploadFilesHttpPost(
    'http://www.example.com/upload.php', 
    [], 
    [], 
    ['fileupload'], 
    ['c:\test.jpg'] 
); 
end;