Board logo

标题: [问题求助] 【已解决】VBS如何根据剪贴板内容生成本机文件(含文字和图片)? [打印本页]

作者: tonyabbs    时间: 2015-4-5 23:36     标题: 【已解决】VBS如何根据剪贴板内容生成本机文件(含文字和图片)?

本帖最后由 tonyabbs 于 2015-4-15 23:30 编辑

我有如下代码,用于将剪贴板的文字转为TXT文件。请问如何扩展一下,使得带有图文的剪贴板内容能够自动生成。比如是个DOC文件?或者是PDF、HTML这种能够包含图片的?
  1. Dim fso,wsh,ie,txt,filename
  2. Set fso=CreateObject("Scripting.Filesystemobject")
  3. Set wsh=CreateObject("Wscript.Shell")
  4. Set ie=CreateObject("Internetexplorer.Application")
  5. ie.visible=False
  6. ie.navigate "about:blank"
  7. '获取剪贴板内容
  8. str=ie.document.parentwindow.clipboarddata.getdata("text")
  9. filename=left(str,24)
  10. '创建文本并写入内容
  11. Set txt=fso.CreateTextFile(wsh.CurrentDirectory & "\0M" & filename & ".txt",false)
  12. txt.WriteLine(str)
  13. txt.Close
  14. Wscript.Sleep 300
  15. Set fso=Nothing:Set wsh=Nothing:Set ie=Nothing:Set txt=nothing
复制代码

作者: yu2n    时间: 2015-4-6 22:35

VBS 使用 Word 保存剪贴板内容为 rtf 文档(图文格式)  By Yu2n  2015.04.06
  1. ' clipboard2rtf.vbs  By Yu2n  2015.04.06
  2. On Error Resume Next
  3. Const msoAutomationSecurityForceDisable = 3
  4. Const wdFormatRTF = 6
  5. Set objWord = CreateObject("Word.Application")
  6. If Not Err.Number = 0 Then
  7.   Msgbox "错误:无法创建 Word 对象,你可能没有安装 Office 。", vbSystemModal+vbCritical, WScript.ScriptName
  8.   WScript.Quit(999)
  9. End If
  10. If Not objWord.Application.Version >= 12.0 Then
  11.   Msgbox "警告:请使用 Office 2007 以上版本。", vbSystemModal+vbExclamation, WScript.ScriptName
  12. End If
  13. objWord.Visible = False
  14. objWord.DisplayAlerts = False
  15. objWord.AutomationSecurity = msoAutomationSecurityForceDisable
  16. Set objDoc = objWord.Documents.Add
  17. objDoc.Content.Paste
  18. objDoc.SaveAs WScript.ScriptFullName & ".rtf", wdFormatRTF
  19. objDoc.Close False
  20. objWord.Quit
  21. CreateObject("Wscript.Shell").popup "完成!" & String(3,vbTab),6,WScript.ScriptName,vbSystemModal+vbInformation
复制代码

作者: tonyabbs    时间: 2015-4-9 18:05

本帖最后由 tonyabbs 于 2015-4-14 22:39 编辑

谢谢!
我想同时让生成的文件名是剪贴板中文字的前24个字符,怎么办?
也就是
  1. objDoc.Content.Paste
  2. objDoc.SaveAs WScript.ScriptFullName & ".rtf", wdFormatRTF
复制代码
如何将objDoc.Content.Paste第一行的TEXT作为objDoc.SaveAs的文件名字?
作者: yu2n    时间: 2015-4-15 17:40

本帖最后由 yu2n 于 2015-4-17 16:09 编辑

回复 3# tonyabbs
  1. ' clipboard2rtf.vbs  By Yu2n  2015.04.17 R2
  2. Main
  3. Sub Main()
  4.   On Error Resume Next
  5.   Const msoAutomationSecurityForceDisable = 3
  6.   Const wdFormatRTF = 6             ' *.rtf
  7.   Dim objWord, objDoc, strFile, strName, strContent
  8.   Set objWord = CreateObject("Word.Application")
  9.   If Not Err.Number = 0 Then
  10.     Msgbox "错误:无法创建 Word 对象,你可能没有安装 Office 。", vbSystemModal+vbCritical, WScript.ScriptName
  11.     WScript.Quit(999)
  12.   End If
  13.   If Not objWord.Application.Version >= 12.0 Then
  14.     Msgbox "警告:请使用 Office 2007 以上版本。", vbSystemModal+vbExclamation, WScript.ScriptName
  15.   End If
  16.   objWord.Visible = False
  17.   objWord.DisplayAlerts = False
  18.   objWord.AutomationSecurity = msoAutomationSecurityForceDisable
  19.   Set objDoc = objWord.Documents.Add
  20.   objDoc.Content.Paste
  21.   strContent = objDoc.Content
  22.   If strContent <> "" And Err.Number = 0 Then
  23.     strName = GetSafeFileName(strContent, 24)
  24.     If strName = "" Then strName = Year(Now) & Right("0"& Month(Now),2) & Right("0"& Day(Now),2) & "." & _
  25.                                     Right("0"& Hour(Now),2) & Right("0"& Minute(Now),2) & Right("0"& Second(Now),2)
  26.     strFile = Left(WScript.ScriptFullName,InStrRev(WScript.ScriptFullName,"\")) & strName & ".rtf"
  27.     strFile = GetUniqueFileName(strFile)
  28.     objDoc.SaveAs strFile, wdFormatRTF
  29.   End If
  30.   objDoc.Close False
  31.   objWord.Quit
  32.   If strFile <> "" Then
  33.     CreateObject("Wscript.Shell").popup "完成!" & String(3,vbTab),6,WScript.ScriptName,vbSystemModal+vbInformation
  34.   Else
  35.     CreateObject("Wscript.Shell").popup "提示!没有找到剪贴板中的图文内容,请复制图文内容后执行本程序。" & String(3,vbTab),6,WScript.ScriptName,vbSystemModal+vbExclamation
  36.   End If
  37. End Sub
  38. ' 过滤文件名里面的无效字符
  39. Function GetSafeFileName(ByVal strFileName, ByVal nMaxLen)
  40.   Dim strSafeChar, strUnsafeChar, nIndex, strChr, strOut
  41.   strSafeChar = "!#$%&'()+,-." & Chr(32)
  42.   strUnsafeChar = "\/:*?""<>|" & vbCrLf
  43.   For nIndex = 0 To &H2F
  44.     If InStr(strSafeChar & strUnsafeChar, Chr(nIndex)) = 0 Then strUnsafeChar = strUnsafeChar & Chr(nIndex)
  45.   Next
  46.   For nIndex = 1 To Len(strUnsafeChar)
  47.     strFileName = Replace(strFileName, Mid(strUnsafeChar, nIndex, 1), Chr(32))
  48.   Next
  49.   GetSafeFileName = Left(Trim(strFileName), nMaxLen)
  50. End Function
  51. ' 获取不重复的文件名,如果有重名则在文件名后面附加“_1”、“_2”……
  52. Function GetUniqueFileName(strFullName)
  53.   Dim fso, strParentFolder, strBaseName, strExtensionName
  54.   Dim nIndex
  55.   Set fso = CreateObject("Scripting.FileSystemObject")
  56.   If Not fso.FileExists(strFullName) Then
  57.     GetUniqueFileName = strFullName
  58.     Exit Function
  59.   End If
  60.   strParentFolder = fso.GetParentFolderName(strFullName)
  61.   strBaseName = fso.GetBaseName(strFullName)
  62.   strExtensionName = fso.GetExtensionName(strFullName)
  63.   nIndex = 0
  64.   While fso.FileExists(strFullName)
  65.     nIndex = nIndex + 1
  66.     strFullName = fso.BuildPath(strParentFolder, strBaseName & "_" & nIndex & "." & strExtensionName)
  67.   Wend
  68.   GetUniqueFileName = strFullName
  69. End Function
复制代码
VBS 关于提取WORD第二行的文字为文件名的方式
http://zhidao.baidu.com/link?url ... bSy87eeZi_Kb3zGSCR_

作者: tonyabbs    时间: 2015-4-15 23:29

太感谢了!
作者: zhangop9    时间: 2021-1-1 00:24

记录剪贴板中的图片




欢迎光临 批处理之家 (http://bbs.bathome.net/) Powered by Discuz! 7.2