hàm chuyển đổi định dạng rangetohtml tự dưng bị lỗi không hiểu nguyên nhân

Liên hệ QC

hungpecc1

Thành viên gắn bó
Tham gia
24/8/12
Bài viết
1,709
Được thích
2,304
Giới tính
Nam
Chào các bạn trong diễn đàn,
mình có dùng hàm Rangetohtml để chuyển đổi file range sang định dạng html (ứng dụng để gửi nội dung email) hàm này đã dùng ổn định được gần 10 năm, tự dưng hôm nay bị lỗi không hiểu nguyên nhân là gì, (dòng code bị lỗi mình đã tô vàng bên dưới) các bạn vui lòng gỡ rối giúp mình
trân trọng cảm ơn /.
Dòng code báo lỗi, :((
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)

End With
Mã:
Option Explicit
Function RangetoHTML(rng As Range)
    ' Changed by Ron de Bruin 28-Oct-2006
    ' Working in Office 2000-2007
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
 
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
        SourceType:=xlSourceRange, _
        Filename:=TempFile, _
        Sheet:=TempWB.Sheets(1).Name, _
        Source:=TempWB.Sheets(1).UsedRange.Address, _
        HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
        "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
 
Chào các bạn trong diễn đàn,
mình có dùng hàm Rangetohtml để chuyển đổi file range sang định dạng html (ứng dụng để gửi nội dung email) hàm này đã dùng ổn định được gần 10 năm, tự dưng hôm nay bị lỗi không hiểu nguyên nhân là gì, (dòng code bị lỗi mình đã tô vàng bên dưới) các bạn vui lòng gỡ rối giúp mình
trân trọng cảm ơn /.
Dòng code báo lỗi, :((
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)

End With
Mã:
Option Explicit
Function RangetoHTML(rng As Range)
    ' Changed by Ron de Bruin 28-Oct-2006
    ' Working in Office 2000-2007
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
 
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
        SourceType:=xlSourceRange, _
        Filename:=TempFile, _
        Sheet:=TempWB.Sheets(1).Name, _
        Source:=TempWB.Sheets(1).UsedRange.Address, _
        HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
        "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
Chào bạn, OT đang sử dụng hàm này của bác Siwtom hiện chưa thấy có lỗi gì.
Bạn tham khảo xem:
Mã:
Function read_content(ByVal HTMfile As String)

    Dim fso As Object
    Dim ts As Object
    
'    Settings The iomode argument can have any of the following settings:
'    Constant       Value   Description
'    ForReading     1       Open a file for reading only. You can't write to this file.
'    ForWriting     2       Open a file for writing. If a file with the same name exists, its previous contents are overwritten.
'    ForAppending   8       Open a file and write to the end of the file.

'    The format argument can have any of the following settings:
'    Constant    Value   Description
'    TristateUseDefault -2     Opens the file using the system default.
'    TristateTrue       -1     Opens the file as Unicode.
'    TristateFalse       0     Opens the file as ASCII.
    
    Const ForReading = 1
    Const TristateUseDefault = -2
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(HTMfile).OpenAsTextStream(ForReading, TristateUseDefault)
    read_content = ts.ReadAll
    read_content = Replace(read_content, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    ts.Close
    
    Set ts = Nothing
    Set fso = Nothing
    
End Function
 
Upvote 0
Chào bạn, OT đang sử dụng hàm này của bác Siwtom hiện chưa thấy có lỗi gì.
Bạn tham khảo xem:
Mã:
Function read_content(ByVal HTMfile As String)

    Dim fso As Object
    Dim ts As Object
   
'    Settings The iomode argument can have any of the following settings:
'    Constant       Value   Description
'    ForReading     1       Open a file for reading only. You can't write to this file.
'    ForWriting     2       Open a file for writing. If a file with the same name exists, its previous contents are overwritten.
'    ForAppending   8       Open a file and write to the end of the file.

'    The format argument can have any of the following settings:
'    Constant    Value   Description
'    TristateUseDefault -2     Opens the file using the system default.
'    TristateTrue       -1     Opens the file as Unicode.
'    TristateFalse       0     Opens the file as ASCII.
   
    Const ForReading = 1
    Const TristateUseDefault = -2
   
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(HTMfile).OpenAsTextStream(ForReading, TristateUseDefault)
    read_content = ts.ReadAll
    read_content = Replace(read_content, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    ts.Close
   
    Set ts = Nothing
    Set fso = Nothing
   
End Function
Bạn bị nhầm ý của chủ thớt rồi, code của bạn chỉ là đọc file html, còn chủ thớt muốn đổi vùng dữ liệu sang dạng html, theo mình thấy thì thường áp dụng cho bảng.
Bài đã được tự động gộp:

Chào các bạn trong diễn đàn,
mình có dùng hàm Rangetohtml để chuyển đổi file range sang định dạng html (ứng dụng để gửi nội dung email) hàm này đã dùng ổn định được gần 10 năm, tự dưng hôm nay bị lỗi không hiểu nguyên nhân là gì, (dòng code bị lỗi mình đã tô vàng bên dưới) các bạn vui lòng gỡ rối giúp mình
trân trọng cảm ơn /.
Dòng code báo lỗi, :((
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)

End With
Mã:
Option Explicit
Function RangetoHTML(rng As Range)
    ' Changed by Ron de Bruin 28-Oct-2006
    ' Working in Office 2000-2007
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
 
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
        SourceType:=xlSourceRange, _
        Filename:=TempFile, _
        Sheet:=TempWB.Sheets(1).Name, _
        Source:=TempWB.Sheets(1).UsedRange.Address, _
        HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
        "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
Mình nghĩ office của bạn có vấn đề thôi.
 
Upvote 0
OT test thử như sau, thấy không có lỗi gì.
Mã:
Option Explicit

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
    
End Function

Public Sub send_mail()
    
    Dim tmpBook As Workbook, tmpSheet As Worksheet, rng As Range
    Dim filename As String, bookName As String, sPath As String
    Dim sendFile As Boolean
    
    bookName = "Test__" & Format(Now, "yyyymmdd hhmmss") & ".xlsx"
    
    sPath = Application.DefaultFilePath
    filename = sPath & "\" & bookName
    Set tmpBook = Workbooks.Add
    With tmpBook
        Set rng = .Worksheets(1).Range("A1:D10")
        rng.Value = "Test"
        .SaveAs filename:=filename, FileFormat:=xlOpenXMLWorkbook
    End With

    Const olFormatHTML = 2
    
    Dim OutMail As Object, OutApp As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    sendFile = False
    
    With OutMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = "Test Mai: " & bookName
        .Body = "BR,"
        If Not sendFile Then
            .BodyFormat = olFormatHTML
            .HTMLBody = .Body & "<br>" & RangetoHTML(rng)
        Else
            .Attachments.Add filename
        End If
        .Display
        '.Send
    End With
    tmpBook.Close False
    With CreateObject("Scripting.FileSystemObject")
        .DeleteFile filename
    End With
    
End Sub
 

File đính kèm

  • sendMail.xlsm
    24.5 KB · Đọc: 8
Upvote 0
Mấy cái đã có sẵn trên mạng không ăn thua.

Cái này tự ghi macro (xuất 1 worksheet thành tập tin html), rồi lấy tập tin html phân tích cấu trúc HTML mà xử lý, lấy phần style và table để cho vào bodyMail thôi.

Quan trọng là phần xử lý enconding để chữ tây tàu thái mán hàn cũng được tuốt.
 
Upvote 0
Cảm ơn các bạn, sau một hồi test mình thấy vấn đề nằm ở nội dung tô màu câu lệnh này
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
sử dụng Environ$ chạy code : lập tức tạo ra 2 file htm (1 là do user Admin, 1 là do user tài khoản người dùng)
mình thử thay Environ$("temp") bằng 1 địa chỉ cụ thể C:\Users\manhh\AppData\Local\Temp
Code lại hoạt động bình thường :(
**********
- Không lẽ do mình dùng office 365 bản quyền đồng bộ onedriver ?

Cảm ơn các bạn đã đọc bài viết và trợ giúp .
 
Upvote 0
Cảm ơn các bạn, sau một hồi test mình thấy vấn đề nằm ở nội dung tô màu câu lệnh này
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
sử dụng Environ$ chạy code : lập tức tạo ra 2 file htm (1 là do user Admin, 1 là do user tài khoản người dùng)
mình thử thay Environ$("temp") bằng 1 địa chỉ cụ thể C:\Users\manhh\AppData\Local\Temp
Code lại hoạt động bình thường :(
**********
- Không lẽ do mình dùng office 365 bản quyền đồng bộ onedriver ?

Cảm ơn các bạn đã đọc bài viết và trợ giúp .
Bạn lách nó theo kiểu này xem:
Mã:
sUser = Application.UserName
TempFile = "C:\Users\" & sUser  & "\AppData\Local\Temp\"

Còn lỗi thì gọi luôn tới API :)

Mã:
Option Explicit

Private Declare PtrSafe Function GetTempPath Lib "kernel32.dll" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal Buffer As String) As Long

Public Function GetTempFolder() As String
    Dim Buffer As String * 255
    Call GetTempPath(255, Buffer)
    GetTempFolder = Buffer
End Function
 
Lần chỉnh sửa cuối:
Upvote 0
Web KT

Bài viết mới nhất

Back
Top Bottom