| |
▼ひら さん：
こんにちは。
>
>> With WebWindow
>> .SetFocus
>> Application.SendKeys "^a", True
>> Application.SendKeys "^c", True
>> DoEvents
>> ActiveCell.Select
>> .....以下貼り付け.....
>> End With
>> End If
>
> 上のコードでコピーはできるようになりましたが、動作が不安定で４〜５回程度
>に１回の割合でしか実行できません。（クリップボードには何も入っていないか、
>以前にクリップした内容が残ったままとなっています。）
>フォーカスがWebWindowにかからないのか、SendKeysの実行を待たずに次のステッ
>プに進んでしまうのかわからない状況です。Winth〜With Endの外側をDo loop
>で括って何回かループしたり、.SetFocusを２個以上つけたりしましたが、少しは
>効果らしいものはありましたが、決め手になるような結果になりませんでした。
> それとついでで申し訳ありませんがクリップボードにクリップされたかどうかの
>確認や、クリップボードをクリアする方法をご存知でしたらよろしくお願いします。（これは当質問箱（番号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でコピー＆ペーストです。
この時、上述のフレームのあるサイト等では、エラーメッセージを表示します。
（私は、エラーコードそのままメッセージにしましたが、コードを調べて
適当なエラーメッセージに変えてください）
|
|
ichinose
- 04/3/8(月) 18:06 -
