Private Const MAX_PATH = 260
Private Type FileTime ' 8 Bytes
LTime As Long
HTime As Long
End Type
Private Type Win32_Find_Data
dwFileAttributes As Long
ftCreationTime As FileTime
ftLastAccessTime As FileTime
ftLastWriteTime As FileTime
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cNameFile As String * MAX_PATH
cAlternate As String * 14
End Type
Private Declare Function MoveFileEx Lib "kernel32" Alias "MoveFileExA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal dwFlags As Long) As Long
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpNameFile As String, lpFindFileData As Win32_Find_Data) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As Win32_Find_Data) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Sub Form_Load()
Text1.Text = "F:\abc...\"
Command1.Caption = "解密": Command2.Caption = "加密"
Me.Caption = "目录或文件的加解密"
End Sub
Private Sub Command1_Click()
Call SetPathName(False) '解密
End Sub
Private Sub Command2_Click()
Call SetPathName(True) '加密
End Sub
Private Sub SetPathName(SetMi As Boolean)
Dim nName As String, NewName As String, nSort As String, nCap As String, dl As Long
nName = Trim(Text1.Text)
If Right(nName, 3) = "..\" Then nName = Left(nName, Len(nName) - 3)
If Right(nName, 1) = "\" Then nName = Left(nName, Len(nName) - 1)
If SetMi Then
NewName = nName & "..\"
Else
NewName = nName
nName = nName & "..\"
End If
If SetMi Then nCap = "加密" Else nCap = "解密"
nSort = GetShortName(nName) '转变其中的 ..\
If nSort = "" Then
MsgBox "文件没有找到：" & vbCrLf & nName, vbCritical, nCap
Exit Sub
End If
If MoveFileEx(nSort, NewName, 0) = 0 Then Exit Sub '文件更名：非零表示成功，支持只读文件
MsgBox nCap & "成功：" & vbCrLf & nName, vbInformation, nCap
End Sub
Public Function GetShortName(F As String, Optional ShortAll As Boolean) As String
'转变为短文件名，如果目录或文件不存在就返回空。可用于判断某目录或文件是否存在
'不能直接用 API 函数 GetShortPathName， 因它不支持 ..\
'ShortAll=T 表示全部转变为短名称，否则只转变其中的点点杠“..\”
Dim FondID As Long, ID1 As Long, S As Long, nPath As String
Dim nF As String, InfoF As Win32_Find_Data, qF As String, hF As String
Dim nName As String, nName1 As String
nF = F
Do
S = InStr(nF, "..\")
If S = 0 Then Exit Do
qF = Left(nF, S + 2): hF = Mid(nF, S + 3) '分为前后两部分
CutPathName qF, nPath, nName
nName = LCase(nName)
qF = nPath & "\" & "*."
FondID = FindFirstFile(qF, InfoF) '-1表示失败。查找所有文件（夹）
ID1 = FondID
Do
If FondID = Find_Err Or ID1 = 0 Then GoTo Exit1 '没有找到符合条件的条目
nName1 = LCase(CutChr0(InfoF.cNameFile)) '文件（夹）名称
If nName1 & ".\" = nName Then
nName1 = CutChr0(InfoF.cAlternate) '用短文件名代替
If hF = "" Then nF = nPath & "\" & nName1 Else nF = nPath & "\" & nName1 & "\" & hF
Exit Do
End If
ID1 = FindNextFile(FondID, InfoF) '查找下一个，0表示失败
Loop
FindClose FondID
Loop
Exit1:
FindClose FondID
S = MAX_PATH: nName = String(S, vbNullChar)
ID1 = GetShortPathName(nF, nName, S) '返回实际字节数，0表示失败
If ID1 = 0 Then Exit Function
If ShortAll Then
If ID1 > S Then
S = ID1: nName = String(S, vbNullChar)
ID1 = GetShortPathName(nF, nName, S) '返回实际字节数
End If
GetShortName = CutChr0(nName)
Else
GetShortName = nF
End If
End Function
Public Sub CutPathName(ByVal F As String, nPath As String, nName As String)
Dim I As Long, LenS As Long
LenS = Len(F)
For I = LenS - 1 To 2 Step -1
If Mid(F, I, 1) = "\" Then
nPath = Left(F, I - 1): nName = Mid(F, I + 1)
GoTo Exit1
End If
Next
nPath = F: nName = ""
Exit1:
If Right(nPath, 2) = ".." Then
nPath = nPath & "\"
Else
If Right(nPath, 1) = "\" Then nPath = Left(nPath, Len(nPath) - 1)
End If
If Right(nName, 1) = "\" And Right(nName, 3) <> "..\" Then nName = Left(nName, Len(nName) - 1)
End Sub
Private Function CutChr0(xx As String) As String
Dim S As Long
S = InStr(xx, vbNullChar)
If S > 0 Then CutChr0 = Left(xx, S - 1) Else CutChr0 = xx
End Function
------解决思路----------------------
Private Const MAX_PATH = 260
Private FileTime As New Win32_Find_Data ' 8 Bytes
Private LTime As Long
Private HTime As Long
Private Structure Win32_Find_Data
Dim dwFileAttributes As Long
Dim ftCreationTime As Date
Dim ftLastAccessTime As Date
Dim ftLastWriteTime As Date
Dim nFileSizeHigh As Long
Dim nFileSizeLow As Long
Dim dwReserved0 As Long
Dim dwReserved1 As Long
Dim cNameFile As String
Dim cAlternate As String
End Structure
Private Declare Function MoveFileEx Lib "kernel32" Alias "MoveFileExA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal dwFlags As Long) As Long
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpNameFile As String, ByVal lpFindFileData As Win32_Find_Data) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, ByVal lpFindFileData As Win32_Find_Data) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Sub Form_Load()
FileTime.cNameFile = FileTime.cNameFile * MAX_PATH
FileTime.cNameFile = FileTime.cNameFile * 14
' Me.textbox1.Text = "F:\abc...\"
' Command1.Caption = "解密" : Command2.Caption = "加密"
Me.Text = "目录或文件的加解密"
End Sub
''' <summary>
''' '解密False,加密True
''' </summary>
''' <param name="SetMi"></param>
''' <remarks></remarks>
Private Sub SetPathName(ByVal SetMi As Boolean)
Dim nName As String, NewName As String, nSort As String, nCap As String
nName = "" '文本框
If Strings.Right(nName, 3) = "..\" Then nName = Strings.Left(nName, Len(nName) - 3)
If Strings.Right(nName, 1) = "\" Then nName = Strings.Left(nName, Len(nName) - 1)
If SetMi Then
NewName = nName & "..\"
Else
NewName = nName
nName = nName & "..\"
End If
If SetMi Then nCap = "加密" Else nCap = "解密"
nSort = GetShortName(nName) '转变其中的 ..\
If nSort = "" Then
MsgBox("文件没有找到：" & vbCrLf & nName, vbCritical, nCap)
Exit Sub
End If
If MoveFileEx(nSort, NewName, 0) = 0 Then Exit Sub '文件更名：非零表示成功，支持只读文件
MsgBox(nCap & "成功：" & vbCrLf & nName, vbInformation, nCap)
End Sub
Public Function GetShortName(ByVal F As String, Optional ByVal ShortAll As Boolean = True) As String
'转变为短文件名，如果目录或文件不存在就返回空。可用于判断某目录或文件是否存在
'不能直接用 API 函数 GetShortPathName， 因它不支持 ..\
'ShortAll=T 表示全部转变为短名称，否则只转变其中的点点杠“..\”
Dim FondID As Long, ID1 As Long, S As Long, nPath As String
Dim nF As String, InfoF As Win32_Find_Data, qF As String, hF As String
Dim nName As String = ""
Dim nName1 As String = ""
Dim Find_Err As String = ""
Dim Info As String = ""
nF = F
Do
S = InStr(nF, "..\")
If S = 0 Then Exit Do
qF = Strings.Left(nF, S + 2) : hF = Mid(nF, S + 3) '分为前后两部分
CutPathName(qF, nPath, nName)
nName = LCase(nName)
qF = nPath & "\" & "*."
FondID = FindFirstFile(qF, InfoF) '-1表示失败。查找所有文件（夹）
ID1 = FondID
Do
If FondID = Find_Err Or ID1 = 0 Then GoTo Exit1 '没有找到符合条件的条目
nName1 = LCase(CutChr0(InfoF.cNameFile)) '文件（夹）名称
If nName1 & ".\" = nName Then
nName1 = CutChr0(InfoF.cAlternate) '用短文件名代替
If hF = "" Then nF = nPath & "\" & nName1 Else nF = nPath & "\" & nName1 & "\" & hF
Exit Do
End If
ID1 = FindNextFile(FondID, InfoF) '查找下一个，0表示失败
Loop
FindClose(FondID)
Loop
Exit1:
FindClose(FondID)
S = MAX_PATH : nName = String.IsNullOrEmpty(S)
ID1 = GetShortPathName(nF, nName, S) '返回实际字节数，0表示失败
If ID1 = 0 Then
Return ""
End If
If ShortAll Then
If ID1 > S Then
S = ID1 : nName = String.IsNullOrEmpty(S)
ID1 = GetShortPathName(nF, nName, S) '返回实际字节数
End If
GetShortName = CutChr0(nName)
Else
GetShortName = nF
End If
End Function
Public Sub CutPathName(ByVal F As String, ByVal nPath As String, ByVal nName As String)
Dim I As Long, LenS As Long
LenS = Len(F)
For I = LenS - 1 To 2 Step -1
If Mid(F, I, 1) = "\" Then
nPath = Strings.Left(F, I - 1) : nName = Mid(F, I + 1)
GoTo Exit1
End If
Next
nPath = F : nName = ""
Exit1:
If Strings.Right(nPath, 2) = ".." Then
nPath = nPath & "\"
Else
If Strings.Right(nPath, 1) = "\" Then nPath = Strings.Left(nPath, Len(nPath) - 1)
End If
If Strings.Right(nName, 1) = "\" And Strings.Right(nName, 3) <> "..\" Then nName = Strings.Left(nName, Len(nName) - 1)
End Sub
Private Function CutChr0(ByVal xx As String) As String
Dim S As Long
S = InStr(xx, vbNullChar)
If S > 0 Then CutChr0 = Strings.Left(xx, S - 1) Else CutChr0 = xx
End Function
需要LZ一句句明白每行代码的名字。
------解决思路----------------------
Public Class Form1
Private Const MAX_PATH As Integer = 260
' The CharSet must match the CharSet of the corresponding PInvoke signature
<System.Runtime.InteropServices.StructLayout(System.Runtime.InteropServices.LayoutKind.Sequential, CharSet:=System.Runtime.InteropServices.CharSet.Auto)> _
Structure WIN32_FIND_DATA
Public dwFileAttributes As UInteger
Public ftCreationTime As System.Runtime.InteropServices.ComTypes.FILETIME
Public ftLastAccessTime As System.Runtime.InteropServices.ComTypes.FILETIME
Public ftLastWriteTime As System.Runtime.InteropServices.ComTypes.FILETIME
Public nFileSizeHigh As UInteger
Public nFileSizeLow As UInteger
Public dwReserved0 As UInteger
Public dwReserved1 As UInteger
<System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.ByValTStr, SizeConst:=260)> _
Public cFileName As String
<System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.ByValTStr, SizeConst:=14)> _
Public cAlternateFileName As String
End Structure
Enum MoveFileFlags As UInteger
MOVEFILE_REPLACE_EXISTING = &H1
MOVEFILE_COPY_ALLOWED = &H2
MOVEFILE_DELAY_UNTIL_REBOOT = &H4
MOVEFILE_WRITE_THROUGH = &H8
MOVEFILE_CREATE_HARDLINK = &H10
MOVEFILE_FAIL_IF_NOT_TRACKABLE = &H20
End Enum
<System.Runtime.InteropServices.DllImport("kernel32.dll", CharSet:=System.Runtime.InteropServices.CharSet.Auto)> _
Private Shared Function MoveFileEx(ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal dwFlags As MoveFileFlags) As Integer
End Function
<System.Runtime.InteropServices.DllImport("kernel32.dll", CharSet:=System.Runtime.InteropServices.CharSet.Auto)> _
Private Shared Function GetShortPathName(ByVal longPath As String, <System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.LPTStr)> ByVal ShortPath As System.Text.StringBuilder, <System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.U4)> ByVal bufferSize As Integer) As Integer
End Function
<System.Runtime.InteropServices.DllImport("kernel32.dll", CharSet:=System.Runtime.InteropServices.CharSet.Auto)> _
Private Shared Function FindFirstFile(ByVal lpFileName As String, ByRef lpFindFileData As WIN32_FIND_DATA) As IntPtr
End Function
<System.Runtime.InteropServices.DllImport("kernel32.dll", CharSet:=System.Runtime.InteropServices.CharSet.Auto)> _
Private Shared Function FindNextFile(ByVal hFindFile As IntPtr, ByRef lpFindFileData As WIN32_FIND_DATA) As Boolean
End Function
<System.Runtime.InteropServices.DllImport("kernel32.dll")> _
Public Shared Function FindClose(ByVal hFindFile As IntPtr) As Boolean
End Function
Private Sub Form_Load(ByVal sender As Object, ByVal arg As EventArgs) Handles Me.Load
TextBox1.Text = "F:\abc...\"
Button1.Text = "解密" : Button2.Text = "加密"
Me.Text = "目录或文件的加解密"
End Sub
Private Sub Command1_Click(ByVal sender As Object, ByVal arg As EventArgs) Handles Button1.Click
Call SetPathName(False) '解密
End Sub
Private Sub Command2_Click(ByVal sender As Object, ByVal arg As EventArgs) Handles Button2.Click
Call SetPathName(True) '加密
End Sub
Private Sub SetPathName(SetMi As Boolean)
Dim nName As String, NewName As String, nSort As String, nCap As String, dl As Integer
nName = Microsoft.VisualBasic.Trim(TextBox1.Text)
If Microsoft.VisualBasic.Right(nName, 3) = "..\" Then nName = Microsoft.VisualBasic.Left(nName, Len(nName) - 3)
If Microsoft.VisualBasic.Right(nName, 1) = "\" Then nName = Microsoft.VisualBasic.Left(nName, Len(nName) - 1)
If SetMi Then
NewName = nName & "..\"
Else
NewName = nName
nName = nName & "..\"
End If
If SetMi Then nCap = "加密" Else nCap = "解密"
nSort = GetShortName(nName) '转变其中的 ..\
If nSort = "" Then
MsgBox("文件没有找到：" & vbCrLf & nName, vbCritical, nCap)
Exit Sub
End If
If MoveFileEx(nSort, NewName, 0) = 0 Then Exit Sub '文件更名：非零表示成功，支持只读文件
MsgBox(nCap & "成功：" & vbCrLf & nName, vbInformation, nCap)
End Sub
Public Function GetShortName(F As String, Optional ShortAll As Boolean = False) As String
'转变为短文件名，如果目录或文件不存在就返回空。可用于判断某目录或文件是否存在
'不能直接用 API 函数 GetShortPathName， 因它不支持 ..\
'ShortAll=T 表示全部转变为短名称，否则只转变其中的点点杠“..\”
Dim FondID As Integer, ID1 As Integer, S As Integer, nPath As String
Dim nF As String, InfoF As WIN32_FIND_DATA, qF As String, hF As String
Dim nName As String, nName1 As String
Dim nName2 As System.Text.StringBuilder
Const Find_Err As Integer = -1
nF = F
Do
S = InStr(nF, "..\")
If S = 0 Then Exit Do
qF = Microsoft.VisualBasic.Left(nF, S + 2) : hF = Mid(nF, S + 3) '分为前后两部分
CutPathName(qF, nPath, nName)
nName = Microsoft.VisualBasic.LCase(nName)
qF = nPath & "\" & "*."
FondID = FindFirstFile(qF, InfoF) '-1表示失败。查找所有文件（夹）
ID1 = FondID
Do
If FondID = Find_Err Or ID1 = 0 Then GoTo Exit1 '没有找到符合条件的条目
nName1 = Microsoft.VisualBasic.LCase(CutChr0(InfoF.cFileName)) '文件（夹）名称
If nName1 & ".\" = nName Then
nName1 = CutChr0(InfoF.cAlternateFileName) '用短文件名代替
If hF = "" Then nF = nPath & "\" & nName1 Else nF = nPath & "\" & nName1 & "\" & hF
Exit Do
End If
ID1 = FindNextFile(FondID, InfoF) '查找下一个，0表示失败
Loop
FindClose(FondID)
Loop
Exit1:
FindClose(FondID)
S = MAX_PATH : nName2 = New System.Text.StringBuilder(S)
ID1 = GetShortPathName(nF, nName2, S) '返回实际字节数，0表示失败
If ID1 = 0 Then Exit Function
If ShortAll Then
If ID1 > S Then
S = ID1 : nName2 = New System.Text.StringBuilder(S)
ID1 = GetShortPathName(nF, nName2, S) '返回实际字节数
End If
GetShortName = CutChr0(nName2.ToString())
Else
GetShortName = nF
End If
End Function
Public Sub CutPathName(ByVal F As String, ByRef nPath As String, ByRef nName As String)
Dim I As Integer, LenS As Integer
LenS = Microsoft.VisualBasic.Len(F)
For I = LenS - 1 To 2 Step -1
If Microsoft.VisualBasic.Mid(F, I, 1) = "\" Then
nPath = Microsoft.VisualBasic.Left(F, I - 1) : nName = Mid(F, I + 1)
GoTo Exit1
End If
Next
nPath = F : nName = ""
Exit1:
If Microsoft.VisualBasic.Right(nPath, 2) = ".." Then
nPath = nPath & "\"
Else
If Microsoft.VisualBasic.Right(nPath, 1) = "\" Then nPath = Microsoft.VisualBasic.Left(nPath, Len(nPath) - 1)
End If
If Microsoft.VisualBasic.Right(nName, 1) = "\" And Microsoft.VisualBasic.Right(nName, 3) <> "..\" Then nName = Microsoft.VisualBasic.Left(nName, Len(nName) - 1)
End Sub
Private Function CutChr0(ByVal xx As String) As String
Dim S As Integer
S = Microsoft.VisualBasic.InStr(xx, vbNullChar)
If S > 0 Then CutChr0 = Microsoft.VisualBasic.Left(xx, S - 1) Else CutChr0 = xx
End Function
End Class