最新の投稿

HKU\.Defaultはデフォルトユーザのものではない。

HKU\.DEFAULT(HKEY_USERS\.DEFAULT)は、あちこちで間違った認識をされている。HKU\.DEFAULT(HKEY_USERS\.DEFAULT)は、デフォルトユーザとかテンプレートユーザと呼ばれるアカウント(=今後作成されるユーザアカウントの初期設定)...

2020/04/09

Excel VBAでHTML作成

Excel VBAで、シートの内容をHTML化して、変数に保存する関数を作った。


Option Explicit

Sub test()
    Dim output As String
    Call Convert_to_HTML("HTML化対象", output)
    MsgBox output
End Sub

Sub Convert_to_HTML(ByVal s_input_sheet As String, ByRef s_outdata As String)

    Dim tmp_path As String
    Dim tmp_filename As String
    Dim tmp_file As String
    
    tmp_path = ThisWorkbook.Path
    tmp_filename = ThisWorkbook.Name & "_tmp_HTML_12345.htm"
    tmp_file = tmp_path & "\" & tmp_filename
    

    '警告や確認を促すメッセージの表示をさせない
    Application.DisplayAlerts = False
    
    'tmpファイルが存在するなら削除
    If Dir(tmp_file) <> "" Then
        Kill tmp_file
    End If
    
    'HTMLでtmpファイルに出力
    Sheets(s_input_sheet).Select
    With ActiveWorkbook.WebOptions
        .RelyOnCSS = True
        .OrganizeInFolder = True
        .UseLongFileNames = True
        .DownloadComponents = False
        .RelyOnVML = True
        .AllowPNG = True
        .ScreenSize = msoScreenSize1024x768
        .PixelsPerInch = 96
        .Encoding = msoEncodingJapaneseShiftJIS
    End With
    With Application.DefaultWebOptions
        .SaveHiddenData = False
        .LoadPictures = True
        .UpdateLinksOnSave = False
        .CheckIfOfficeIsHTMLEditor = False
        .AlwaysSaveInDefaultEncoding = False
        .SaveNewWebPagesAsWebArchives = True
    End With
    With ActiveWorkbook.PublishObjects.Add(xlSourceSheet, _
        tmp_file, "HTML化対象", "", xlHtmlStatic, _
        "FKTN_HTML_20354", "")
        .Publish (True)
        .AutoRepublish = False
    End With
    
    'tmpファイルの内容をs_outdataに読み込む
    Dim buf As String
    Open tmp_file For Input As #1
        Do Until EOF(1)
            Line Input #1, buf
            s_outdata = s_outdata & buf
        Loop
    Close #1
    
    'tmpファイルを削除
    Kill tmp_file
    
    '警告や確認を促すメッセージの表示をさせる
    Application.DisplayAlerts = True
End Sub


0 件のコメント:

コメントを投稿