- 帖子
- 109
- 主題
- 2
- 精華
- 0
- 積分
- 114
- 點名
- 0
- 作業系統
- Win7 Win10
- 軟體版本
- Office 2019 WPS
- 閱讀權限
- 20
- 性別
- 男
- 來自
- 深圳
- 註冊時間
- 2013-2-2
- 最後登錄
- 2024-8-30
|
3#
發表於 2016-1-15 09:12
| 只看該作者
回復 1# lionliu
不好意思，2#的代碼有錯誤，所以在3#重新附上新的代碼。請新增一個模塊，將下面的代碼粘貼到新的模塊裡：- #If VBA7 Then
- Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" _
- (ByVal CodePage As Long, ByVal dwFlags As Long, _
- ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long, _
- ByVal lpMultiByteStr As LongPtr, ByVal cchMultiByte As Long, _
- Optional ByVal lpDefaultChar As Long = 0, Optional ByVal lpUsedDefaultChar As Long = 0) As Long
- #Else
- Private Declare Function WideCharToMultiByte Lib "kernel32" _
- (ByVal CodePage As Long, ByVal dwFlags As Long, _
- ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, _
- ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, _
- Optional ByVal lpDefaultChar As Long = 0, Optional ByVal lpUsedDefaultChar As Long = 0) As Long
- #End If
- Public Sub TestSave()
- Dim FileName As Variant
-
- FileName = Application.GetSaveAsFilename(FileFilter:="UTF-8 Text File,*.TXT", FilterIndex:=1)
- If VarType(FileName) = vbString Then
- If Len(Dir(FileName, vbHidden Or vbReadOnly Or vbSystem)) Then
- If MsgBox("文檔已存在，是否復寫此文檔？", vbYesNo) = vbNo Then Exit Sub
- SetAttr FileName, vbNormal
- Kill FileName
- If Len(Dir(FileName, vbHidden Or vbReadOnly Or vbSystem)) Then
- MsgBox "錯誤：" & vbCrLf & "無法保存為指定的文件名，文件被佔用或權限不允許。", vbCritical
- Exit Sub
- End If
- End If
- MsgBox "當前工作表""" & ActiveSheet.Name & """另存為UTF8 Text文檔" & IIf(SaveAsUTF8Text(FileName), "成功！", "失敗！"), vbInformation
- End If
- End Sub
- Public Function SaveAsUTF8Text(ByVal FileName As String) As Boolean
- Dim FileTemp As String
- Dim wkIndex As Long
- Dim lFile As Long
- Dim bytArr() As Byte
- Dim bytUTF8() As Byte
- Dim WB As Workbook
- Dim DisplayAlerts As Boolean, ScreenUpdating As Boolean
-
- On Error Resume Next
-
- DisplayAlerts = Application.DisplayAlerts: ScreenUpdating = Application.ScreenUpdating
- Application.DisplayAlerts = False: Application.ScreenUpdating = False
- wkIndex = ActiveSheet.Index
- FileTemp = GetTempFileName(FileName, "*.XLS")
- ThisWorkbook.SaveCopyAs FileTemp
- Set WB = Workbooks.Open(FileTemp)
- If Not (WB Is Nothing) Then
- WB.Sheets(wkIndex).SaveAs FileName:=FileName, FileFormat:=xlUnicodeText
- WB.Close SaveChanges:=False
- Kill FileTemp
- lFile = FileLen(FileName)
- If lFile > 0 Then
- If lFile > 2 Then
- ReDim bytArr(0 To lFile - 3)
- lFile = FreeFile
- Open FileName For Binary As lFile
- Get lFile, 3, bytArr()
- Close lFile
- Kill FileName
- lFile = WideCharToMultiByte(65001, 0, VarPtr(bytArr(0)), (UBound(bytArr) + 1) \ 2, 0, 0)
- ReDim bytUTF8(0 To 2 + IIf(lFile > 0, lFile, 0))
- If lFile > 0 Then WideCharToMultiByte 65001, 0, VarPtr(bytArr(0)), (UBound(bytArr) + 1) \ 2, VarPtr(bytUTF8(3)), lFile
- Else
- ReDim bytUTF8(0 To 2)
- End If
- bytUTF8(0) = &HEF: bytUTF8(1) = &HBB: bytUTF8(2) = &HBF
- lFile = FreeFile
- Open FileName For Binary As lFile
- Put lFile, , bytUTF8()
- Close lFile
- SaveAsUTF8Text = True
- End If
- End If
- Application.DisplayAlerts = DisplayAlerts: Application.ScreenUpdating = ScreenUpdating
- End Function
- Private Function GetTempFileName(ByVal FileName As String, Optional ByVal FileType As String) As String
- Dim I As Long
-
- If Len(FileType) Then
- I = InStrRev(FileType, ".")
- If I > 0 Then
- If I = Len(FileType) Then
- FileType = ".XLS"
- Else
- FileType = Mid$(FileType, I)
- End If
- Else
- FileType = "." & FileType
- End If
- Else
- FileType = ".XLS"
- End If
- I = InStrRev(FileName, ".")
- If I > 0 Then FileName = Left$(FileName, I - 1)
- I = 1
- Do While Len(Dir(FileName & I & FileType, vbReadOnly Or vbHidden Or vbSystem Or vbDirectory))
- I = I + 1
- Loop
- GetTempFileName = FileName & I & FileType
- End Function
|
|
