セル範囲のデータをテキストとしてクリップボードに取り込みたいのです。
http://okwave.jp/qa/q5650002.html#16327676 の回答ANo2を見て
Sub test01()
Dim myData As DataObject
Dim myCb As Variant
Dim x
x = "TESTデータです。"
Set myData = New DataObject
myData.SetText x
myCb = myData.GetText
myData.PutInClipboard
End Sub
は出来ました。
そこで、セル範囲A1:B3をクリップボードに貼ろうといろいろやってみました。
一応、下記でできましたが、実際にはもっと広い範囲を取り込みたいので、もっと簡単な方法はないでしょうか?
Sub Clip()
Dim myStr As String
Dim myData As DataObject
Dim myCb As Variant
Set myData = New DataObject
With Sheets(1)
myStr = .Range("A1").Value & ":" & .Range("B1").Value & _
vbNewLine & .Range("A2").Value & ":" & .Range("B2").Value & _
vbNewLine & .Range("A3").Value & ":" & .Range("B3").Value
End With
myData.SetText myStr ', 1
myCb = myData.GetText
If MsgBox("データ" & vbNewLine & myCb & " をクリップボードに送りますか? ", vbYesNo + vbQuestion, "確認") = vbNo Then
Exit Sub
End If
myData.PutInClipboard
End Sub
横いりすみません。
必要範囲をCoryしたら、
DataObjectのGetFromClipboardメソッドを使ってクリップボードデータを取得します。
そこからさらにDataObjectのGetTextメソッドを使うとテキスト文字列だけ取り出せます。
その後、DataObjectをClearして
あらためて取り出したテキスト文字列をSetTextすれば良いです。
各メソッドについては、DataObjectのヘルプを見て下さい。
ただし、OutlookならCtrl+VまでVBAでやれば良い気がしますが。
http://outlooklab.wordpress.com/
この辺りを参考にしてみると良いかと。
Sub try()
Const olFolderInbox As Long = 6
Const olMailItem As Long = 0
Dim obj As Object
Dim ins As Object
Dim m As Object
Dim tmp As String
If TypeName(Selection) <> "Range" Then Exit Sub
Selection.Copy
With New DataObject
.GetFromClipboard
tmp = .GetText
.Clear
End With
Application.CutCopyMode = False
On Error Resume Next
Set obj = GetObject(, "Outlook.Application")
On Error GoTo 0
If obj Is Nothing Then
Set obj = CreateObject("Outlook.Application")
obj.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Display
End If
For Each ins In obj.Inspectors
With ins.CurrentItem
If .MessageClass = "IPM.Note" Then
If Not .Sent Then
Exit For
End If
End If
End With
Next
If ins Is Nothing Then
Set m = obj.CreateItem(olMailItem)
Else
Set m = ins.CurrentItem
Set ins = Nothing
End If
m.body = tmp
m.Display
Set m = Nothing
Set obj = Nothing
End Sub
#3です。何故か盛り上がっていますね。
一つ思いついてしまいました。UserFormに、テキストボックスと、コマンドボタンを一個置きます。
UserForm1をモードレスで表示させ、セルを選択してコマンドボタンを押すと、テキストボックスや、単独セル内に貼り付けられる形で文字列がクリップボードにコピーされますので、質問者様のなさりたい事が出来ているのではと思います。
UserForm1のコードは下記だけです。ご参考まで。
Private Sub CommandButton1_Click()
Selection.Copy
With Me.TextBox1
.Paste
.SetFocus
.SelStart = 0
.SelLength = Len(Me.TextBox1)
.Copy
End With
End Sub
Private Sub UserForm_Initialize()
Me.TextBox1.MultiLine = True
End Sub
こんな感じじゃ?
Sub てすと()
Dim rC As Long, rR As Long
Dim strT As String
Dim myStr As String
Dim myData As DataObject
'Dim myCb As Variant
Set myData = New DataObject
Range("A1:D10").Select 'か適当に選択しておいて
For rR = 1 To Selection.Rows.Count
For rC = 1 To Selection.Columns.Count
strT = strT & vbTab & Selection(1).Offset(rR - 1, rC - 1)
Next rC
strT = Mid(strT, 2)
myStr = myStr & vbCrLf & strT
strT = ""
Next rR
myStr = Mid(myStr, 3)
myData.SetText myStr ', 1
'myCb = myData.GetText
If MsgBox("データ" & vbNewLine & myStr & " をクリップボードに送りますか? ", vbYesNo + vbQuestion, "確認") = vbNo Then
Exit Sub
End If
myData.PutInClipboard
End Sub
以下の様な感じでどうでしょうか
Sub Clip()
Dim myStr As String
Dim myData As DataObject
Dim myCb As Variant
Set myData = New DataObject
Dim C As Range
With Sheets(1)
For Each C In .Range("A1:B100")
If myStr = "" Then
myStr = C.Value
Else
If C.Column = 1 Then 'C.Column = 1はA列の意味
myStr = myStr & vbNewLine & C.Value
Else
myStr = myStr & ":" & C.Value
End If
End If
Next C
End With
myData.SetText myStr ', 1
myCb = myData.GetText
If MsgBox("データ" & vbNewLine & myCb & " をクリップボードに送りますか? ", vbYesNo + vbQuestion, "確認") = vbNo Then
Exit Sub
End If
myData.PutInClipboard
End Sub
お礼
ほんとうにお世話になりました。 ありがとうございます。