Option Explicit

Dim strHtml As String '受信したHTMLの生データ


Private Sub Form_Load()                     'フォームロード
    Command1.Caption = "Go"
    CheckBox1.Caption = "タグ除去"
    Me.Caption = "HTMLデータ受信　タグ除去機能付き"
    Text1.Text = "http://www.yahoo.co.jp/"    'YAHOO
End Sub

Private Sub Form_Unload(Cancel As Integer)  'フォームアンロード
    End
End Sub

Private Sub Form_Resize()                   ' フォームリサイズ
'
    On Error Resume Next
    
    Text1.Width = Me.ScaleWidth - Text1.Left
    Text2.Width = Me.ScaleWidth - Text2.Left
    Text2.Height = Me.ScaleHeight - Text2.Top

    On Error GoTo 0
    
End Sub


Private Sub Command1_Click()   '「Go」開始

    Dim lngSize As Long     '受信サイズ
    Dim bytArray() As Byte  'データを受け取るバッファ(Byte型配列)
    Dim bytResult() As Byte '変換後のデータ格納域
    
    Dim tmp As String


    Command1.Enabled = False    '「Go」ボタンを無効

    strHtml = ""
    Text2 = ""                  'テキストボックスをクリア
    
    'tText1 で指定したURLのデータを取得
    lngSize = GetHtml(Text1.Text, bytArray(), "")
    If lngSize > 0 Then '成功
        tmp = StrConv(bytArray, vbUnicode)          'Unicode変換
        
        '----------------------------------------------------------------------
        ' 文字コード変換処理
        ' 　EUC,UTF-8などからShift-Jisへの変換を行うには、
        ' 　Nkf32.dllをダウンロード （　Nkf32.dllの入手先　）
        ' 　　http://www.vector.co.jp/soft/win95/util/se295331.html
        '-----------------------------------------
        ReDim bytResult(LenB(StrConv(tmp, vbFromUnicode)) * 4) '変換後の最大必要域確保

        Call SetNkfOption("s")                      'Nkf:Shift-Jis指定
        Call NkfConvert(bytResult(0), bytArray(0))  'Nkf:変換
        Call ResizeBytes(bytResult())               'Null位置まで配列をリサイズ
        tmp = StrConv(bytResult, vbUnicode)         'Unicodeに変換
        
        '改行変換
        tmp = Replace(tmp, vbCrLf, Chr(&H1))     'CrLf退避 &H1は通常文字コードとしては使われていない
        tmp = Replace(tmp, vbLf, vbCrLf)         'Lf→CrLf
        tmp = Replace(tmp, vbCr, vbCrLf)         'Cr→CrLf   ついでに
        tmp = Replace(tmp, Chr(&H1), vbCrLf)     '退避しておいたCrLfを復帰
        strHtml = tmp
        
        Call CheckBox1_Click    ' タグ除去処理後、テキストボックスに表示
    End If


    Command1.Enabled = True     '「Go」ボタンを有効

End Sub


Private Sub CheckBox1_Click()   'タグ除去ボタン
    If CheckBox1.Value = 0 Then
        Text2.Text = strHtml                'HTML生データ
    Else
        Text2.Text = CutTag(strHtml)        'タグ除去データ
    End If
    Text2.ToolTipText = Len(Text2) & "文字" '文字数をヒントテキストに表示
End Sub



'-------------------------
' 内部関数
'-------------------------


Private Function CutTag(strSrc As String) As String
'
' HTMLのタグを除去し、コード化された文字を復活する
'
    Dim re As RegExp                    '正規表現用のオブジェクト
                                        '　参照設定：Microsoft VBScript Regular Expressions
    Dim colMatches  As MatchCollection  '　マッチコレクション
    Dim tmp As String                   '作業用
    
    '-- 改行削除 ---------------
    
    tmp = Replace(strSrc, vbCrLf, "")   'CRLF
    tmp = Replace(tmp, vbLf, "")        'LF
    tmp = Replace(tmp, vbCr, "")        'CR
    
    '-- タグ除去 ---------------
    
    Set re = New RegExp     '正規表現オブジェクト作成
    re.Global = True        '文字列全体でパターンマッチング
    re.IgnoreCase = True    '大文字と小文字を区別しない
    
    re.Pattern = "< *script.*?</script *?>" 'Script削除
    tmp = re.Replace(tmp, "")

    re.Pattern = "<!--.*?-->"               'コメント削除
    tmp = re.Replace(tmp, "")

    re.Pattern = "< *style.+?</style *>"    'スタイルタグ削除
    tmp = re.Replace(tmp, "")
    
    re.Pattern = "< *br *>"         '改行タグを改行に置換
    tmp = re.Replace(tmp, vbCrLf)
    
    re.Pattern = "<.+?>"            'その他のタグを削除
    tmp = re.Replace(tmp, "")
    
    
    '-- エスケープ文字 ----------
    
    tmp = Replace(tmp, "&quot;", """")   ' "
    tmp = Replace(tmp, "&amp;", "&")     ' &
    tmp = Replace(tmp, "&gt;", ">")      ' >
    tmp = Replace(tmp, "&lt;", "<")      ' <
    tmp = Replace(tmp, "&nbsp;", " ")    ' 半角空白
        
    CutTag = tmp
    
    Set re = Nothing    '開放
    
End Function

Public Function ResizeBytes(ByRef bytArray() As Byte) As Long
'
' Null位置まで配列をリサイズ
'
    Dim p As Long       'Null位置

    p = InStr(bytArray, Chr(0), vbBinaryCompare)    'Null文字を検索（バイナリモード）
    If p > 0 Then ReDim Preserve bytArray(p - 1)    '配列再定義

    '配列要素最大値を返却
    ResizeBytes = UBound(bytArray) + 1

End Function


Private Sub Text1_GotFocus()  'Urlを全選択
    Text1.SelStart = 0
    Text1.SelLength = Len(Text1.Text)
End Sub