[[20150306221838]]　『ファイルをコピーしクリップボードに格納した状態』（田吾作）　ページの最後に飛ぶ

『ファイルをコピーしクリップボードに格納した状態にする』（田吾作）

 こんばんは、よろしくお願いいたします。

 指定のファイルをクリップボードに格納した状態にするコードを作成中です。
 ファイルのクリップボードへの格納はマクロで行いますが、ファイルの貼り付けはユーザーが手動で
 行います。

 現在、下記のようなコードは出来ました。
 ファイルを選択した状態で親フォルダを開き、SendKeysでCtrl+Cを送り込みクリップボードに格納、
 フォルダを閉じる、という作業です。

 これを直接ファイルをクリップボードに格納、という作業のみを行うよう改変したいのです。

 Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

 Sub test()
 　Dim itm As String
 　Dim fol As String

 　  'コピー対象ファイルのパス
   　itm = "D:\hoge\aaa.txt"
  　 'ファイルの親フォルダ取得
   　fol = Left(itm, InStrRev(itm, "\") - 1)
  　 'ファイルを選択した状態でフォルダを開く
   　Call Shell("explorer.exe /select," & itm, vbNormalFocus)
   　Sleep 1000
   　'Ctrl+Cのキーストロークを送り込む
   　Application.SendKeys ("^c")
   　'フォルダを閉じる
   　Call folcls(fol)
 End Sub

 'フォルダを閉じるFunction
 Function folcls(ByVal moji As String)
  Dim MyShell As Object, MyWindow As Object
  Dim cnt As Integer
  Dim i As Integer
  Dim myurl As String
    moji = "file:///" & Replace(Replace(moji, " ", "%20"), "\", "/")
    On Error Resume Next
    Set MyShell = CreateObject("Shell.Application")
    cnt = MyShell.Windows.Count
    For i = cnt - 1 To 0 Step -1
     If UCase(Right(MyShell.Windows((i)).FullName, 12)) <> "IEXPLORE.EXE" Then
        myurl = MyShell.Windows((i)).LocationUrl
        If myurl = moji Then
           MyShell.Windows((i)).Quit
        End If
     End If
    Next i
    Set MyShell = Nothing
    On Error GoTo 0
 End Function

 ※下記のHPも見てみましたが、VBAへの応用の方法が分かりませんでした。
http://dobon.net/vb/dotnet/file/copyfiletoclipboard.html

＜使用 Excel：Excel2007、使用 OS：WindowsVista ＞

 Shellからこんな方法で可能みたいですよ！！

 標準モジュールに

 Sub test()
    Dim fpath As Variant
    fpath = Application.GetOpenFilename("すべてのファイル,*.*")
    If TypeName(fpath) <> "Boolean" Then
       If copyfile(fpath) = 0 Then MsgBox "コピー成功"
    End If
 End Sub
 '==============================================================================
 Function copyfile(ByVal flpath As String) As Long
    Dim path As String
    Dim fnm As String
    Dim folobj As Object
    Dim fobj As Object
    Dim v As Object
    On Error Resume Next
    With CreateObject("scripting.filesystemobject")
       path = .GetParentFolderName(flpath)
       fnm = .GetFileName(flpath)
    End With
    With CreateObject("Shell.Application").Namespace(IIf(Mid(path, Len(path), 1) = "\", path, path & "\"))
       Set fobj = .ParseName(fnm)
       For Each v In fobj.Verbs
          If v.Name = "コピー(&C)" Then
             v.doit
             Exit For
          End If
       Next
       copyfile = Err.Number
    End With
    On Error GoTo 0
 End Function

（ichinose） 2015/03/07(土) 00:11

 ichinoseさん、ご回答ありがとうございます。

 Shellって奥深いですね。もっと勉強します。
 ありがとうございました。
（田吾作） 2015/03/07(土) 00:21

コメント返信：

[ 一覧(最新更新順) ]

[[20150306221838]] 『ファイルをコピーしクリップボードに格納した状態』（田吾作） ページの最後に飛ぶ

[[20150306221838]]　『ファイルをコピーしクリップボードに格納した状態』（田吾作）　ページの最後に飛ぶ