tagCANDY CGI VBレスキュー(花ちゃん) - 正規表現を使って文字列中からURLを抜き出す(VB6.0) - Visual Basic 6.0 VB2005 VB2010
VB2005用トップページへVBレスキュー(花ちゃん)のトップページVB6.0用のトップページ
正規表現を使って文字列中からURLを抜き出す(VB6.0)
元に戻る スレッド一覧へ 記事閲覧
このページ内の検索ができます。(AND 検索や OR 検索のような複数のキーワードによる検索はできません。)

正規表現を使って文字列中からURLを抜き出す(VB6.0) [No.316の個別表示]
     サンプル投稿用掲示板  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

実行結果図(画像をクリックすると元のサイズで見る事ができます。)
メンテ

Page: 1 |

 投稿フォーム               スレッド一覧へ
題  名 スレッドをトップへソート
名  前
パスワード (記事メンテ時に使用)
投稿キー (投稿時 投稿キー を入力してください)
コメント

   クッキー保存   
スレッド一覧へ