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

tonyabbs

我有如下代码，用于将剪贴板的文字转为TXT文件。请问如何扩展一下，使得带有图文的剪贴板内容能够自动生成。比如是个ＤＯＣ文件？或者是PDF、HTML这种能够包含图片的？

Dim fso,wsh,ie,txt,filename
Set fso=CreateObject("Scripting.Filesystemobject")
Set wsh=CreateObject("Wscript.Shell")
Set ie=CreateObject("Internetexplorer.Application")
ie.visible=False
ie.navigate "about:blank"
'获取剪贴板内容
str=ie.document.parentwindow.clipboarddata.getdata("text")
filename=left(str,24)
'创建文本并写入内容
Set txt=fso.CreateTextFile(wsh.CurrentDirectory & "\0M" & filename & ".txt",false)
txt.WriteLine(str)
txt.Close
Wscript.Sleep 300
 
Set fso=Nothing:Set wsh=Nothing:Set ie=Nothing:Set txt=nothingCOPY

yu2n

VBS 使用 Word 保存剪贴板内容为 rtf 文档（图文格式）  By Yu2n  2015.04.06

' 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+vbInformationCOPY

tonyabbs

谢谢！
我想同时让生成的文件名是剪贴板中文字的前24个字符，怎么办？
也就是

objDoc.Content.Paste
objDoc.SaveAs WScript.ScriptFullName & ".rtf", wdFormatRTFCOPY

如何将objDoc.Content.Paste第一行的TEXT作为objDoc.SaveAs的文件名字？

yu2n

回复 3# tonyabbs

' 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 FunctionCOPY

VBS 关于提取WORD第二行的文字为文件名的方式
http://zhidao.baidu.com/link?url ... bSy87eeZi_Kb3zGSCR_

tonyabbs

太感谢了！

zhangop9

记录剪贴板中的图片