vba 复制电脑文件到系统剪切板

hempy2100

芐雨 发表于 2019-12-25 14:32
两边加单引号啊
FileList = "'" & ActiveDocument.Path & "\" & "2020BC_Hall " & Application.Acti ...

不知为何，您给我的代码可以，但又回到了之前的问题，可以在电脑的桌面或电脑本地的其它文件夹里粘贴，就是不能在微信或QQ里粘贴，绝望

我把全部代码都发上来了，由于用的visio 不是excel，所以没有上附件。


Sub 存为PDF()

Dim lshg As String
Dim DiagramServices As Integer
    Dim pscode As String

Dim oShellApp, oShellAppWindows, oWin, oWind, Ste, Str, Sty

    Ste = ActiveDocument.Path
    Str = Left(Ste, Len(Ste) - 1)
    Sty = Right(Str, Len(Str) - InStrRev(Str, "\"))

    Set oShellApp = CreateObject("Shell.Application")
    Set oShellAppWindows = oShellApp.Windows
    For Each oWin In oShellAppWindows
    For Each oWind In oShellAppWindows
        If InStr(1, oWind.locationname, Sty, vbTextCompare) > 0 Then oWind.Quit
    Next
        If InStr(1, oWin.locationname, Sty, vbTextCompare) > 0 Then oWin.Quit
    Next
    Set oWin = Nothing
    Set oShellApp = Nothing
    Set oShellAppWindows = Nothing
   
DiagramServices = ActiveDocument.DiagramServicesEnabled
ActiveDocument.DiagramServicesEnabled = visServiceVersion140

    Dim UndoScopeID1 As Long
    UndoScopeID1 = Application.BeginUndoScope("填充颜色")
    On Error Resume Next
    Application.ActiveWindow.Page.Shapes.ItemFromID(ActiveWindow.Selection(1).ID).CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaU = "THEMEGUARD(RGB(255,255,0))"
    On Error Resume Next
    Application.ActiveWindow.Page.Shapes.ItemFromID(ActiveWindow.Selection(1).ID).CellsSRC(visSectionObject, visRowFill, visFillBkgnd).FormulaU = "THEMEGUARD(SHADE(FillForegnd,LUMDIFF(THEME(""FillColor""),THEME(""FillColor2""))))"
    On Error Resume Next
    Application.ActiveWindow.Page.Shapes.ItemFromID(ActiveWindow.Selection(1).ID).CellsSRC(visSectionObject, visRowFill, visFillPattern).FormulaU = "1"

    lshg = InputBox("PDF│请输入企业简称：")
   
If Application.ActivePage.Name = "Hall 8.2" Then
    Application.ActiveDocument.ExportAsFixedFormat visFixedFormatPDF, ActiveDocument.Path & "\" & "2020秋季焙烤展_" & Application.ActivePage.Name & " " & lshg & ".pdf", visDocExIntentPrint, visPrintCurrentPage, 3, 3, False, True, True, True, False
Else
    Application.ActiveDocument.ExportAsFixedFormat visFixedFormatPDF, ActiveDocument.Path & "\" & "2020BC_Hall " & Application.ActivePage.Name & " " & lshg & ".pdf", visDocExIntentPrint, visPrintCurrentPage, 3, 3, False, True, True, True, False
End If

    On Error Resume Next
    Application.ActiveWindow.Page.Shapes.ItemFromID(ActiveWindow.Selection(1).ID).CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaU = "THEMEGUARD(MSOTINT(RGB(255,255,255),-25))"
    On Error Resume Next
    Application.ActiveWindow.Page.Shapes.ItemFromID(ActiveWindow.Selection(1).ID).CellsSRC(visSectionObject, visRowFill, visFillBkgnd).FormulaU = "THEMEGUARD(SHADE(FillForegnd,LUMDIFF(THEME(""FillColor""),THEME(""FillColor2""))))"
    On Error Resume Next
    Application.ActiveWindow.Page.Shapes.ItemFromID(ActiveWindow.Selection(1).ID).CellsSRC(visSectionObject, visRowFill, visFillPattern).FormulaU = "1"
   
    Application.EndUndoScope UndoScopeID1, True

    pscode = "powershell  $filelist =" & "'" & ActiveDocument.Path & "\" & "2020BC_Hall " & Application.ActivePage.Name & " " & lshg & ".pdf'" & vbCrLf & "$col = New-Object Collections.Specialized.StringCollection " & vbCrLf & "foreach($file in $filelist){$col.add($file)}" & vbCrLf & "Add-Type -AssemblyName System.Windows.Forms" & vbCrLf & "[Windows.Forms.Clipboard]::setfiledroplist($col)"
    Shell pscode, vbHide


ActiveDocument.DiagramServicesEnabled = DiagramServices
Shell "Explorer.exe " & ActiveDocument.Path, vbNormalFocus


End Sub

hempy2100

芐雨 发表于 2019-12-25 14:32
两边加单引号啊
FileList = "'" & ActiveDocument.Path & "\" & "2020BC_Hall " & Application.Acti ...

另外，我在用API里的cutorcopyfiles时，代码为CutOrCopyFiles ActiveDocument.Path & "\" & Application.ActiveDocument.Name时（代码里没有&".docx"），是可以在本地粘贴，也可以在微信里粘贴。

请问跟这个问题有关系吗？

Sub 更新()
   
Selection.WholeStory
Selection.Fields.Locked = False
Selection.Fields.Update
Selection.Fields.Locked = True
If MsgBox("关闭程序并复制文件？", vbOKCancel, "提示") = vbOK Then
ActiveDocument.Save
CutOrCopyFiles ActiveDocument.Path & "\" & Application.ActiveDocument.Name
Shell "Explorer.exe " & ActiveDocument.Path, vbNormalFocus
ActiveDocument.Close
Word.Application.Quit
End If
End Sub

hempy2100

芐雨 发表于 2019-12-25 14:32
两边加单引号啊
FileList = "'" & ActiveDocument.Path & "\" & "2020BC_Hall " & Application.Acti ...

大神，再追问一下，地址里是否可以用通配符呢

FOB_FN_L

hempy2100 发表于 2019-12-23 13:05
我在国外网站查到以下代码，可是还是不懂

Option Explicit

在国外的哪个网站看到的，分享一下那网站

hempy2100

FOB_FN_L 发表于 2020-1-18 17:43
在国外的哪个网站看到的，分享一下那网站

为自己的问题在网上随便搜索的看到的，搜索英文网页，已经忘记了

GS6300

芐雨 发表于 2019-12-23 18:29
api确实比较长，来个曲线救国吧，用powershell

win7及以上系统自带powersehll,你可以理解为cmd批处理的 ...

感谢！测试可用