http - VBA/Corel 绘图 : How to send binary and text file in HTTP POST request to server from VBA/VB6 script running from Corel Draw 12/X4?

Question

我想通过 HTTP POST 将 Corel Draw .CDR 绘图二进制文件和 XML SVG 文件从应用程序发送到服务器。

我做了一些研究，这个现有的帖子似乎最接近但不适合我的情况: How can I send an HTTP POST request to a server from Excel using VBA?

我已将一个用户自定义按钮添加到 Corel Draw 工具 Pane ，并创建了一个宏以在按下此按钮时运行。该宏包含以下代码。

Sub OpenLabelPrintExport()
    '
    ' Recorded 24/06/2008
    '
    ' Description:
    '
    '

' Add a reference to Microsoft WinHTTP Services
Const HTTPREQUEST_SETCREDENTIALS_FOR_SERVER = 0

    'MsgBox "hello"

    Dim expflt As ExportFilter
    Dim expopt As StructExportOptions
    Dim responseText As String
    Set expopt = New StructExportOptions
    expopt.UseColorProfile = False
    ' expopt.DontExportFonts
    Set expflt = ActiveDocument.ExportEx("C:\afile.svg", cdrSVG, cdrAllPages, expopt)
    expflt.Finish

    file = "C:\afile.svg"

    Dim oS As ADODB.STREAM
    Set oS = New STREAM

    oS.Type = 2
    oS.Open
    oS.LoadFromFile file

    Dim contentlength As Integer
    contentlength = oS.Size

sEntityBody = "-----boundary" & vbCrLf
sEntityBody = sEntityBody & "Content-Dispostion: form-data; name=fileInputElementName; filename=""" + sFileName + """" & vbCrLf
sEntityBody = sEntityBody & "Content-Transfer-Encoding: 7bit" & vbCrLf
sEntityBody = sEntityBody & "Content-Type: text/xml" & vbCrLf & vbCrLf
' did use oS
sEntityBody = sEntityBody & "text" & vbCrLf
sEntityBody = sEntityBody & "-----boundary--" & vbCrLf & vbCrLf

' Set xhr = New MSXML2.XMLHTTP30

Dim xhr As WinHttp.WinHttpRequest
Set xhr = New WinHttpRequest

xhr.Open "POST", sUrl, False
xhr.SetRequestHeader "Content-Type", "multipart/form-data; boundary=""-----boundary"""
xhr.Send sEntityBody

End Sub

在我的服务器上，我有以下 Perl CGI 脚本来接受文件:

#!/usr/bin/perl -wT

use strict;
use CGI;
use CGI::Carp qw ( fatalsToBrowser );
use File::Basename;

$CGI::POST_MAX = 1024 * 5000;
my $safe_filename_characters = "a-zA-Z0-9_.-";
my $upload_dir = "/usr/lib/cgi-bin/";

my $query = new CGI;
my $filename = $query->param("file");
my $email_address = $query->param("email_address");

if ( !$filename )
{
 print $query->header ( );
 print "There was a problem uploading your file (try a smaller file).";
 exit;
}

my ( $name, $path, $extension ) = fileparse ( $filename, '\..*' );
$filename = $name . $extension;
$filename =~ tr/ /_/;
$filename =~ s/[^$safe_filename_characters]//g;

if ( $filename =~ /^([$safe_filename_characters]+)$/ )
{
 $filename = $1;
}
else
{
 die "Filename contains invalid characters";
}

my $upload_filehandle = $query->upload("file");

open ( UPLOADFILE, ">$upload_dir/$filename" ) or die "$!";
binmode UPLOADFILE;

while (  )
{
 print UPLOADFILE;
}

close UPLOADFILE;

print STDOUT "success";

我已经在浏览器上用 HTML 表单测试了服务器端脚本。

我想就如何让在 Corel Draw 中运行的 VBA 脚本正常工作提出建议。对于通过 HTTP POST 从支持 VBA 的应用程序向服务器发送二进制文件和文本文件，我搜索了又搜索，但似乎找不到明确的答案。我也买了一些关于这个主题的书，但并不聪明。

我需要它来使用 Corel Draw 12 和 Corel Draw X4。

提前致谢。

Answer 1

这是适用于 Corel Draw 12 的工作解决方案。它用于导出 SVG - 它可以扩展为使用 Corel 为 Visual Basic 应用程序环境提供的导出器对象同时导出 .CDR 和 .PDF。对于这两种二进制格式，在发送前可能需要进行base64编码。

学分:

• 信用 http://www.vbforums.com/showthread.php?t=337424扩展此功能以实际发送最初使用 Winsock 的功能 - 但这在 Corel Draw 12/XIV 的 Visual Basic 应用程序环境中不可用所以我将其替换为 WinHttpRequest

• 来源:http://bytes.com/topic/asp-classic/answers/659406-winhttprequest-posting-byte-string-multipart-message-howto#post2618801 - 用于添加 WinHttpRequest 中所需的 req.setRequestHeader "Content-Type", "multipart/form-data; boundary="& boundary line 以便服务器端代码在接收帖子时可以检索实际文件数据和其他参数

• 来源:http://word.mvps.org/faqs/macrosvba/DeleteFiles.htm删除临时文件

下面提供的解决方案的四个部分:

1. 安装 Corel Draw Visual Basic 应用程序代码的说明(下面的第 2 部分)
2. Corel Draw Visual Basic 应用程序代码
3. 服务器端 Perl CGI 脚本接受作为标准 HTTP POST CGI 消息发送的文件
4. 测试 html 表单网页只是为了测试服务器端 Perl cgi 脚本

1) 说明

1. Corel Draw:工具->Visual Basic->Visual Basic 编辑器
2. 返回 Microsoft Visual Basic:查看 -> 项目资源管理器
3. 打开 FileConverter->Modules->Recorded Macros
4. 粘贴代码。注意:可能需要通过对象浏览器添加脚本所需的对象，例如 WinHttpRequest:View->Object Browser
5. 关闭，回到...
6. 返回 Corel Draw:工具 -> 自定义
7. 在选项弹出对话框中:选项->自定义->命令栏
8. 点击新建
9. 为工具栏名称导出到服务器
10. 点击确定
11. 将新创建的工具栏拖到顶部 Pane 中，它应该被“吸收”到其中。
12. 右键单击它
13. 自定义->导出到服务器工具栏->添加新命令
14. 从“选项”对话框的下拉菜单中选择宏
15. 查找 FileConverter.RecordedMacros.DrawingExportToServer
16. 将其拖放到新创建的空白“导出到服务器”工具栏上以创建按钮
17. 要将绘图导出到服务器:照常创建绘图并单击按钮

2) Corel Draw Visual Basic 应用代码

Type URL
    Scheme As String
    Host As String
    Port As Long
    URI As String
    Query As String
End Type

Sub DrawingExportToServer()

    Dim expflt As ExportFilter
    Dim expopt As StructExportOptions
    Dim responseText As String
    Set expopt = New StructExportOptions
    expopt.UseColorProfile = False

    ' moved from BuildFileUploadRequest to here
    ' want to re-use this for generating a temporary file name that has minimal risk of clashing/overwriting an other temporary files
    Dim strBoundary As String
    strBoundary = RandomAlphaNumString(32)

    Dim tempExportFile As String
    tempExportFile = "C:\WINDOWS\Temp\tempExportFileCorelDraw_" & strBoundary & ".svg"

    Set expflt = ActiveDocument.ExportEx(tempExportFile, cdrSVG, cdrAllPages, expopt)
    expflt.Finish

    Dim realFilenameOfDrawing As String
    realFilenameOfDrawing = ActiveDocument.FileName
    realFilenameOfDrawing = realFilenameOfDrawing & ".svg"

    Dim strFile As String
    strFile = GetFileContents(tempExportFile)
    Dim strHttp As String

    sUrl = "http://myserver.com/cgi-bin/server_side_perl_script.cgi"

    Dim DestUrl As URL
    DestUrl = ExtractUrl(sUrl)

    strHttp = BuildFileUploadRequest(strFile, DestUrl, "file", realFilenameOfDrawing, "text/xml", strBoundary, sUrl)


    KillProperly (tempExportFile)

End Sub

' credit http://www.vbforums.com/showthread.php?t=337424
' extended this function to actually do the sending
' originally the function used Winsock - but this is unavailable in the Visual Basic Application environment of Corel Draw 12/XIV
' So I replaced this with a WinHttpRequest
' credit: http://bytes.com/topic/asp-classic/answers/659406-winhttprequest-posting-byte-string-multipart-message-howto#post2618801
' - for adding the req.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & boundary
' line which is required in WinHttpRequest so that the server-side  code on receiving the post can retrieve the actual file data and other params
Private Function BuildFileUploadRequest(ByRef strData As String, _
                                        ByRef DestUrl As URL, _
                                        ByVal UploadName As String, _
                                        ByVal FileName As String, _
                                        ByVal MimeType As String, _
                                        ByVal aStrBoundary As String, _
                                        ByVal aUrlString As String) As String

    Dim strHttp As String ' holds the entire HTTP request
    Dim strBoundary As String 'the boundary between each entity
    Dim strBody As String ' holds the body of the HTTP request
    Dim lngLength As Long ' the length of the HTTP request

    ' create a boundary consisting of a random string
    'strBoundary = RandomAlphaNumString(32)
    strBoundary = aStrBoundary

    ' create the body of the http request in the form
    '
    ' --boundary
    ' Content-Disposition: form-data; name="UploadName"; filename="FileName"
    ' Content-Type: MimeType
    '
    ' file data here
    '--boundary--
    strBody = "--" & strBoundary & vbCrLf
    strBody = strBody & "Content-Disposition: form-data; name=""" & UploadName & """; filename=""" & _
                    FileName & """" & vbCrLf
    strBody = strBody & "Content-Type: " & MimeType & vbCrLf
    strBody = strBody & vbCrLf & strData
    strBody = strBody & vbCrLf & "--" & strBoundary & "--"

    ' find the length of the request body - this is required for the
    ' Content-Length header
    lngLength = Len(strBody)

    ' construct the HTTP request in the form:
    '
    ' POST /path/to/reosurce HTTP/1.0
    ' Host: host
    ' Content-Type: multipart-form-data, boundary=boundary
    ' Content-Length: len(strbody)
    '
    ' HTTP request body
    strHttp = "POST " & DestUrl.URI & "?" & DestUrl.Query & " HTTP/1.0" & vbCrLf
    strHttp = strHttp & "Host: " & DestUrl.Host & vbCrLf
    strHttp = strHttp & "Content-Type: multipart/form-data, boundary=" & strBoundary & vbCrLf
    strHttp = strHttp & "Content-Length: " & lngLength & vbCrLf & vbCrLf
    strHttp = strHttp & strBody


    Dim ContentType As String

    Dim xhr As New WinHttp.WinHttpRequest

    Dim anUploadName As String
    anUploadName = "file"

    Dim aFileName As String
    aFileName = "file"

    Dim aContentType As String
    aMimeType = "text/xml"

    ContentType = "multipart/form-data, boundary=" & strBoundary & vbCrLf

    xhr.Open "POST", aUrlString, False

    xhr.SetRequestHeader "Content-Type", ContentType

    xhr.Send strHttp

    BuildFileUploadRequest = strHttp
End Function



' this function retireves the contents of a file and returns it as a string
' this is also ture for binary files
Private Function GetFileContents(ByVal strPath As String) As String
    Dim StrReturn As String
    Dim lngLength As Long

    lngLength = FileLen(strPath)
    StrReturn = String(lngLength, Chr(0))

    On Error GoTo ERR_HANDLER

    Open strPath For Binary As #1

    Get #1, , StrReturn

    GetFileContents = StrReturn

    Close #1

    Exit Function

ERR_HANDLER:
    MsgBox Err.Description, vbCritical, "ERROR"

    Err.Clear
End Function


' generates a random alphanumeirc string of a given length
Private Function RandomAlphaNumString(ByVal intLen As Integer)
    Dim StrReturn As String

    Dim X As Integer
    Dim c As Byte

    Randomize

    For X = 1 To intLen
        c = Int(Rnd() * 127)

        If (c >= Asc("0") And c <= Asc("9")) Or _
           (c >= Asc("A") And c <= Asc("Z")) Or _
           (c >= Asc("a") And c <= Asc("z")) Then

            StrReturn = StrReturn & Chr(c)
        Else
            X = X - 1
        End If
    Next X

    RandomAlphaNumString = StrReturn
End Function





' returns as type URL from a string
Function ExtractUrl(ByVal strUrl As String) As URL
    Dim intPos1 As Integer
    Dim intPos2 As Integer

    Dim retURL As URL

    '1 look for a scheme it ends with ://
    intPos1 = InStr(strUrl, "://")

    If intPos1 > 0 Then
        retURL.Scheme = Mid(strUrl, 1, intPos1 - 1)
        strUrl = Mid(strUrl, intPos1 + 3)
    End If

    '2 look for a port
    intPos1 = InStr(strUrl, ":")
    intPos2 = InStr(strUrl, "/")

    If intPos1 > 0 And intPos1 < intPos2 Then
        ' a port is specified
        retURL.Host = Mid(strUrl, 1, intPos1 - 1)

        If (IsNumeric(Mid(strUrl, intPos1 + 1, intPos2 - intPos1 - 1))) Then
                retURL.Port = CInt(Mid(strUrl, intPos1 + 1, intPos2 - intPos1 - 1))
        End If
    ElseIf intPos2 > 0 Then
        retURL.Host = Mid(strUrl, 1, intPos2 - 1)
    Else
        retURL.Host = strUrl
        retURL.URI = "/"

        ExtractUrl = retURL
        Exit Function
    End If

    strUrl = Mid(strUrl, intPos2)

    ' find a question mark ?
    intPos1 = InStr(strUrl, "?")

    If intPos1 > 0 Then
        retURL.URI = Mid(strUrl, 1, intPos1 - 1)
        retURL.Query = Mid(strUrl, intPos1 + 1)
    Else
        retURL.URI = strUrl
    End If

    ExtractUrl = retURL
End Function

' url encodes a string
Function URLEncode(ByVal str As String) As String
        Dim intLen As Integer
        Dim X As Integer
        Dim curChar As Long
        Dim newStr As String

        intLen = Len(str)
        newStr = ""

        ' encode anything which is not a letter or number
        For X = 1 To intLen
            curChar = Asc(Mid$(str, X, 1))


            If curChar = 32 Then
                ' we can use a + sign for a space
                newStr = newStr & "+"
            ElseIf (curChar < 48 Or curChar > 57) And _
                (curChar < 65 Or curChar > 90) And _
                (curChar < 97 Or curChar > 122) Then


                newStr = newStr & "%" & Hex(curChar)
            Else
                newStr = newStr & Chr(curChar)
            End If
        Next X

        URLEncode = newStr
End Function

' decodes a url encoded string
Function UrlDecode(ByVal str As String) As String
        Dim intLen As Integer
        Dim X As Integer
        Dim curChar As String * 1
        Dim strCode As String * 2

        Dim newStr As String

        intLen = Len(str)
        newStr = ""

        For X = 1 To intLen
            curChar = Mid$(str, X, 1)

            If curChar = "%" Then
                strCode = "&h" & Mid$(str, X + 1, 2)

                If IsNumeric(strCode) Then
                    curChar = Chr(Int(strCode))
                Else
                    curChar = ""
                End If
                                X = X + 2
            End If

            newStr = newStr & curChar
        Next X

        UrlDecode = newStr
End Function

' credit: http://word.mvps.org/faqs/macrosvba/DeleteFiles.htm
Public Sub KillProperly(Killfile As String)
    If Len(Dir$(Killfile)) > 0 Then
        SetAttr Killfile, vbNormal
        Kill Killfile
    End If
End Sub

3) 服务器端 Perl CGI 脚本接受作为标准 HTTP POST CGI 消息发送的文件

#!/usr/bin/perl -w 

use strict;
use warnings;

use CGI;
use CGI::Carp qw ( fatalsToBrowser );
use File::Basename;

sub main
{
  my $rc = 0;
  my $errorMsg = "";

  $CGI::POST_MAX = 1024 * 5000;
  my $safe_filename_characters = "a-zA-Z0-9_.-";

  # NOTE: make sure that appropriate chmod permissions are set so that the script can create and write files to this directory
  my $upload_top_level = "/usr/lib/cgi-bin/drawings";

  # NOTE: make sure that appropriate chmod permissions are set in this file's parent holding directory and the file itself if already exists 
  # so that the script can create and write the file
  my $upload_log = "/usr/lib/cgi-bin/uploadlog.txt";


  my $query = new CGI;
  my $filename = $query->param("file");
  my $machineid = $query->param("machineid");

  my %allParams = $query->Vars;

  my $allParamsAsString = "";

  my $paramName = "";
  foreach $paramName ( keys ( %allParams ) )
  {
    $allParamsAsString .= "$paramName=".$allParams{$paramName};
  }

  if ( !$filename )
  {
   $rc = 1;
   $errorMsg = "Filename not specified.";
  }

  if ( $rc == 0 )
  {
    my ( $name, $path, $extension ) = fileparse ( $filename, '\..*' );
    $filename = $name . $extension;
    $filename =~ tr/ /_/;
    $filename =~ s/[^$safe_filename_characters]//g;

    if ( $filename =~ /^([$safe_filename_characters]+)$/ )
    {
     $filename = $1;
    }
    else
    {
     $rc = 1;
     $errorMsg = "Filename contains invalid characters.";
    }
  }

  if ( $rc == 0)
  {
    my $upload_filehandle = $query->upload("file"); # file is the file field in the form

    my $upload_path = "";

    # if a machine id is provided
    # then we make a subdirectory off of the main top level uploads directory
    if ( $machineid )
    {
      $upload_path = $upload_top_level."/".$machineid."/";

      if (!( -e $upload_path ))
      {
        mkdir $upload_path;
      }
    }
    else
    {
      $upload_path = $upload_top_level."/";
    }

    unless( open ( UPLOADFILE, ">$upload_path/$filename" ) )
    {
      $rc = 1;
      $errorMsg = "Cannot open $upload_path/$filename";
    }

    if ( $rc == 0 )
    {
      binmode UPLOADFILE;

      while ( <$upload_filehandle> )
      {
        print UPLOADFILE;
      }

      close UPLOADFILE;

      print STDOUT $query->header();
      $errorMsg = "Success.";
      print STDOUT responseToClient( "Success." );
    }
  }
  else
  {
    print STDOUT $query->header();
    print STDOUT responseToClient( $errorMsg );
  }

  # needs (f)locking
  open ( LOG, ">>$upload_log" );
  print LOG $filename.", ".$machineid.", ".$errorMsg.", ".$query->all_parameters.", ".$allParamsAsString."\n";
  close ( LOG );


}


sub responseToClient
{
  my ( $message ) = @_;

  my $response =
    "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"DTD/xhtml1-strict.dtd\">\n"
   ."<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\">\n"
   ."<head>\n"
   ."<meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\" />\n"
   ."<title>".$message."</title>\n"
   ."</head>\n"
   ."<body>\n"
   ."<p>".$message."</p>\n"
   ."</body>\n"
   ."</html>\n\n";

  return $response;
}

main ();

4) 测试 html 表单网页只是为了测试服务器端 Perl cgi 脚本

<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
 <head>
   <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
   <title>File Upload</title>
 </head>
 <body>
   <form action="/cgi-bin/nsr_store_label.cgi" method="post"  
enctype="multipart/form-data">
     <p>File to Upload: <input type="file" name="file" /></p>
     <p>Machine id: <input type="text" name="machineid" /></p>
     <p><input type="submit" name="Submit" value="Submit Form" /></p>
   </form>
 </body>
</html>