サンプル投稿用掲示板 VB2005 〜 用トップページ VB6.0 用 トップページ
- 日時： 2012/02/29 09:31
- 名前： VBレスキュー(花ちゃん)
- ***********************************************************************************
* カテゴリー：[文字列処理][インターネット][] *
* キーワード：リンク,URL,正規表現,検索,取り出し,文字列,検索置換え,選択 *
***********************************************************************************
'==================================================================================
'投 稿 日：2012.02.17 / 2012/02/29 一部修正
'投 稿 者：VBレスキュー(花ちゃん)
'タイトル：正規表現を使って文字列中からURLを抜き出す(587)
'動作確認：Windows Vista / Windows 7 / VB6.0(SP6) IE 9.0 で確認
'Microsoft VBScript Regular Expressions 5.5 を参照設定して下さい
'==================================================================
某掲示板に回答した分を少し汎用性を持たせてみたものです。
標準的なURLには対応しておりますが、間違った URL や途中で改行しているような URL は、
うまく取得できない場合があります。
メッセージボックスが表示している間に選択範囲等を修正する事によってある程度はカバー
しております。
使用コントロールや配置は下図を参考にお好みで。
Option Explicit
Private Sub Command1_Click()
Dim myString As String
myString = RichTextBox1.Text
Dim Reg As New RegExp
Dim MCs As MatchCollection
Dim Mat As Match
Dim Ret As Integer
Reg.Global = True
Reg.Pattern = "(https?|ftp)(:\/\/[a-zA-Z0-9;\/?:\@&=\+$,\-_\.!~*'\(\)%#]+)"
'検索して結果を取得
Set MCs = Reg.Execute(myString)
' Debug.Print MCs.Count '見つかった個数
Text2.Text = ""
With RichTextBox1
.HideSelection = False
For Each Mat In MCs
.SelStart = Mat.FirstIndex '見つかった位置
.SelLength = Len(Mat.Value) '見つかった文字列
If Right$(Mat.Value, 1) = ")" Then
.SelLength = Len(Mat.Value) - 1 '最後の)を取り除く
End If
Ret = CreateObject("WScript.Shell").Popup("そのまま取得しますか？" & _
"修正して取得しますか？", , "", vbYesNo)
If Ret = vbYes Then
Reg.Pattern = "[\n\r\f]+"
Text2.Text = Text2.Text & Reg.Replace(.SelText, "") & vbCrLf
.SelColor = vbBlue
.SelUnderline = True
.SelBold = True
End If
Next
.SelStart = 0
End With
End Sub
Private Sub RichTextBox1_MouseMove(Button As Integer, _
Shift As Integer, x As Single, y As Single)
RichTextBox1.SetFocus
End Sub
実行結果図(画像をクリックすると元のサイズで見る事ができます。)
 |
