Board logo

標題: sheet轉utf8 TXT 問題 [打印本頁]
作者: lionliu    時間: 2016-1-14 11:46     標題: sheet轉utf8 TXT 問題

各位大哥好：
小弟的TEST.XLS想轉出 UTF8 TEST.TXT但是一直無法克服，
我想用第一個巨集完成不知是否可行。[attach]23111[/attach]
作者: Joforn    時間: 2016-1-15 09:01

本帖最後由 Joforn 於 2016-1-15 09:02 編輯

無法下載附件，只能按自己的想法寫了，請參考下樓的代碼。
作者: Joforn    時間: 2016-1-15 09:12

回復 1# lionliu
不好意思，2#的代碼有錯誤，所以在3#重新附上新的代碼。請新增一個模塊，將下面的代碼粘貼到新的模塊裡：
  1. #If VBA7 Then
  2.   Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" _
  3.         (ByVal CodePage As Long, ByVal dwFlags As Long, _
  4.         ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long, _
  5.         ByVal lpMultiByteStr As LongPtr, ByVal cchMultiByte As Long, _
  6.         Optional ByVal lpDefaultChar As Long = 0, Optional ByVal lpUsedDefaultChar As Long = 0) As Long
  7. #Else
  8.   Private Declare Function WideCharToMultiByte Lib "kernel32" _
  9.         (ByVal CodePage As Long, ByVal dwFlags As Long, _
  10.         ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, _
  11.         ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, _
  12.         Optional ByVal lpDefaultChar As Long = 0, Optional ByVal lpUsedDefaultChar As Long = 0) As Long
  13. #End If

  15. Public Sub TestSave()
  16.   Dim FileName  As Variant
  17.   
  18.   FileName = Application.GetSaveAsFilename(FileFilter:="UTF-8 Text File,*.TXT", FilterIndex:=1)
  19.   If VarType(FileName) = vbString Then
  20.     If Len(Dir(FileName, vbHidden Or vbReadOnly Or vbSystem)) Then
  21.       If MsgBox("文檔已存在，是否復寫此文檔？", vbYesNo) = vbNo Then Exit Sub
  22.       SetAttr FileName, vbNormal
  23.       Kill FileName
  24.       If Len(Dir(FileName, vbHidden Or vbReadOnly Or vbSystem)) Then
  25.         MsgBox "錯誤：" & vbCrLf & "無法保存為指定的文件名，文件被佔用或權限不允許。", vbCritical
  26.         Exit Sub
  27.       End If
  28.     End If
  29.     MsgBox "當前工作表""" & ActiveSheet.Name & """另存為UTF8 Text文檔" & IIf(SaveAsUTF8Text(FileName), "成功！", "失敗！"), vbInformation
  30.   End If
  31. End Sub

  33. Public Function SaveAsUTF8Text(ByVal FileName As String) As Boolean
  34.   Dim FileTemp  As String
  35.   Dim wkIndex   As Long
  36.   Dim lFile     As Long
  37.   Dim bytArr()  As Byte
  38.   Dim bytUTF8() As Byte
  39.   Dim WB        As Workbook
  40.   Dim DisplayAlerts As Boolean, ScreenUpdating As Boolean
  41.   
  42.   On Error Resume Next
  43.    
  44.   DisplayAlerts = Application.DisplayAlerts: ScreenUpdating = Application.ScreenUpdating
  45.   Application.DisplayAlerts = False: Application.ScreenUpdating = False
  46.   wkIndex = ActiveSheet.Index
  47.   FileTemp = GetTempFileName(FileName, "*.XLS")
  48.   ThisWorkbook.SaveCopyAs FileTemp
  49.   Set WB = Workbooks.Open(FileTemp)
  50.   If Not (WB Is Nothing) Then
  51.     WB.Sheets(wkIndex).SaveAs FileName:=FileName, FileFormat:=xlUnicodeText
  52.     WB.Close SaveChanges:=False
  53.     Kill FileTemp
  54.     lFile = FileLen(FileName)
  55.     If lFile > 0 Then
  56.       If lFile > 2 Then
  57.         ReDim bytArr(0 To lFile - 3)
  58.         lFile = FreeFile
  59.         Open FileName For Binary As lFile
  60.         Get lFile, 3, bytArr()
  61.         Close lFile
  62.         Kill FileName
  63.         lFile = WideCharToMultiByte(65001, 0, VarPtr(bytArr(0)), (UBound(bytArr) + 1) \ 2, 0, 0)
  64.         ReDim bytUTF8(0 To 2 + IIf(lFile > 0, lFile, 0))
  65.         If lFile > 0 Then WideCharToMultiByte 65001, 0, VarPtr(bytArr(0)), (UBound(bytArr) + 1) \ 2, VarPtr(bytUTF8(3)), lFile
  66.       Else
  67.         ReDim bytUTF8(0 To 2)
  68.       End If
  69.       bytUTF8(0) = &HEF: bytUTF8(1) = &HBB: bytUTF8(2) = &HBF
  70.       lFile = FreeFile
  71.       Open FileName For Binary As lFile
  72.       Put lFile, , bytUTF8()
  73.       Close lFile
  74.       SaveAsUTF8Text = True
  75.     End If
  76.   End If
  77.   Application.DisplayAlerts = DisplayAlerts: Application.ScreenUpdating = ScreenUpdating
  78. End Function

  80. Private Function GetTempFileName(ByVal FileName As String, Optional ByVal FileType As String) As String
  81.   Dim I As Long
  82.   
  83.   If Len(FileType) Then
  84.     I = InStrRev(FileType, ".")
  85.     If I > 0 Then
  86.       If I = Len(FileType) Then
  87.         FileType = ".XLS"
  88.       Else
  89.         FileType = Mid$(FileType, I)
  90.       End If
  91.     Else
  92.       FileType = "." & FileType
  93.     End If
  94.   Else
  95.     FileType = ".XLS"
  96.   End If
  97.   I = InStrRev(FileName, ".")
  98.   If I > 0 Then FileName = Left$(FileName, I - 1)
  99.   I = 1
  100.   Do While Len(Dir(FileName & I & FileType, vbReadOnly Or vbHidden Or vbSystem Or vbDirectory))
  101.     I = I + 1
  102.   Loop
  103.   GetTempFileName = FileName & I & FileType
  104. End Function
複製代碼
運行宏"TestSave"將會把當前的工作表保存為指定的文檔。
作者: stillfish00    時間: 2016-1-15 09:38

回復 1# lionliu
附檔的 test.txt ，依BOM(Byte Order Mark)來看
編碼是unicode (little endian) 而非 utf-8。
作者: lionliu    時間: 2016-1-15 14:14

本帖最後由 lionliu 於 2016-1-15 14:26 編輯

謝謝兩位大哥的協助
我已找到處理方式，謝謝。
在此我將它提供大家參考：
  1. Sub FileZM(sFile As String, sCode As String, dFile As String, dCode As String)
  2. Dim objStream As Object
  3.     Set objStream = CreateObject("Adodb.Stream")
  4.     With objStream
  5.         .Mode = 3         'adModeReadWrite = 3 ' 指示读/写权限。
  6.         .Type = 1         'adTypeBinary = 1
  7.         .Open
  8.         .LoadFromFile sFile   
  9.         .Position = 0
  10.         .Type = 2      
  11.         .Charset = sCode

  13. sCode = .ReadText   
  14.        .Position = 0     
  15.        .SetEOS
  16.        .Type = 2      
  17.        .Charset = dCode   
  18.        .WriteText sCode   
  19.        .SaveToFile dFile, 2
  20.        .Close
  21.       End With
  22. Set objStream = Nothing
  23. End Sub

  25. Sub SAVE_TXT()
  26.     Dim I%, x%, y%, arr, FileName$
  27.     FileName = "D:\TEST\1000724.txt"
  28.     Open FileName For Output As #1
  29.     Do While Sheets(1).Cells(I + 1, "A") <> ""
  30.         Print #1, Sheets(1).Cells(I + 1, "A")
  31.         I = I + 1
  32.     Loop
  33.     Close #1
  34.    我原來第一個巨集呼叫fileZM處裡既可。
  35.    Call FileZM(FileName, "big5", FileName, "utf-8")
  36.    
  37. End Sub
複製代碼
以上是我在大陸網站所找到的資料，我修改後就能使用了
以下是我看到的另一種做法一併提供：但是不符合我的需求。
他會將所有資料寫入同一行，請問是否有方法可以讓他一列一行。
但文字當中不要有隱藏的折行符號。

Sub Day15_4_()
'多國語言文字寫入UTF8格式的文字檔
      Sheets(1).Select
      Dim Rng As Object
      Dim strData

      For Each Rng In Range("A1:b9")
          If Rng.Column = 1 Then
              strData = strData & Rng & vbTab
         ElseIf Rng.Column = 2 Then
             strData = strData & Rng & vbCr
         End If
     Next
     Debug.Print strData

     Dim fsT As Object
     Set fsT = CreateObject("ADODB.Stream")
     fsT.Type = 2 '指定類型，儲存文字資料使用2
     fsT.Charset = "UTF-8" '指定字元集為UTF8
     fsT.Open '開啟與寫入二進位資料到物件
     fsT.WriteText strData
     fsT.SaveToFile "D:\Day15_4_2.txt", 2 '寫入二進位資料到磁碟
End Sub
此種寫法是我覺得最簡便的，請問是否有大哥可以指導修正。
作者: Joforn    時間: 2016-1-15 20:51

回復 5# lionliu
3#的代碼相比你找到的代碼而言更合適。
當然了，如果你不考慮系統兼容性和運行速度的話就用你認為好的代碼即可。
你找到的代碼和我粘出來的代碼在大陸的網站上幾年前有不少討論的，這裡我就不重復了。
作者: lionliu    時間: 2016-1-15 23:12

回復 6# Joforn

謝謝 J大的指導，#3的部分我會再好好爬一下文。
作者: lionliu    時間: 2016-1-30 08:53

回復 6# Joforn
joforn 大哥好：
我試了我找到的方法，還有你的方法可以產生utf8，但是對方要求要沒有Bom檔首的utf8，
不知大哥或其他大大有無其他方法。
作者: lionliu    時間: 2016-1-30 11:44

回復  Joforn
joforn 大哥好：
我試了我找到的方法，還有你的方法可以產生utf8，但是對方要求要沒有Bom檔 ...
lionliu 發表於 2016-1-30 08:53

我試了
  1. Sub Day15_4_()
  2. '多國語言文字寫入UTF8格式的文字檔
  3.       Sheets(1).Select
  4.       Dim Rng As Object
  5.       Dim strData

  7.       For Each Rng In Range("A1:b9")
  8.           If Rng.Column = 1 Then
  9.               strData = strData & Rng & vbTab
  10.          ElseIf Rng.Column = 2 Then
  11.              strData = strData & Rng & vbCr
  12.          End If
  13.      Next
  14.      Debug.Print strData

  16.      Dim fsT As Object
  17.      Set fsT = CreateObject("ADODB.Stream")
  18.      fsT.Type = 2 '指定類型，儲存文字資料使用2
  19.      fsT.Charset = "UTF-8" '指定字元集為UTF8
  20.      fsT.Open '開啟與寫入二進位資料到物件
  21.      fsT.WriteText strData
  22.      fsT.SaveToFile "D:\Day15_4_2.txt", 2 '寫入二進位資料到磁碟
  23. End Sub
複製代碼
這方法是無bom檔首的，但是我要如何將整個工作表依順序寫入而不是合成一行，是否有大哥可以指導一下。



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)