Question

我必须创建一个代码来保存指定列表中路由器的配置脚本。

使用telnet和VBA我能够满足我的要求。但每次都可以看到telnet窗口，而且我必须依靠SendKeys将命令正确发送到该telnet窗口。
我已经嵌入了＆＃p; plink.exe＆＃39;作为＆＃34;对象7＆＃34;在Sheet1中。下面是将此对象复制并粘贴今天的日期在临时文件夹中的代码：
```
EmbeddedObject.Copy
Set oFolder = CreateObject("Shell.Application").Namespace(sFolder & Chr(0))
oFolder.Self.InvokeVerb "Paste"
```
这里的问题是在复制粘贴后，文件显示为已损坏。我尝试添加一个zip文件，但zip也会损坏。
所以我添加了一个代码来打开Excel中的对象并使用SendKeys和7z Extractor I再次提取到temp文件夹依赖于SendKeys。

请帮助我以更好的方式复制它，而不会导致文件损坏。

这是我的代码。

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
#Else
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
#End If

Private Type FUNC_OUT_RESULTS
    SUCCESS As Boolean
    SAVED_FILE_PATH_NAME As String
    ERROR As String
End Type


Sub test()
    Dim tRes As FUNC_OUT_RESULTS
    Dim oleObj As OLEObject

    tRes = SaveEmbeddedOleObjectToDisk _
    (EmbeddedObject:=ActiveSheet.OLEObjects("Object 7"), FilePathName:="C:\Users\user\AppData\Local\Temp\20170512\")

    With tRes
        If .SUCCESS Then
            MsgBox "OleObject successfully saved as : '" & .SAVED_FILE_PATH_NAME & " '", vbInformation
        Else
            MsgBox .ERROR, vbCritical
        End If
    End With
End Sub


Private Function SaveEmbeddedOleObjectToDisk( _
    ByVal EmbeddedObject As OLEObject, _
    ByVal FilePathName As String _
    ) _
    As FUNC_OUT_RESULTS


    Dim oFolder As Object
    Dim sFolder As String

    On Error GoTo errHandler
    If Len(Dir$(FilePathName)) <> 0 Then 'Err.Raise 58
        Dim FSO As Object
        Set FSO = CreateObject("scripting.filesystemobject")

        FSO.deletefile FilePathName & "\*.*", True    'Delete files
        FSO.deletefolder FilePathName                'Delete Todays Date folder
        MkDir FilePathName                          'Make Todays Date folder
    End If
'\---------------------------------------\
    sFolder = Left$(FilePathName, InStrRev(FilePathName, "\") - 10)
    If Len(Dir$(sFolder, vbDirectory)) = 0 Then
        MkDir sFolder
    End If
    If EmbeddedObject.OLEType = xlOLEEmbed Then
        EmbeddedObject.Verb Verb:=xlPrimary   '\---Here it opens within excel

        Set EmbeddedObject = Nothing
        Application.DisplayAlerts = True

        Dim oShell
        Set oShell = CreateObject("WScript.Shell")
        Application.Wait (Now + TimeValue("0:00:02"))
        oShell.AppActivate sFolder & "\plink*"
        oShell.SendKeys "{F5}"         '\----it extracts to temp-----------\
        oShell.SendKeys FilePathName
        oShell.SendKeys "{ENTER}"
        Application.Wait (Now + TimeValue("0:00:01"))
        oShell.AppActivate sFolder & "\plink*"
        oShell.SendKeys ("%{F4}")

'----Copy the object without opening-----

' EmbeddedObject.Copy
' Set oFolder = CreateObject("Shell.Application").Namespace(sFolder & Chr(0))
' oFolder.Self.InvokeVerb "Paste"
'\---------------------------------------\

        SaveEmbeddedOleObjectToDisk.SAVED_FILE_PATH_NAME = FilePathName
        SaveEmbeddedOleObjectToDisk.SUCCESS = True
    End If
    Call CleanClipBoard
    Exit Function
errHandler:
    SaveEmbeddedOleObjectToDisk.ERROR = Err.Description
    Call CleanClipBoard
End Function


Private Function GetPastedFile( _
    ByVal Folder As String _
    ) _
    As String

    Dim sCurFile As String
    Dim sNewestFile As String
    Dim dCurDate As Date
    Dim dNewestDate As Date

    Folder = Folder & "\"
    sCurFile = Dir$(Folder & "*.*", vbNormal)
    Do While Len(sCurFile) > 0
        dCurDate = FileDateTime(Folder & sCurFile)
        If dCurDate > dNewestDate Then
            dNewestDate = dCurDate
            sNewestFile = Folder & sCurFile
        End If
        sCurFile = Dir$()
    Loop
    GetPastedFile = sNewestFile
End Function


Private Sub CleanClipBoard()
    OpenClipboard 0
    EmptyClipboard
    CloseClipboard
End Sub

如何使用VBA复制嵌入对象并粘贴到临时文件夹中

0 个答案: