Вывод в файл в UTF-8

Alex Pancho
Дата: 14.03.2016 15:15:38
В базе используется текст в кодировке UTF-8.
Надо вывести результат запроса в файл, но текст в УТФ отображает знаками вопроса.
Private Sub button01_Click()
    'delete old filedata
    Call ClearTablesRef
    'link new file
    Call LinkSchema
    '
End Sub


Function LinkSchema()
   Dim db As Database, tbl As TableDef, filename As String, rst As Recordset, arr()
      Set db = CurrentDb()
   Set tbl = db.CreateTableDef("SourceData")
   ' Append selection of any file through a dialog box
   filename = "Asci.txt"
   Call SchemaIniCreate(filename)
   ' Connect to the data source file
   tbl.Connect = "Text;DATABASE=" & CurrentProject.Path & ";TABLE=" & filename & ""
   tbl.SourceTableName = filename
With db.TableDefs
    .Append tbl
    .Refresh
End With
    ' Find error in file
    strSql = "SELECT SourceData.pid, SourceData.Sname, SourceData.Fname, SourceData.fday " & _
    "FROM SourceData GROUP BY SourceData.pid, SourceData.Sname, SourceData.Fname, SourceData.fday " & _
    "HAVING ((Count(*) Mod 2)=1)"
    
    Set rst = db.OpenRecordset(strSql)
        If rst.RecordCount > 0 Then
           Call ErrLogCreate(funMsgListRecord(strSql))
           Call MsgBox("Import with errors!", vbCritical, "ERRORS!")
         
    End If
    
    
  
End Function

' Create schema.ini for .csv or .txt file
' If the column names, number of columns, or type columns of data will be changed - edit this part of the code.
Function SchemaIniCreate(filename As String)
    Dim create_file_name As String
    create_file_name = CurrentProject.Path & "\schema.ini"
    Open create_file_name For Output As #1
    Print #1, "[" & filename & "]"
    Print #1, "Format = Delimited(;)" 'IN USE. Use only one!
    'Print #1, "Format = Delimited(,)" 'Use only one!
    Print #1, "MaxScanRows = 0"
    Print #1, "ColNameHeader = False"
    Print #1, "CharacterSet = 65001"
    Print #1, "DecimalSymbol = ."
    Print #1, "CurrencyDecimalSymbol = ."
    Print #1, "Col1=""ouid"" Long Width 10"
    Print #1, "Col2=""did"" Long Width 10"
    Print #1, "Col3=""pid"" Long Width 10"
    Print #1, "Col4=""fday"" DateTime Width 30"
    Print #1, "Col5=""ftime"" DateTime Width 30"
    Print #1, "Col6=""punch"" Byte Width 3"
    Print #1, "Col7=""Sname"" Char Width 100"
    Print #1, "Col8=""Fname"" Char Width 100"
    Close #1
End Function

' Create Error Description
Function funMsgListRecord(ByVal sSQL As String)
Dim rst As DAO.Recordset
Dim sListMsg As String
Dim Output As String

On Error GoTo Err_
    Set rst = CurrentDb.OpenRecordset(sSQL, dbOpenSnapshot)
    With rst
        If Not (.BOF And .EOF) Then
            .MoveLast
            .MoveFirst
            Do Until .EOF
                If sListMsg = "" Then
                    Output = "id:" & !PID & ", Name: " & !Sname & " " & !fname & ", Date:" & !fDay & ""
                    sListMsg = Output
                Else
                    Output = "id:" & !PID & ", Name: " & !Sname & " " & !fname & ", Date:" & !fDay & ""
                    sListMsg = sListMsg & "</p><p>" & vbCrLf & Output
                End If
                .MoveNext
            Loop
        End If
        .Close
    End With
    Set rst = Nothing
    funMsgListRecord = sListMsg
Exit Function

Err_:
    MsgBox Err.Description
    Err.Clear
End Function


' Create errorlog.html if .csv or .txt contain error
Function ErrLogCreate(errmsg As String)
    Dim errorlog As String
    errorlog = CurrentProject.Path & "\errorlog.html"
    Open errorlog For Output As #2
    Print #2, "<!DOCTYPE html><html><head><meta charset=""utf-8""><title>Error log</title><body>"
    Print #2, "<h1>Errors in the import file:</h1>"
    Print #2, "<h2>" & errmsg & "</h2>"
    Print #2, "</body></html>"
    Close #2
End Function


В errorlog.html имена юзеров из базы выводит так: ????? ?????
Konst_One
Дата: 14.03.2016 15:38:06
используйте ADODB.Stream с указанием кодовой страницы в output
Alex Pancho
Дата: 14.03.2016 16:30:21
Konst_One,

мне б примерчик, если можно
Alex Pancho
Дата: 14.03.2016 21:18:12
Konst_One,

Не выходит цветок каменный:
' Create Error Description
Function funMsgListRecord(sSQL As String)
Dim rst As DAO.Recordset
Dim sListMsg As String
Dim Output As String
Dim strm 'As ADODB.Stream
On Error GoTo Err_
    Set rst = CurrentDb.OpenRecordset(sSQL, dbOpenSnapshot)
    ' New output
    'Debug.Print rst.Value
    
    With rst
        If Not (.BOF And .EOF) Then
            .MoveLast
            .MoveFirst
            Do Until .EOF
                If sListMsg = "" Then
                    Output = "<td>" & !PID & "</td><td>" & !Sname & " " & !fname & "</td><td>" & !fDay & "</td>"
                    sListMsg = Output
                Else
                    Output = "<td>" & !PID & "</td><td>" & !Sname & " " & !fname & "</td><td>" & !fDay & "</td>"
                    sListMsg = sListMsg & "</tr><tr>" & vbCrLf & Output
                End If
                .MoveNext
            Loop
        End If
        .Close
    End With
    Set rst = Nothing
' New output
   
    Set strm = New ADODB.Stream
    strm.Type = adTypeText
    strm.Charset = "utf-8"
    strm.Open
    strm.WriteText sListMsg 'rst.Value '
    ErrLogCreate (strm)
    
    funMsgListRecord = strm
   
' Old output
    'funMsgListRecord = sListMsg
Exit Function

Err_:
    MsgBox Err.Description
    Err.Clear
End Function


' Create errorlog.html if .csv or .txt contain error
Function ErrLogCreate(errmsg As String)
    Dim errorlog As String
    errorlog = CurrentProject.Path & "\errorlog.html"
    Open errorlog For Output As #2
    Print #2, "<!DOCTYPE html><html><head><meta charset=""utf-8"">"
    Print #2, "<title>Error log</title>"
    Print #2, "<style type=""text/css"">"
    Print #2, ".tg  {border-collapse:collapse;border-spacing:0;border-color:#999;}"
    Print #2, ".tg td{font-family:sans-serif;font-size:14px;padding:10px 14px;border-style:solid;border-width:0px;overflow:hidden;word-break:normal;border-color:#999;color:#444;background-color:#F7FDFA;border-top-width:1px;border-bottom-width:1px;}"
    Print #2, ".tg th{font-family:sans-serif;font-size:14px;font-weight:normal;padding:10px 14px;border-style:solid;border-width:0px;overflow:hidden;word-break:normal;border-color:#999;color:#fff;background-color:#26ADE4;border-top-width:1px;border-bottom-width:1px;}"
    Print #2, "</style><body>"
    Print #2, "<h1>Errors in the import file:</h1>"
    Print #2, "<table class=""tg"">"
    Print #2, "<tr><th>Persn ID</th><th>Name</th><th>Date</th></tr>"
    Print #2, "<tr>" & errmsg & "</tr>"
    Print #2, "</table></body></html>"
    Close #2
End Function
Alex Pancho
Дата: 14.03.2016 22:45:46
Alex Pancho,

Все, спасибо вышло, правда пришлось чуток вывод переписать:
' Create Error Description
Function funMsgListRecord(sSQL As String)
Dim rst As DAO.Recordset
Dim sListMsg As String
Dim Output As String
Dim strm As ADODB.Stream
On Error GoTo Err_
    Set rst = CurrentDb.OpenRecordset(sSQL, dbOpenSnapshot)
    ' New output
    Debug.Print rst(0).Value
    
    With rst
        If Not (.BOF And .EOF) Then
            .MoveLast
            .MoveFirst
            Do Until .EOF
                If sListMsg = "" Then
                    Output = "<td>" & !PID & "</td><td>" & !Sname & " " & !fname & "</td><td>" & !fDay & "</td>"
                    sListMsg = Output
                Else
                    Output = "<td>" & !PID & "</td><td>" & !Sname & " " & !fname & "</td><td>" & !fDay & "</td>"
                    sListMsg = sListMsg & "</tr><tr>" & vbCrLf & Output
                End If
                .MoveNext
            Loop
        End If
        .Close
    End With
    Set rst = Nothing
' New output
   
    Set strm = New ADODB.Stream
    strm.Type = adTypeText
    strm.Charset = "utf-8"
    strm.Open
    strm.WriteText ErrLogCreateNew()
    strm.WriteText sListMsg
    strm.WriteText ("</tr></table></body></html>")
    strm.SaveToFile CurrentProject.Path & "\errorlog.html", 2
Exit Function

Err_:
    MsgBox Err.Description
    Err.Clear
End Function

' Create errorlog.html head and body if .csv or .txt contain error
Function ErrLogCreateNew()
    Dim errorlog As String
    errorlog = "<!DOCTYPE html><html><head><meta charset=""utf-8"">" & _
        "<title>Error log</title>" & _
        "<style type=""text/css"">" & _
        ".tg  {border-collapse:collapse;border-spacing:0;border-color:#999;}" & _
        ".tg td{"ДЛИННОЕ_ОПИСАНИЕ_СТИЛЯ"}" & _
        ".tg th{"ДЛИННОЕ_ОПИСАНИЕ_СТИЛЯ"}" & _
        "</style><body>" & _
        "<h1>Errors in the import file:</h1>" & _
        "<table class=""tg"">" & _
        "<tr><th>Persn ID</th><th>Name</th><th>Date</th></tr>" & _
        "<tr>"
    ErrLogCreateNew = errorlog
End Function