HTMLに変換          <TOP>

読み込んだファイルをHTMLに変換し保存します。

PathRenameExtension パス文字列から拡張子のみ変更する関数

PathRemoveExtension パス文字列から拡張子を取り除く関数

ReleaseCapture マウスのキャプチャを解放

SendMessage ウィンドウにメッセージを送信

GetSystemMetrics 表示要素の寸法とシステム構成の設定を取得

　

ホームページにTipsを載せる際、注釈部の色を変えた方が見やすくなるかナと思い作成してみました。Text3はサイズグリップ用です。

Edit1、Edit2に水平スクロールを「あり」に変更しました。

「HTMLに変換」のコード(bas)を読み込んでHTMLに変換した状態。注釈部「'」を見つけるとその行を暗緑色で表示させます。<font color=#008000>部

変換後のファイルは拡張子を「.htm」に自動変換し保存します。下段のコードは作成されたファイルを読み込んだものです。

フォームサイズは自由に可変できますが、その最小値は起動時より小さくはできません（アイコン時は除く）。

ファイル名の無いHTMLを保存する場合はdefault.htmとして保存されます。

※ファイルを読み込み、EditBoxに表示させた場合Tabの部分は半角8文字相当に変換されます。このコードでは、Tabを半角4文字への変換はしておりません。

　

'================================================================
'= HTMLに変換
'=    (SourceToHtml.bas)
'================================================================
#include "Windows.bi"
#include "File.bi"

' 二重起動禁止
If PrevInstance Then 
    A% = MessageBox("Attention!", "このプログラムは実行中です。", 0, 2) : End
End If

' パス名の拡張子だけを変更
Declare Function Api_PathRenameExtension& Lib "shlwapi" Alias "PathRenameExtensionA" (ByVal pszPath$, ByVal pszExt$)

' マウスのキャプチャを解放
Declare Function Api_ReleaseCapture& Lib "user32" Alias "ReleaseCapture" ()

' ウィンドウにメッセージを送信
Declare Function Api_SendMessage& Lib "user32" Alias "SendMessageA" (ByVal hWnd&, ByVal wMsg&, ByVal wParam&, lParam As Any)

' 表示要素の寸法とシステム構成の設定を取得
Declare Function Api_GetSystemMetrics& Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex&)

#define WM_NCLBUTTONDOWN &HA1           '非クライアント領域で左マウスボタンを押す
#define HTBOTTOMRIGHT 17                'ウィンドウ境界の右下隅
#define SM_CXFRAME 32                   'サイズ可変ウィンドウの境界線のX方向の幅
#define SM_CYFRAME 33                   'サイズ可変ウィンドウの境界線のY方向の幅
#define SM_CYSIZE 31                    'タイトルバー内のビットマップの高さ
#define SM_CYBORDER 6                   'サイズ固定ウィンドウの境界線のY方向の幅

#define vbCrLf (Chr$(13) & Chr$(10))    'キャリッジリターンとラインフィード(\r\n)
 
Var Shared Edit(3) As Object
Var Shared Text(2) As Object
Var Shared Button(3) As Object

For i = 0 To 3
    Edit(i).Attach GetDlgItem("Edit" & Trim$(Str$(i + 1)))
    Edit(i).SetFontSize 12
Next
For i = 0 To 2
    Text(i).Attach GetDlgItem("Text" & Trim$(Str$(i + 1)))
    If i < 2 Then
        Text(i).SetFontSize 12
    End if
Next
For i = 0 To 3
    Button(i).Attach GetDlgItem("Button" & Trim$(Str$(i + 1)))
    Button(i).SetFontSize 12
Next

Var Shared FileName As String           'ファイル名
Var Shared zX As Integer                'サイズグリップX軸
Var Shared zY As Integer                'サイズグリップY軸

'================================================================
'= サイズグリップ位置計算
'================================================================
Declare Sub MainForm_Start edecl ()
Sub MainForm_Start()
    Var fs As Integer

    fs = 18
    Text(2).SetFontSize fs
    Text(2).SetWindowSize fs, fs
    Text(2).SetFontName "Marlett"
    Text(2).SetWindowText "o"

    ShowWindow -1

    zX = Api_GetSystemMetrics(SM_CXFRAME) * 2 + 1
    zY = Api_GetSystemMetrics(SM_CYFRAME) * 2 + Api_GetSystemMetrics(SM_CYBORDER) + Api_GetSystemMetrics(SM_CYSIZE) + 1
End Sub

'================================================================
'= サイズグリップ処理
'================================================================
Declare Sub Mainform_MouseDown edecl (ByVal Button%, ByVal Shift%, ByVal SX!, ByVal SY!)
Sub Mainform_MouseDown(ByVal Button%, ByVal Shift%, ByVal SX!, ByVal SY!)
    Var Ret As Long

    If Button% = 1 Then
        Ret = Api_ReleaseCapture()
        Ret = Api_SendMessage(Text(2).GethWnd, WM_NCLBUTTONDOWN, HTBOTTOMRIGHT, 0)
    End if
End Sub

'================================================================
'= 注釈を暗緑色で
'================================================================
Declare Function Comments(txt As String) As String
Function Comments(txt As String) As String
    Var ePos As Integer
    Var ch As String
    Var quote As Integer

    For ePos = 1 To Len(txt)
        ch = Mid$(txt, ePos, 1)
        If ch = """" Then
            quote = Not quote
        Else If (ch = "'") And (Not quote) Then
            Exit For
        End if
    Next ePos

    If ePos <= Len(txt) Then
        '暗緑色で表示
        Comments = Left$(txt, ePos - 1) & "<font color=" & "#008000" & ">'" & Mid$(txt, ePos + 1) & "</font>"
　　　　'太字で表示する場合
        'Comments = Left$(txt, ePos - 1) & "<B>'" & Mid$(txt, ePos + 1) & "</B>"
    Else
        Comments = txt
    End if
End Function

'================================================================
'= 置換関数
'================================================================
Declare Function ReplaceString(txt As String, from_str As String, to_str As String) As String
Function ReplaceString(txt As String, from_str As String, to_str As String) As String
    Var Res As String
    Var ePos As Integer

    Res = ""
    Do
        ePos = InStr(txt, from_str)
        If ePos = 0 Then Exit do

        Res = Res & Left$(txt, ePos - 1) & to_str
        txt = Mid$(txt, ePos + Len(from_str))
    Loop

    Res = Res & txt
    ReplaceString = Res
End Function

'================================================================
'= HTML変換部
'================================================================
Declare Function TextToHTML(source_Text As String) As String
Function TextToHTML(source_Text As String) As String
    Var txt As String
    Var ePos As Integer
    Var Next_line As String

    txt = ""
    txt = txt & "<TT><PRE>"
    txt = txt & "<head>"
    txt = txt & "<meta http-equiv=" & Chr$(34) & "Content-Language" & Chr$(34) & " content=" & Chr$(34) & "ja" & Chr$(34) & ">"
    txt = txt & "<meta http-equiv=" & Chr$(34) & "Content-Type" & Chr$(34) & " content=" & Chr$(34) & "Text/html; charset=shift_jis" & Chr$(34) & ">"
    txt = txt & "</head>"
    txt = txt & "<font face=" & Chr$(34) & "ＭＳ ゴシック" & Chr$(34) & ">"

    Do While Len(source_Text) > 0
        ePos = instr(source_Text, vbCrLf)
        If ePos = 0 Then
            Next_line = source_Text
            source_Text = ""
        Else
            Next_line = Left$(source_Text, ePos - 1)
            source_Text = Mid$(source_Text, ePos + Len(vbCrLf))
        End if

        Next_line = ReplaceString(Next_line, "&", "&amp;")
        Next_line = ReplaceString(Next_line, "<", "&lt;")
        Next_line = ReplaceString(Next_line, ">", "&gt;")

        Next_line = Comments(Next_line)
        Next_line = ReplaceString(Next_line, """", "&quot;")

        txt = txt & Next_line & vbCrLf
    Loop

    txt = Left$(txt, Len(txt) - Len(vbCrLf))
    txt = txt & "</PRE></TT></font>" & vbCrLf

    TextToHTML = txt
End Function

'================================================================
'= EditBoxクリア
'================================================================
Declare Sub Button1_on edecl ()
Sub Button1_on()
    For i = 0 To 3
        Edit(i).SetWindowText ""
    Next
End Sub

'================================================================
'= ファイル読込
'================================================================
Declare Sub Button2_on edecl ()
Sub Button2_on()
    Var hFile As byte
    Var Buff As String
    Var Temp As String
    Var Ret As Long

    Button1_on

    FileName = WinOpenDlg("ファイルのオープン", "*.txt;*.bas;*.rc", "ﾃｷｽﾄ(*.txt);basﾌｧｲﾙ(*.bas);rcﾌｧｲﾙ(*.rc)", 0)
    If FileName <> Chr$(&H1B) Then
        Edit(2).SetWindowText FileName
        hFile = FreeFile
        Open FileName For BinInp As hFile
        Buff = Space$(Lof(hFile))
        FRead hFile, Buff
        Buff = JConv$(Buff, 0, 2)
        Edit(0).SetWindowText Buff
        Close hFile

        '拡張子をhtmに変換
        Temp = FileName & String$(260, Chr$(0))
        Ret = Api_PathRenameExtension(Temp, ".htm")
        Edit(3).SetWindowText Temp
    Else
        FileName = ""
    End If
End Sub

'================================================================
'= ソース → HTML変換
'================================================================
Declare Sub Button3_on edecl ()
Sub Button3_on()
    If Edit(0).GetWindowText = "" Then Exit Sub

    Edit(1).SetWindowText TextToHTML(Edit(0).GetWindowText)
End Sub

'================================================================
'= 変換済データをHTMLとして保存
'================================================================
Declare Sub Button4_on edecl ()
Sub Button4_on()
    Var hFile As byte
    Var Buff As String

    FileName = Edit(3).GetWindowText

    If Edit(1).GetWindowText = "" Then
        Exit Sub
    Else If FileName = "" Then
        FileName = "default.htm"
        Edit(3).SetWindowText FileName
    End if

    If IsExistFile(FileName) Then Kill FileName
    hFile = FreeFile
    Open FileName For BinIO As hFile
    Buff = Edit(1).GetWindowText
    FWrite hFile, Buff
    Close hFile
End Sub

'================================================================
'= リサイズ
'================================================================
Declare Sub MainForm_Resize edecl ()
Sub MainForm_Resize()
    '最小基本サイズに戻す
    If GetWidth < 700 Or GetHeight < 512 Then
        SetWindowSize 700, 512
    End if

    Text(0).MoveWindow 12, 16
    Text(1).MoveWindow 12, (GetHeight - 78) / 2 + 15

    Edit(0).MoveWindow 10, 36
    Edit(0).SetWindowSize GetWidth - 34, (GetHeight - 78) / 2 - 37

    Edit(1).MoveWindow 10, (GetHeight - 78) / 2 + 11 + 26
    Edit(1).SetWindowSize GetWidth - 34, (GetHeight - 78) / 2 - 37

    Edit(2).MoveWindow 96, 10
    Edit(2).SetWindowSize GetWidth - 120, 22

    Edit(3).MoveWindow 96, (GetHeight - 78) / 2 + 11
    Edit(3).SetWindowSize GetWidth - 120, 22

    Button(0).MoveWindow  38, GetHeight - 66
    Button(1).MoveWindow 194, GetHeight - 66
    Button(2).MoveWindow 350, GetHeight - 66
    Button(3).MoveWindow 506, GetHeight - 66

    'サイズグリップ(右下)
    Text(2).MoveWindow (GetWidth - Text(2).GetWidth) - zX, GetHeight - Text(2).GetHeight - zY
End Sub

'================================================================
'=
'================================================================
While 1
    WaitEvent
Wend
Stop
End