用VB的朋友们，能不能帮我写个小程序，对你们来说应该很快的！就是：把一个目录下的html文件批量改名，所改名字是该html文件的title，多谢各位了，应该不难吧！分不是问题！随时加分！

Question

你要该成什么名字呀?批量改?都改成一样的?还是仅仅提供一个小工具供改title用?

Answer 1

把一个目录下所有的html文件批量改名，这是很容易做到的，但是要改成该html文件的title（标题），就比较难了，关键在于不能取到一个html文件的title。
不好意思！能改成其它名字吗？
另，你是把这个作为一个工具呢，还是作为模块在VB或网页中引用？

Answer 2

格式:    <title>标题</title>
用VB写个程序,用文本格式打开HTML文件，然后寻找<title>起头</title>结尾的字符串,它之间的内容就是标题拉,然后就改名吧!

Answer 3

回猫儿：
改成的名字是该文件的标题title回Anti猫：
我是准备把它作为一个小工具使用，因为对我来说可能用的比较多吧回zxb365：
过程我是知道的，但是具体如何实现就不清楚了希望有时间、有热心的VB大虾帮帮我！！！！！！！！我只要最后的程序就可以了
至于代码乱不乱、美观不美观，都无所谓再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！

Answer 4

要用VB7就简单了，把HTML当成XML处理
声明一个XMLDocument，Load文件

Answer 5

你会用WORD吧！用WORD就可以很容易做到了。

Answer 6

另外是不是改完以后title和文件名相同?今天来不及了,明天给你吧

Answer 7

自己修改文件吧，代码添加到ChangeName()中
Public SourcePgm As String
Public MyArr As Variant
Public MyDir As Variant
Public Num As String
Public Txt1 As String
Public Txt2 As String
Public Dir As String
Public flags As Boolean
Public Sub ChangeName(Source As String, Direct As String)
    '添加代码
End SubPrivate Sub Command1_Click()
If MsgBox("这将是不可修复的，请确认!", vbOKCancel) Then
   MyDir = Split(MyArr(i), "\", -1, vbTextCompare)
   Dir = MyDir(0)
   For i1 = 1 To UBound(MyDir) - 1
       Dir = Dir & "\" & MyDir(i1)
   Next i1
   
   For i = 0 To Num - 1
      Open MyArr(i) For Input Access Read As #1
          MyDir = Split(MyArr(i), "\", -1, vbTextCompare)
          flags = False
          Do While Not EOF(1)   ' 循环至文件尾。
            
            Input #1, mystring ' 将数据读入变量。
            If Len(mystring) >= 7 Then
               a = InStr(1, mystring, Txt1, vbTextCompare)
               If a >= 0 Then
                  b = InStr(a, mystring, Txt2, vbTextCompare)
                  If b >= 0 Then
                     c = Mid(mystring, a + 7, b - a - 7)
                     Form1.Caption = c
                     Direct = c & ".htm"
                   
                     flags = True
                     Exit Do
                  End If
                End If
            End If
            Label2.Caption = CInt(Label2.Caption) + 1
          Loop
            Close #1
            
            
          If flags = True Then
             ChangeName MyArr(i), Direct
          End If
   Next i
   
Else
End If
End SubPrivate Sub Form_Load()
Txt1 = "<title>"
Txt2 = "</title>"
With CommonDialog1 '开文件问话框
    .Filter = "html Files (*.html;*.htm)|*.html;*.htm"
    .FilterIndex = 3
    .flags = &H200
    .ShowOpen
    SourcePgm = .FileName
End WithDim a As Variant
MyArr = Split(SourcePgm, " ", -1, 1)
Num = UBound(MyArr) + 1
Label1.Caption = "共选择了" & Num & "个文件"
Form1.Caption = SourcePgm
End Sub

Answer 8

CLS
INPUT FILE1$ :rem 文件名
B$ = "<TITLE>"
d$ = "</TITLE>"
OPEN FILE1$ FOR INPUT AS #1
WHILE NOT EOF(1)
LI = LI + 1
LINE INPUT #1, a$
bak$ = a$
VA1 = INSTR(a$, B$) 
IF VA1 THEN : c$ = MID$(bak$, VA1 + LEN(B$)): GOTO 20
VA1 = 0
WEND
END
20
bak$ = c$
c$ = UCASE$(c$)
va2 = INSTR(c$, d$)
over$ = LEFT$(bak$, va2 - 1)
over1$ = LEFT$(over$, 8)
PRINT over1$,"ok"
CLOSE #1
SHELL "ren " + FILE1$ + " " + over1$ + ".html" ：rem  改名
这是我用QB4.5编的程序，已经通过，希望你取其精华，改成自己的程序！

Answer 9

to :itmouse
我取出了title，你接着批量改文件名吧，我该吃饭去了，今天发工资，高兴

Answer 10

给你两个函数，别忘了引用Scripting Runtime库Function BetweenText(strFullText As String _
                            , strBeginText As String _
                            , strEndText As String _
                            , Optional blnInclude = False) As String
    Dim lngStartPos As Long, lngEndPos As Long
    Dim lngLength As Long
    Dim lngI As Long
    
    lngLength = Len(strFullText)
    
    If lngLength = 0 Then Exit Function
    
    If strBeginText = "" Then
        lngStartPos = 1
    Else
        lngStartPos = InStr(1, strFullText, strBeginText)
        If lngStartPos = 0 Then
            Exit Function
        Else
            lngStartPos = lngStartPos + Len(strBeginText)
        End If
    End If
    
    If strEndText = "" Then
        lngEndPos = lngLength + 1
    Else
        lngEndPos = InStr(lngStartPos, strFullText, strEndText)
        If lngEndPos = 0 Then
            Exit Function
        End If
    End If
    
    BetweenText = Mid(strFullText, lngStartPos, lngEndPos - lngStartPos)
    
    If blnInclude = True Then
        BetweenText = strBeginText & BetweenText & strEndText
    End If
End Function
Function fileText(ByVal strFileName As String) As String
    Dim intHandle As Integer
    
    On Error GoTo ERROR_HANDLE
    
    intHandle = FreeFile
    
    Open strFileName For Binary Access Read As #intHandle
    
    fileText = Space$(LOF(intHandle))
    
    Get #intHandle, , fileText
    
    Close #intHandle    Exit Function
    
ERROR_HANDLE:
    fileText = ""
End FunctionPrivate Sub Command2_Click()
    Dim FSO As New FileSystemObject
    Dim FLD As Folder
    Dim F As File
    Dim filePath As String
    Dim fileData As String
    Dim NewName As String
    filePath = InputBox("Where is your root directory of HTML?", "Input Directory", filePath)
    
    If Dir(filePath, vbDirectory) = "" Then
        MsgBox "File path [" & filePath & "] do not exist!"
        Exit Sub
    End If
    Set FLD = FSO.GetFolder(filePath)
    
    For Each F In FLD.Files
        fileData = fileText(F.Name)
        NewName = BetweenText(fileData, "<TITLE>", "</TITLE>") & ".htm"
'        NewName = BetweenText(fileData, "<title>", "</title>") & ".htm"
        F.Copy "C:\temp\" & NewName
    Next F
End Sub

Answer 11

不好意思不好意思最近忙，没来得及来看大家对不起了
为表示歉意，再加20分！！！！！！！！！！！！！！！！！！！！！！
为表示歉意，再加20分！！！！！！！！！！！！！！！！！！！！！！
为表示歉意，再加20分！！！！！！！！！！！！！！！！！！！！！！
为表示歉意，再加20分！！！！！！！！！！！！！！！！！！！！！！
为表示歉意，再加20分！！！！！！！！！！！！！！！！！！！！！！
为表示歉意，再加20分！！！！！！！！！！！！！！！！！！！！！！我的信箱是 [email protected]
我的信箱是 [email protected]
我的信箱是 [email protected]
我的信箱是 [email protected]
我的信箱是 [email protected]
我的信箱是 [email protected]
我的信箱是 [email protected]
为表示歉意，再加20分！！！！！！！！！！！！！！！！！！！！！！

Answer 12

没想到这么多朋友帮助我！
多些多谢！等allen和猫儿给我发完程序（有源码更好），我即给大家散分！！！！！！！！！！！！！！并且多谢沧浪客、zxb365等等热心朋友，多谢了！散分不会忘了大家地！！！^_^再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！再加10分！
如再参与还加分！保证散分！已经80分了！加了4次，20+20+10+20+10！如果愿意把源代码公布出来，我愿意为大家作贡献，我个人多给他加10分。哈哈哈

Answer 13

啊呀猫儿，真不好意思，可能是我没说清楚我想要的是这样的程序：就是我只需要选择一个目录，程序自动将里面所有的htm文件（比如1.htm，2.htm，asd.htm，其他.htm 等等所有htm文件）批量改名，所改名称是该文件的title，比如1.htm的<title>是“我爱北京天安门”，改名之后的该文件名称就变成了“我爱北京天安门.htm”你发给我的程序我收到了可是不是我想要的那种真不好意思你能不能再作一个这样的程序？麻烦你了！！！！！！！！！！！！！！！！！！！！！！

Answer 14

你的意思是让所有文件的名字都是它们的TITLE?而不是改TITLE本身是吗?

Answer 15

对！不是改title而是改文件名，所有文件的名字都是它们的TITLE傻瓜式的，轻轻一点，就完成最好再加上过滤的功能比如这个目录下的所有htm文件的title中都含有“天安门”三个字，而这三个我不想加在文件名称中，这就需要过滤掉！ 过滤词汇可定制猫儿，最好这样！多谢多谢！！！！！！！！！！！！

Answer 16

你上QQ说可以吗?我QQ号是34708151

Answer 17

allen写好了，给我发一个，我试试

Answer 18

猫儿，我上不去QQ啊，我们这里封了端口
你用msn吗？或者新浪的那个QQ？相同的字符是我自己输入然后过滤掉你说的没错

Answer 19

msn或者新浪的我都没有,我只想问你,你批量改的文件里,如果标题有重名的怎么办?

Answer 20

原理就是打开每个文件，分析源文件，找到 TITLE ，然后改掉就行了。
打开文件可以使用 FSO
分析源码时可以使用几个和字符串相关的函数。

Answer 21

猫儿忽略了一个问题就是title中可能含有 斜杠 （\） 等特殊字符我用的时候
老报错
VB怎么过滤这些特殊字符

Answer 22

        
                  猫儿，老报错，都是下面这一句惹的祸
        Open infor2 & "\" & File2.List(i) For Input As #1

Answer 23

在LOOP后面加
infor4 = Replace(infor4, "\", "")
再试试