win7下剪贴板保存为自定格式文本 - 无忧启动论坛

Option Explicit
Sub Main()
On Error Resume Next
Dim clipboardText
clipboardText = GetClipboardText()
If IsEmpty(clipboardText) Then
MsgBox "剪贴板中没有文本内容或无法访问剪贴板！", vbExclamation, "错误"
Exit Sub
End If
If clipboardText = "" Then
MsgBox "剪贴板中没有文本内容！", vbExclamation, "错误"
Exit Sub
End If
Dim convertedText
convertedText = ConvertTextFormat(clipboardText)
Dim filePath
filePath = ShowSaveDialog()
If filePath = "" Then
Exit Sub
End If
If SaveTextToFile(convertedText, filePath) Then
MsgBox "文件保存成功！" & vbCrLf & "路径：" & filePath, vbInformation, "成功"
Else
MsgBox "文件保存失败！", vbExclamation, "错误"
End If
End Sub
Function GetClipboardText()
On Error Resume Next
Dim objHTML, clipboardText
Set objHTML = CreateObject("htmlfile")
clipboardText = objHTML.ParentWindow.ClipboardData.GetData("text")
If Err.Number <> 0 Then
Err.Clear
Dim objShell
Set objShell = CreateObject("WScript.Shell")
Dim tempFile, objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
tempFile = objFSO.GetSpecialFolder(2) & "\clipboard_temp.txt"
objShell.Run "powershell -Command Get-Clipboard | Out-File -FilePath """ & tempFile & """ -Encoding UTF8", 0, True
WScript.Sleep 500 ' 等待文件写入
If objFSO.FileExists(tempFile) Then
Dim objStream
Set objStream = CreateObject("ADODB.Stream")
objStream.Charset = "UTF-8"
objStream.Open
objStream.LoadFromFile tempFile
clipboardText = objStream.ReadText
objStream.Close
objFSO.DeleteFile tempFile, True
End If
End If
GetClipboardText = clipboardText
Set objHTML = Nothing
End Function
Function ConvertTextFormat(text)
Dim converted
converted = Replace(text, vbCrLf, vbLf) ' 先将CRLF转为LF
converted = Replace(converted, vbCr, vbLf) ' 将CR转为LF
converted = Replace(converted, vbLf, vbCrLf) ' 最后将所有LF转为CRLF
If Len(converted) >= 3 Then
If AscB(MidB(converted, 1, 1)) = &HEF And _
AscB(MidB(converted, 2, 1)) = &HBB And _
AscB(MidB(converted, 3, 1)) = &HBF Then
converted = Mid(converted, 2) ' 跳过BOM
End If
End If
ConvertTextFormat = converted
End Function
Function ShowSaveDialog()
Dim objShell, objFolder, tempPath, fileName
Set objShell = CreateObject("WScript.Shell")
fileName = "clipboard_content_" & FormatDateTime(Now, 2) & "_" & Replace(FormatDateTime(Now, 4), ":", "") & ".txt"
Dim filePath
filePath = InputBox("请输入要保存的文件路径：" & vbCrLf & vbCrLf & _
"支持的文件格式：.txt, .log, .csv, .ini, .xml等", _
"保存剪贴板内容", _
objShell.ExpandEnvironmentStrings("%USERPROFILE%\Desktop") & fileName)
If filePath = "" Then
ShowSaveDialog = ""
Exit Function
End If
Dim objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
If InStr(objFSO.GetFileName(filePath), ".") = 0 Then
filePath = filePath & ".txt"
End If
ShowSaveDialog = filePath
Set objFSO = Nothing
Set objShell = Nothing
End Function
Function SaveTextToFile(text, filePath)
On Error Resume Next
Dim objStream, objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim folderPath
folderPath = objFSO.GetParentFolderName(filePath)
If Not objFSO.FolderExists(folderPath) Then
objFSO.CreateFolder folderPath
End If
Set objStream = CreateObject("ADODB.Stream")
objStream.Type = 2 ' 文本类型
objStream.Charset = "gb2312" ' 使用GB2312编码（ANSI中文环境）
objStream.Open
objStream.WriteText text
objStream.SaveToFile filePath, 2 ' 2 = 覆盖已存在文件
objStream.Close
If Err.Number = 0 Then
SaveTextToFile = True
Else
SaveTextToFile = False
End If
Set objStream = Nothing
Set objFSO = Nothing
End Function
Main

复制代码