|
▼ひら さん:
こんにちは。
>
>> With WebWindow
>> .SetFocus
>> Application.SendKeys "^a", True
>> Application.SendKeys "^c", True
>> DoEvents
>> ActiveCell.Select
>> .....以下貼り付け.....
>> End With
>> End If
>
> 上のコードでコピーはできるようになりましたが、動作が不安定で4〜5回程度
>に1回の割合でしか実行できません。(クリップボードには何も入っていないか、
>以前にクリップした内容が残ったままとなっています。)
>フォーカスがWebWindowにかからないのか、SendKeysの実行を待たずに次のステッ
>プに進んでしまうのかわからない状況です。Winth〜With Endの外側をDo loop
>で括って何回かループしたり、.SetFocusを2個以上つけたりしましたが、少しは
>効果らしいものはありましたが、決め手になるような結果になりませんでした。
> それとついでで申し訳ありませんがクリップボードにクリップされたかどうかの
>確認や、クリップボードをクリアする方法をご存知でしたらよろしくお願いします。(これは当質問箱(番号11315)で質問しています)
これは、ひらさんのご質問を考えているときに経験しました。
例えば、
http://www.microsoft.com/japan/msdn/library/default.asp
のようにフレームのあるサイトではIEを使用しても同じなんですが、
サイトが表示された直後、「すべて選択」ができません。
これは、webbrowserのSetfocusでも駄目でした。
この場合、私が試行したかぎりでは、一度WebBrowserをクリックしないとコピーできませんでした。
よって、このようなサイトを表示したときにコピー&ペーストのコードを実行しても
以前のクリップボードの内容がペーストされてしまう現象が起こります。
私は、こんなコードにしてみましたが、いかがでしようか?
例えば、
ユーザーフォーム(Userform1)には、
テキストボックス(Textbox1)ひとつ(URL入力用)
ウェブブラウザー(WebBrowser1)ひとつ
コマンドボタンふたつ
(Commandbutton1---Textbox1に入力されたURLのNavigate用)
(Commandbutoon2----コピー&ペースト用)
の4つのコントロールを配置します。
標準モジュールで
'========================================================
Sub main()
UserForm1.Show vbModeless
End Sub
Userform1のモジュールで
'========================================================
Private dsp_flg As Boolean
'========================================================
Private Sub CommandButton1_Click()
On Error Resume Next
With WebBrowser1
If TextBox1.Text <> "" Then
dsp_flg = False
.Navigate TextBox1.Text
Do While dsp_flg = False
DoEvents
Loop
If Err.Number <> 0 Then
MsgBox Error$(Err.Number)
End If
End If
End With
End Sub
'========================================================
Private Sub CommandButton2_Click()
On Error Resume Next
If dsp_flg = True Then
Call del_clip
With WebBrowser1
.SetFocus
Application.SendKeys "^a", True
Application.SendKeys "^c", True
DoEvents
ActiveCell.Select
ActiveSheet.PasteSpecial Format:="HTML", Link:=False, _
DisplayAsIcon:=False
If Err.Number <> 0 Then
MsgBox Error$(Err.Number)
End If
End With
End If
End Sub
'========================================================
Private Sub WebBrowser1_BeforeNavigate2(ByVal pDisp As Object, URL As Variant, Flags As Variant, TargetFrameName As Variant, PostData As Variant, Headers As Variant, Cancel As Boolean)
dsp_flg = False
End Sub
'========================================================
Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
dsp_flg = True
End Sub
'========================================================
Sub del_clip()
On Error Resume Next
Application.CommandBars("Clipboard").Controls(4).Execute
On Error GoTo 0
End Sub
フォームが表示されたらテキストボックスにURLを指定してCommandbutton1をクリックして下さい。
その後に、Commandbutton2でコピー&ペーストです。
この時、上述のフレームのあるサイト等では、エラーメッセージを表示します。
(私は、エラーコードそのままメッセージにしましたが、コードを調べて
適当なエラーメッセージに変えてください)
|
|