frmhtmtotxt.frm

批量HTML转换TXT,VB写了N久了的

VERSION 5.00
Begin VB.Form Frmhtmtotxt 
   Caption         =   "批量HTML转换成TXT."
   ClientHeight    =   5730
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   7575
   LinkTopic       =   "Form1"
   ScaleHeight     =   5730
   ScaleWidth      =   7575
   StartUpPosition =   3  '窗口缺省
   Begin VB.ComboBox parten 
      Height          =   300
      ItemData        =   "Frmhtmtotxt.frx":0000
      Left            =   5400
      List            =   "Frmhtmtotxt.frx":0013
      TabIndex        =   10
      Text            =   "*.htm"
      ToolTipText     =   "一定要输入正确的格式!用"";""分开"
      Top             =   120
      Width           =   1935
   End
   Begin VB.CommandButton Command1 
      Caption         =   "清空列表"
      Height          =   495
      Left            =   2760
      TabIndex        =   9
      Top             =   5160
      Width           =   2055
   End
   Begin VB.CommandButton Command2 
      Caption         =   "转 换"
      Height          =   495
      Left            =   5640
      TabIndex        =   5
      Top             =   5160
      Width           =   1695
   End
   Begin VB.CommandButton Command3 
      Caption         =   "关 闭"
      Height          =   495
      Left            =   240
      TabIndex        =   4
      Top             =   5160
      Width           =   1815
   End
   Begin VB.DirListBox Dir1 
      Height          =   1770
      Left            =   240
      TabIndex        =   3
      Top             =   600
      Width           =   3135
   End
   Begin VB.DriveListBox Drive1 
      Height          =   300
      Left            =   240
      TabIndex        =   2
      Top             =   120
      Width           =   3135
   End
   Begin VB.FileListBox File1 
      Height          =   1710
      Left            =   3600
      Pattern         =   "*.htm;*.html"
      TabIndex        =   1
      Top             =   600
      Width           =   3735
   End
   Begin VB.ListBox List1 
      Height          =   2220
      Left            =   240
      TabIndex        =   0
      Top             =   2880
      Width           =   7095
   End
   Begin VB.Label Lblstatus 
      Caption         =   "Lblstatus"
      Height          =   255
      Left            =   3000
      TabIndex        =   7
      Top             =   2520
      Width           =   4335
   End
   Begin VB.Label Label1 
      Caption         =   "选择HTML文件:(双击可以删除.)"
      Height          =   255
      Left            =   360
      TabIndex        =   8
      Top             =   2520
      Width           =   6975
   End
   Begin VB.Label Label2 
      Caption         =   "待转换的文件列表:"
      Height          =   255
      Left            =   3600
      TabIndex        =   6
      Top             =   120
      Width           =   1695
   End
End
Attribute VB_Name = "Frmhtmtotxt"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'**********************************************
'*声明url重复时不添加的代码
'**********************************************

Private Function Exists(objCmb As ComboBox, ByVal strTmp As String) As Boolean
    Exists = False
    Dim i As Long
    For i = 0 To objCmb.ListCount - 1
        If objCmb.List(i) = strTmp Then
            Exists = True
            Exit For
        End If
    Next
End Function


Function folderfmat(pname)
    folderfmat = Replace(pname & "\", "\\", "\")
End Function



Sub parten_KeyDown(KeyCode%, Shift%)
    If KeyCode = 13 Then '新增过滤条件并生效
         '验证url中是否有重复东东
         If Not Exists(parten, parten.Text) Then parten.AddItem parten.Text
    End If
End Sub

Private Sub parten_Click()
File1.Pattern = parten.Text

End Sub


Private Sub Command1_Click()
    List1.Clear
End Sub

Private Sub Command2_Click()
    Dim i%
    If List1.List(0) = "" Then
        MsgBox "没有选择需要转换的文件！", , "错误"
    Else
        For i = 0 To List1.ListCount - 1
            StripText CStr(List1.List(i))
        Next i
            Lblstatus.Visible = True
    End If
    Screen.MousePointer = vbDefault

End Sub

Private Sub Command3_Click()
    Unload Me
End Sub

Private Sub Dir1_Change()
    File1.Pattern = parten.Text
    File1.Path = Dir1.Path
End Sub

Private Sub Drive1_Change()
    On Error GoTo errorchu
    Dir1.Path = Drive1.Drive
    File1.Pattern = parten.Text
    Exit Sub
errorchu:
    MsgBox "设备不可用", vbExclamation, "错误"
End Sub

Private Sub File1_Click()
    Dim tmpfilename$, i%
    tmpfilename = folderfmat(Dir1.Path) & File1.Filename
    For i = 0 To List1.ListCount - 1
        If tmpfilename = List1.List(i) Then
            MsgBox "文件已被加入待转换列表！", , "错误"
            Exit Sub
        End If
    Next i
    List1.AddItem (tmpfilename)
End Sub

'Private Sub File1_dblClick()

'End Sub
Private Sub File1_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single)
    Dim tmpfilename$, i%, j%, panduan As Boolean
    If Button = 2 Then
        For j = 0 To File1.ListCount - 1
            tmpfilename = folderfmat(Dir1.Path) & File1.List(j)
            panduan = False
            For i = 0 To List1.ListCount - 1
                If tmpfilename = List1.List(i) Then
                    MsgBox "文件已被加入待转换列表！", , "错误"
                    panduan = True
                    i = List1.ListCount
                End If
            Next i
            If panduan = False Then List1.AddItem (tmpfilename)
        Next j
    End If
End Sub

Private Sub Form_Load()
     Me.Caption = "HTML转换TXT"
     Lblstatus.Visible = False
     File1.Pattern = "*.htm"
End Sub



'Private Sub List1_Click()
    'List1.RemoveItem (List1.ListIndex)
'End Sub


Private Sub List1_dblClick()
    List1.RemoveItem (List1.ListIndex)
End Sub

Sub StripText(Filename$)
    Dim f%, xiansi As Boolean, tebiehansu As Boolean
    Dim b() As Byte, c() As Byte
    Dim sourcefilelength&, i&, j&
    On Error GoTo Err_Handler
    Screen.MousePointer = 11
    
    f% = FreeFile
    sourcefilelength = FileLen(Filename$)
    ReDim c(1 To sourcefilelength)
    ReDim b(1 To sourcefilelength)
    Open Filename$ For Binary As #f%
    Get #f%, , b()
    Close #f%
    tebiehansu = False
    j = 1
    For i = 1 To sourcefilelength
        Select Case b(i)
            Case 60
                If i + 8 < sourcefilelength Then
                    If UCase(Chr(b(i + 1)) & Chr(b(i + 2)) & Chr(b(i + 3)) & Chr(b(i + 4)) & Chr(b(i + 5)) & Chr(b(i + 6)) & Chr(b(i + 7)) & Chr(b(i + 8))) = "/SCRIPT>" Then
                        xiansi = True
                        tebiehansu = False
                    End If
                End If
                If i + 6 < sourcefilelength Then
                    If UCase(Chr(b(i + 1)) & Chr(b(i + 2)) & Chr(b(i + 3)) & Chr(b(i + 4)) & Chr(b(i + 5)) & Chr(b(i + 6))) = "/HEAD>" Then
                        xiansi = True
                        j = 1
                        i = i + 6
                    End If
                    If UCase(Chr(b(i + 1)) & Chr(b(i + 2)) & Chr(b(i + 3)) & Chr(b(i + 4)) & Chr(b(i + 5)) & Chr(b(i + 6))) = "/STYLE" Then
                        xiansi = True
                        tebiehansu = False
                    End If
                    If UCase(Chr(b(i + 1)) & Chr(b(i + 2)) & Chr(b(i + 3)) & Chr(b(i + 4)) & Chr(b(i + 5)) & Chr(b(i + 6))) = "SCRIPT" Then
                        xiansi = False
                        tebiehansu = True
                    End If
                End If
                If i + 3 < sourcefilelength Then
                    If UCase(Chr(b(i + 1)) & Chr(b(i + 2)) & Chr(b(i + 3))) = "/P>" Or UCase(Chr(b(i + 1)) & Chr(b(i + 2)) & Chr(b(i + 3))) = "BR>" Then
                        c(j) = 13
                        c(j + 1) = 10
                        j = j + 2
                        i = i + 3
                        xiansi = True
                    Else
                        xiansi = False
                    End If
                Else
                    xiansi = False
                End If
                If i + 5 < sourcefilelength Then
                    If UCase(Chr(b(i + 1)) & Chr(b(i + 2)) & Chr(b(i + 3)) & Chr(b(i + 4)) & Chr(b(i + 5))) = "STYLE" Then
                        xiansi = False
                        tebiehansu = True
                    End If
                End If
            Case 62
                xiansi = True
            Case 13
                If b(i + 1) = 10 Then i = i + 1
            Case Else
                If xiansi = True And tebiehansu = False Then
                    c(j) = b(i)
                    j = j + 1
                End If
        End Select
    Next i
    ReDim Preserve c(1 To j - 1)
    f% = FreeFile
    Open Left$(Filename$, InStr(Filename$, ".")) & "TXT" For Binary As #f%
    Put #f%, , c()
    Close #f%
    Lblstatus.Caption = "成功转换了" & Filename$
    Exit Sub
    
Exit_Sub:
   Close #f%
   Screen.MousePointer = 0
   Exit Sub
Err_Handler:
   Lblstatus.Caption = "Error: " & Error$(Err)
End Sub