Вывод результата выполнения запроса SELECT в HTML файл
По материалам: https://www.cyberforum.ru/ms-access/thread2860557.html#post15631886
Sub mm210722() q1 "select * from [товар]" End Sub Public Function q1(Optional strSQL As String = "", _ Optional intMax As Integer = 100) As Boolean ''количество строк Dim RST As Recordset, FLD As Field, i As Integer Dim intNr As Integer ' Dim zpath, kf, J1, J1K, S1, S2, zname Dim ZTABLE1, ZTABLE2, ZTABLE9, ZROW, ZCEL, ZCELH, ZHEAD1, ZHEAD9, ZH2, ZH2K ZTABLE1 = "<TABLE BORDER=1 WIDTH=100% CELLSPACING=0 CELLPADDING=0>" ZTABLE2 = "<TABLE BORDER=1 CELLSPACING=0 CELLPADDING=0>" ZTABLE9 = "</TABLE>" ZROW = "<TR>" ZCEL = "<TD>" ZCELH = "<TH>" ZHEAD1 = "<THEAD>" ZHEAD9 = "</THEAD>" ZH2 = "<H2>": ZH2K = "</H2>" zpath = Access.CurrentProject.Path & "\" kf = FreeFile zname = zpath & "protocol_" & Format(Now, "yyyy_mm_dd_hh_nn") & ".htm" Open zname For Output As kf On Error GoTo Err_SQL ''''''''''''''''''''''''''головная часть''''''''''''''''''''''''''''''' Print #kf, "<HTML>" Print #kf, ZH2; " Running [" & strSQL & "]"; ZH2K Set RST = CurrentDb.OpenRecordset(strSQL) RST.MoveLast Print #kf, "<BR> Query; returned; " & RST.RecordCount & "; entries." RST.MoveFirst Print #kf, ZTABLE2 ''''''''''''''''''''''''''шапка''''''''''''''''''''' Print #kf, ZHEAD1 Print #kf, ZROW & ZCELH & "№№" For Each FLD In RST.Fields Print #kf, ZCELH & Replace(FLD.Name, "_", " ") Next Print #kf, ZHEAD9 ''''''''''''''''''''''''''данные'''''''''''''''''''''' intNr = 1 Do While RST.EOF = False And (intNr <= intMax) Print #kf, "" Print #kf, ZROW & ZCELH & intNr, For Each FLD In RST.Fields S1 = FLD.Type If S1 = 11 Then S2 = "~OLE" '' есть и другие исключения Else S2 = FLD.Value & "" If S2 = "" Then S2 = "-" End If Print #kf, ZCEL, S2, Next intNr = intNr + 1 RST.MoveNext Loop '''''''''''''''''''''''''завершение' Print #kf, ZTABLE9 Close #kf RST.Close Set RST = Nothing Set FLD = Nothing S1 = Shell("explorer " & zname, vbMaximizedFocus) Exit Function ''''''''''''''''''''''''обработка ошибки''''''''''''''''''''''''''' Err_SQL: MsgBox Err.Number & " " & Err.Description & "Bad; SQL; string" End Function
