[问题求助] 【已解决】VBS如何根据剪贴板内容生成本机文件（含文字和图片）？

' clipboard2rtf.vbs  By Yu2n  2015.04.06
On Error Resume Next
Const msoAutomationSecurityForceDisable = 3
Const wdFormatRTF = 6
Set objWord = CreateObject("Word.Application")
If Not Err.Number = 0 Then
  Msgbox "错误：无法创建 Word 对象，你可能没有安装 Office 。", vbSystemModal+vbCritical, WScript.ScriptName
  WScript.Quit(999)
End If
If Not objWord.Application.Version >= 12.0 Then
  Msgbox "警告：请使用 Office 2007 以上版本。", vbSystemModal+vbExclamation, WScript.ScriptName
End If
objWord.Visible = False
objWord.DisplayAlerts = False
objWord.AutomationSecurity = msoAutomationSecurityForceDisable
Set objDoc = objWord.Documents.Add
objDoc.Content.Paste
objDoc.SaveAs WScript.ScriptFullName & ".rtf", wdFormatRTF
objDoc.Close False
objWord.Quit
CreateObject("Wscript.Shell").popup "完成！" & String(3,vbTab),6,WScript.ScriptName,vbSystemModal+vbInformation
复制代码

objDoc.Content.Paste
objDoc.SaveAs WScript.ScriptFullName & ".rtf", wdFormatRTF
复制代码

' clipboard2rtf.vbs  By Yu2n  2015.04.17 R2
Main
Sub Main()
  On Error Resume Next
  Const msoAutomationSecurityForceDisable = 3
  Const wdFormatRTF = 6             ' *.rtf
  Dim objWord, objDoc, strFile, strName, strContent
  Set objWord = CreateObject("Word.Application")
  If Not Err.Number = 0 Then
    Msgbox "错误：无法创建 Word 对象，你可能没有安装 Office 。", vbSystemModal+vbCritical, WScript.ScriptName
    WScript.Quit(999)
  End If
  If Not objWord.Application.Version >= 12.0 Then
    Msgbox "警告：请使用 Office 2007 以上版本。", vbSystemModal+vbExclamation, WScript.ScriptName
  End If
  objWord.Visible = False
  objWord.DisplayAlerts = False
  objWord.AutomationSecurity = msoAutomationSecurityForceDisable
  Set objDoc = objWord.Documents.Add
  objDoc.Content.Paste
  strContent = objDoc.Content
  If strContent <> "" And Err.Number = 0 Then
    strName = GetSafeFileName(strContent, 24)
    If strName = "" Then strName = Year(Now) & Right("0"& Month(Now),2) & Right("0"& Day(Now),2) & "." & _
                                    Right("0"& Hour(Now),2) & Right("0"& Minute(Now),2) & Right("0"& Second(Now),2)
    strFile = Left(WScript.ScriptFullName,InStrRev(WScript.ScriptFullName,"\")) & strName & ".rtf"
    strFile = GetUniqueFileName(strFile)
    objDoc.SaveAs strFile, wdFormatRTF
  End If
  objDoc.Close False
  objWord.Quit
  If strFile <> "" Then
    CreateObject("Wscript.Shell").popup "完成！" & String(3,vbTab),6,WScript.ScriptName,vbSystemModal+vbInformation
  Else
    CreateObject("Wscript.Shell").popup "提示！没有找到剪贴板中的图文内容，请复制图文内容后执行本程序。" & String(3,vbTab),6,WScript.ScriptName,vbSystemModal+vbExclamation
  End If
End Sub

' 过滤文件名里面的无效字符
Function GetSafeFileName(ByVal strFileName, ByVal nMaxLen)
  Dim strSafeChar, strUnsafeChar, nIndex, strChr, strOut
  strSafeChar = "!#$%&'()+,-." & Chr(32)
  strUnsafeChar = "\/:*?""<>|" & vbCrLf
  For nIndex = 0 To &H2F
    If InStr(strSafeChar & strUnsafeChar, Chr(nIndex)) = 0 Then strUnsafeChar = strUnsafeChar & Chr(nIndex)
  Next
  For nIndex = 1 To Len(strUnsafeChar)
    strFileName = Replace(strFileName, Mid(strUnsafeChar, nIndex, 1), Chr(32))
  Next
  GetSafeFileName = Left(Trim(strFileName), nMaxLen)
End Function

' 获取不重复的文件名，如果有重名则在文件名后面附加“_1”、“_2”……
Function GetUniqueFileName(strFullName)
  Dim fso, strParentFolder, strBaseName, strExtensionName
  Dim nIndex
  Set fso = CreateObject("Scripting.FileSystemObject")
  If Not fso.FileExists(strFullName) Then
    GetUniqueFileName = strFullName
    Exit Function
  End If
  strParentFolder = fso.GetParentFolderName(strFullName)
  strBaseName = fso.GetBaseName(strFullName)
  strExtensionName = fso.GetExtensionName(strFullName)
  nIndex = 0
  While fso.FileExists(strFullName)
    nIndex = nIndex + 1
    strFullName = fso.BuildPath(strParentFolder, strBaseName & "_" & nIndex & "." & strExtensionName)
  Wend
  GetUniqueFileName = strFullName
End Function
复制代码