您的位置:首页 > 编程语言 > VB

vb-复制ie临时文件夹下所有mp3文件到指定目录,并且将utf8编码转换过来

2011-04-27 18:35 806 查看
Option Explicit
'引用Microsoft Scripting RunTime
Dim m_objFSO As New FileSystemObject   '定义文件系统对象
Private Declare Function SHGetSpecialFolderLocation Lib "Shell32" (ByVal hwndOwner As Long, ByVal nFolder As Integer, ppidl As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "Shell32" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal szPath As String) As Long
Const MAX_LEN = 200 '字符串最大长度
Const PAGETMP = &H20& '网页临时文件
Private Sub Command1_Click()
Dim sTmp As String * MAX_LEN '存放结果的固定长度的字符串
Dim nLength As Long '字符串的实际长度
Dim pidl As Long '某特殊目录在特殊目录列表中的位置
Dim TStr As String

'获得网页临时文件夹
SHGetSpecialFolderLocation 0, PAGETMP, pidl
SHGetPathFromIDList pidl, sTmp
TStr = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
SearchMP3 TStr
End Sub
Private Sub SearchMP3(strPath As String)
Dim objFolder   As Scripting.Folder   '文件夹对象
Dim objFile   As Scripting.File   '文件对象
Dim objSubdirs   As Scripting.Folders   '文件夹集合对象
Dim objLoopFolder   As Scripting.Folder   '文件夹对象

Set objFolder = m_objFSO.GetFolder(strPath)

For Each objFile In objFolder.Files
If LCase$(Right$(objFile.ShortPath, 4)) = ".mp3" Then
FileCopy objFile.Path, "c:\TestMP3\" & UTF8Decode(objFile.Name)
End If
Next objFile

Set objSubdirs = objFolder.SubFolders

For Each objLoopFolder In objSubdirs
SearchMP3 objLoopFolder.Path
Next objLoopFolder

Set objSubdirs = Nothing
Set objFolder = Nothing
End Sub
Public Function UTF8Decode(ByVal code As String) As String
If code = "" Then
UTF8Decode = ""
Exit Function
End If

Dim tmp As String
Dim decodeStr As String
Dim codelen As Long
Dim result As String
Dim leftStr As String

leftStr = Left(code, 1)

While (code <> "")
codelen = Len(code)
leftStr = Left(code, 1)
If leftStr = "%" Then
If (Mid(code, 2, 1) = "C" Or Mid(code, 2, 1) = "B") Then
decodeStr = Replace(Mid(code, 1, 6), "%", "")
tmp = c10ton(Val("&H" & Hex(Val("&H" & decodeStr) And &H1F3F)))
tmp = String(16 - Len(tmp), "0") & tmp
UTF8Decode = UTF8Decode & UTF8Decode & ChrW(Val("&H" & c2to16(Mid(tmp, 3, 4)) & c2to16(Mid(tmp, 7, 2) & Mid(tmp, 11, 2)) & Right(decodeStr, 1)))
code = Right(code, codelen - 6)
ElseIf (Mid(code, 2, 1) = "E") Then
decodeStr = Replace(Mid(code, 1, 9), "%", "")
tmp = c10ton((Val("&H" & Mid(Hex(Val("&H" & decodeStr) And &HF3F3F), 2, 3))))
tmp = String(10 - Len(tmp), "0") & tmp
UTF8Decode = UTF8Decode & ChrW(Val("&H" & (Mid(decodeStr, 2, 1) & c2to16(Mid(tmp, 1, 4)) & c2to16(Mid(tmp, 5, 2) & Right(tmp, 2)) & Right(decodeStr, 1))))
code = Right(code, codelen - 9)
End If
Else
UTF8Decode = UTF8Decode & leftStr
code = Right(code, codelen - 1)
End If
Wend
End Function
'10进制转n进制(默认2)
Public Function c10ton(ByVal x As Integer, Optional ByVal n As Integer = 2) As String
Dim i As Integer
i = x \ n
If i > 0 Then
If x Mod n > 10 Then
c10ton = c10ton(i, n) + Chr(x Mod n + 55)
Else
c10ton = c10ton(i, n) + CStr(x Mod n)
End If
Else
If x > 10 Then
c10ton = Chr(x + 55)
Else
c10ton = CStr(x)
End If
End If
End Function
'二进制代码转换为十六进制代码
Public Function c2to16(ByVal x As String) As String
Dim i As Long
i = 1
For i = 1 To Len(x) Step 4
c2to16 = c2to16 & Hex(c2to10(Mid(x, i, 4)))
Next
End Function
'二进制代码转换为十进制代码
Public Function c2to10(ByVal x As String) As String
c2to10 = 0
If x = "0" Then Exit Function
Dim i As Long
i = 0
For i = 0 To Len(x) - 1
If Mid(x, Len(x) - i, 1) = "1" Then c2to10 = c2to10 + 2 ^ (i)
Next
End Function
内容来自用户分享和网络整理,不保证内容的准确性,如有侵权内容,可联系管理员处理 点击这里给我发消息
标签: 
相关文章推荐