Tworzenie pliku HTM poprzez Excel VBA

Choć kodu, który jest poniżej nigdy nie użyłem w finalnej aplikacji to w testach już tak – spędzając trochę czasu nad nim. Kod wydaje się dość fajny, użyto tagów HTML aby utworzyć plik HTM otwierany w przeglądarce internetowej.

Utworzenie pliku w formacie HTM gwarantuje nam, że po jego otwarciu będzie (powinien) zachowywać się tak samo na każdej stacji roboczej. Plik HTM tworzyłem w momencie, gdy nie było w Excelu narzędzia zapisywania zawartości do pliku PDF.

Z poniższych źródeł skorzystałem, aby utworzyć plik HTM:
1. Tworzenie pliku HTM z danych w arkuszu
2. Filtr rozszerzeń przy zapisaniu plików
3. Różne rodzaje tabel w CSS
4. Rozmiar czcionki w CSS
5. Polskie znaki w Firefox

Do testów trzeba dodać jakieś dane w aktywnym arkuszu, najlepiej tak jak poniżej:

Jak utworzyć plik HTM:

' Source:
' Tworzenie pliku HTM z danych w arkuszu
' http://www.meadinkent.co.uk/xlhtmltable.htm
' Filtr rozszerzeń przy zapisaniu plików
' http://software-solutions-online.com/2014/03/13/excel-vba-save-file-dialog-getsaveasfilename/
' Różne rodzaje tabel w css
' http://stackoverflow.com/questions/7992198/html-how-to-make-2-tables-with-different-css
' Rozmiar czcionki w css
' http://www.w3schools.com/tags/att_font_size.asp
' Polskie znaki w Firefox
' http://forums.phpfreaks.com/topic/132413-polish-characters-dont-display-properly/

Sub HTM_Page_Creation()

Dim TempStr
Dim PageName As String
Dim MyFormats As Variant
Dim FirstRow, LastRow, FirstCol, LastCol, MyRow, MyCol As Integer

' ----------------------------------
' LOKALIZACJA PLIKU HTM

PageName = Application.GetSaveAsFilename("HTM_File_Name", "Plik HTM (*.htm), *.htm", 1, "Zapisz zamówienie")
' Sprawdzanie czy user czasem nie nacisął ANULUJ
If PageName = "False" Then
    MsgBox "Zaniechano zapisu.", vbOKOnly + vbInformation, "POTWIERDZENIE..."
    Exit Sub
End If

' ----------------------------------
' DEFINIOWANIE ZMIENNYCH

' MyFormats is an array which can contain formats for numbersand dates. Add one element for each table column.
MyFormats = Array("#", "dd mmm yy", "# ##0 pln", "0%")

' Sztywne deklaracje zakresu tabeli w htm
FirstRow = 1
LastRow = 6
FirstCol = 1
LastCol = 4

' ----------------------------------
' SPRAWDZANIE POPRAWNOŚCI DANYCH (choć przyznaje, że nie wiem jak to działa)

'Jeżeli bład to przerwanie makra
'If UBound(MyFormats2) < (LastCol - FirstCol) Then
'    MsgBox "Brak danych w arkuszu. Zatrzymanie wykonania kodu.", vbOKOnly + vbCritical, "TWORZENIE PLIKU HTM..."
'    Exit Sub
'End If

' ----------------------------------
' TWORZENIE PLIKU HTM

Open PageName For Output As #1
Print #1, "<html>"
Print #1, "<head>"
Print #1, "<title>COMPANY SALE RAPORT</title>" ' widoczny m.in. w zakładce w przegladarce
Print #1, "<meta http-equiv='content-type' content='text/html;charset=windows-1250' />" ' polskie znaki w FireFox
Print #1, "<style type='text/css'>"
Print #1, "body {font-family: Arial, Helvetica; font-size: 11pt; margin-left: 10; margin-right: 10}"
Print #1, "td.td1 {padding: 1pt 3pt 2pt 3pt; border-style: solid; border-width: 1; border-color: #0F5BB9; font-size: 11pt}"
Print #1, "table.table1 {border-collapse: collapse; border-width: 1 ; border-style: solid; border-color: #0F5BB9 }"
Print #1, "p.p1 {font-size: 8pt}"
Print #1, "</style>"
Print #1, "</head>"

Print #1, "<body>"
Print #1, "<h1>MÓJ TYTUŁ STRONY</h1>"
Print #1, "<p></p>"
Print #1, "<table class='table1'>"
Print #1, "<p></p>"

' Fizyczne dodawanie wartości z arkusza do pliku HTM
For MyRow = FirstRow To LastRow
    Print #1, "<tr>"
    For MyCol = FirstCol To LastCol
            If MyRow = 1 Then
                TempStr = Cells(MyRow, MyCol).Value
                TempStr = "<b>" & TempStr & "</b>"
                TempStr = "<td class='td1'; align='center'; bgcolor='#58FAF4'>" & TempStr & "</td>"
            Else
                If IsNumeric(Cells(MyRow, MyCol).Value) = True Then
                    TempStr = Format(Cells(MyRow, MyCol).Value, MyFormats(MyCol - FirstCol))
                    TempStr = "<td class='td1'; align='right'>" & TempStr & "</td>"
                Else
                    TempStr = Cells(MyRow, MyCol).Value
                    TempStr = "<td class='td1'; align='left'>" & TempStr & "</td>"
                End If
            End If
        Print #1, TempStr
    Next MyCol
    Print #1, "</tr>"
Next MyRow

Print #1, "</table>"

' Finalizacja pliku HTM
Print #1, "<p></p>"
Print #1, "<p class='p1'>Można przeszukiwać dane używając [CTRL]+'F'. Naciśnij [Home], aby"
Print #1, "wrócić na górę strony. Dane mogą być kopiowane do Excela</p>"
Print #1, "<hr>"

Print #1, "<p><small>Raport utworzono dnia: " & Format(Date, "dd-mm-yyyy") & " | <a href='http://www.meadinkent.co.uk/'>Plik utworzono dzięki meadinkent</a></small></p>"
Print #1, "<p></p>"
Print #1, "<p><img src='Można dodać jakieś zdjecie'></p>"
Print #1, "</body>"
Print #1, "</html>"
Close #1

MsgBox "Done"

End Sub

Dodaj komentarz

Twój adres email nie zostanie opublikowany. Pola, których wypełnienie jest wymagane, są oznaczone symbolem *

Witryna wykorzystuje Akismet, aby ograniczyć spam. Dowiedz się więcej jak przetwarzane są dane komentarzy.