VBA/Corel Draw：如何从 Corel Draw 12/X4 运行的 VBA/VB6 脚本将 HTTP POST 请求中的二进制和文本文件发送到服务器？

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 工具窗格中添加了一个用户自定义按钮，并创建了一个宏以在按下此按钮时运行。该宏包含以下代码。

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编码。

学分：

• credit http://www.vbforums.com/showthread.php?t=337424 扩展了这个函数来实际发送原来使用 Winsock 的函数——但这在 Corel Draw 12/XIV 的 Visual Basic 应用程序环境中不可用所以我用 WinHttpRequest 替换了它

• credit: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=" & 边界线，以便服务器端代码接收帖子可以检索实际文件数据和其他参数

• 信用：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->录制的宏
4. 粘贴代码。注意：可能需要通过对象浏览器添加脚本所需的对象，例如 WinHttpRequest：View->Object Browser
5. 关闭，返回...
6. 返回 Corel Draw：工具->自定义
7. 在选项弹出对话框中：选项->自定义->命令栏
8. 点击新建
9. 工具栏名称导出到服务器
10. 点击确定
11. 将新创建的工具栏拖到顶部窗格中，它应该被“吸收”到其中。
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>

Answer 2

您可以将文件保存在本地，然后使用cURL 将数据发布到您的服务器（使用 VBA 中的 Shell 命令）。