HTML変換と文字列置換          <TOP>

PathRenameExtension パス名の拡張子だけを変更

　

F-Basicで作成したbasファイルは、FrontPageでhtmlに変換しているのですが、Tabを8文字から4文字に、コメント部分は暗緑色にとか背景色をFDFFFFに統一したいとかいろいろ欲が出てきましたので、HTML変換と置換関数を一つにしました。

通常、「ファイル保存」をクリックするとHTMLの場合.htm、置換の場合は読込と同じファイル名で保存します。

FrontPageのHTMLに貼り付けるため、「Clip複写」を設けています。

「ファイルを開く」、または目的ファイルを「読み込み」EditBoxへドラッグ＆ドロップします。

　

'================================================================
'= 文字列置換・HTMLに変換
'=    (ReplaceHtml.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$)

#define vbCrLf (Chr$(13) & Chr$(10))    'キャリッジリターンとラインフィード(\r\n)
 
Var Shared Edit(4) As object
Var Shared Text(9) As Object
Var Shared BmpButton(5) As Object
Var Shared Radio(1) As Object
Var Shared Check1 As Object

For i = 0 To 4
    Edit(i).Attach GetDlgItem("Edit" & Trim$(Str$(i + 1)))
    If i < 2 Or i > 2 Then
        Edit(i).SetFontSize 14
    Else
        Edit(i).SetFontSize 12
    End If
Next
For i = 0 To 9
    Text(i).Attach GetDlgItem("Text" & Trim$(Str$(i + 1)))
    If i < 5 Or i = 9 Then
        Text(i).SetFontSize 12
    Else
        Text(i).SetFontSize 14
    End If
Next
For i = 0 To 5
    BmpButton(i).Attach GetDlgItem("BmpButton" & Trim$(Str$(i + 1)))
Next
For i = 0 To 1
    Radio(i).Attach GetDlgItem("Radio" & Trim$(Str$(i + 1)))
    Radio(i).SetFontSize 14
Next
Check1.Attach GetDlgItem("Check1") : Check1.SetFontSize 14

Var Shared FileName As String           'ファイル名
Var Shared zX As Integer                'サイズグリップX軸
Var Shared zY As Integer                'サイズグリップY軸
Var Shared FLG As Integer               '置換/HTML変換
Var Shared Buffer As String

'================================================================
'= 拡張子をhtmに変換
'================================================================
Declare Sub ExtensionSet()
Sub ExtensionSet()
    Var Temp As String
    Var Ret As Long

    '拡張子をhtmに変換
    Temp = FileName & String$(260, Chr$(0))
    Ret = Api_PathRenameExtension(Temp, ".htm")
    Edit(1).SetWindowText Temp
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

'================================================================
'= 置換関数
'= sOriginal:原本 sCorrection:修正文字 sReplace:置換文字 
'================================================================
Declare Function Replace(strOrgriginal As String, strCororrection As String, strReplace As String) As String
Function Replace(strOrgriginal As String, strCororrection As String, strReplace As String) As String
    Var txt As String
    Var ePos As Integer

    txt = ""
    Do
        ePos = InStr(strOrgriginal, strCororrection)
        If ePos = 0 Then Exit Do

        txt = txt & Left$(strOrgriginal, ePos - 1) & strReplace
        strOrgriginal = Mid$(strOrgriginal, ePos + Len(strCororrection))
    Loop

    txt = txt & strOrgriginal
    Replace = txt
End Function

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

    txt = ""

    'チェック無しの場合(BodyColor=無)
    If Check1.GetCheck = 0 Then
        txt = ""

    'チェック有りの場合(BodyColor=#FDFFEE)
    Else
        txt = txt & "<BODY BGCOLOR=" & Chr$(34) & "#FDFFEE" & Chr$(34) & ">" & vbCrLf 
    End If

    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(SourceText) > 0
        ePos = InStr(SourceText, vbCrLf)
        If ePos = 0 Then
            NextLine = SourceText
            SourceText = ""
        Else
            NextLine = Left$(SourceText, ePos - 1)
            SourceText = Mid$(SourceText, ePos + Len(vbCrLf))
        End If

        NextLine = Replace(NextLine, "&", "&amp;")
        NextLine = Replace(NextLine, "<", "&lt;")
        NextLine = Replace(NextLine, ">", "&gt;")

        NextLine = Comments(NextLine)
        NextLine = Replace(NextLine, """", "&quot;")

        txt = txt & NextLine & vbCrLf
    Loop

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

    TextToHTML = txt
End Function

'================================================================
'= 文字列置換を選択
'================================================================
Declare Sub Radio1_on edecl ()
Sub Radio1_on()
    FLG = 0

    Text(7).EnableWindow -1
    Text(8).EnableWindow -1
    Edit(3).EnableWindow -1
    Edit(4).EnableWindow -1

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

'================================================================
'= HTML変換を選択
'================================================================
Declare Sub Radio2_on edecl ()
Sub Radio2_on()
    FLG = 1

    Edit(3).SetWindowText ""
    Edit(4).SetWindowText ""

    Text(7).EnableWindow 0
    Text(8).EnableWindow 0
    Edit(3).EnableWindow 0
    Edit(4).EnableWindow 0

    ExtensionSet
End Sub

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

'================================================================
'= ファイル読込
'================================================================
Declare Sub FileRead()
Sub FileRead()
    Var hFile As Byte
    Var Temp As String
    Var Ret As long

    On Error GoTo *ErTrap

    BmpButton5_on                                 'Edit3消去連動
    Radio1_on                                     '
    Radio(0).SetCheck 1
    Radio(1).SetCheck 0
    Check1.SetCheck 0

    Edit(0).SetWindowText FileName
    hFile = FreeFile

    Open FileName For BinInp As hFile
        Buffer = Space$(lof(hFile))
        fread hFile, Buffer
        Buffer = jconv$(Buffer, 0, 2)
        Edit(2).SetWindowText Buffer
    Close hFile

    If FLG = 0 Then
        Edit(1).SetWindowText FileName
    Else
        ExtensionSet
    End If
    Exit Sub

*ErTrap
    Close hFile
    Edit(0).SetWIndowText ""
    Resume *ErReturn

*ErReturn
    On Error GoTo 0
End Sub

'================================================================
'= ファイル読込
'================================================================
Declare Sub BmpButton1_on edecl ()
Sub BmpButton1_on()
    FileName = WinOpEndlg("ファイルのオープン", "*.txt;*.bas;*.rc", "ﾃｷｽﾄ(*.txt);basﾌｧｲﾙ(*.bas);rcﾌｧｲﾙ(*.rc)", 0)
    If FileName => Chr$(&H1B) Then
        FileRead
    Else
        FileName = ""
    End If
End Sub

'================================================================
'= シェルドロップされたファイル名を取得
'================================================================
Declare Sub Edit1_DropFiles edecl (ByVal DF As Long)
Sub Edit1_DropFiles(ByVal DF As Long)
    Var CN As Long

    CN = GetDropFileCount(DF)
    FileName = GetDropFileName(DF, 0)
    Edit(0).SetWindowText FileName
    Edit(1).SetWindowText FileName
    FileRead
End Sub

'================================================================
'= シェルドロップされたファイル名を取得
'================================================================
Declare Sub MainForm_DropFiles edecl (ByVal DF As Long)
Sub MainForm_DropFiles(ByVal DF As Long)
    Var CN As Long

    CN = GetDropFileCount(DF)
    FileName = GetDropFileName(DF, 0)
    Edit(0).SetWindowText FileName
    Edit(1).SetWindowText FileName
    FileRead
End Sub

'================================================================
'= FLG=0(同名で上書保存)・FLG=1(HTMLとして保存)
'================================================================
Declare Sub BmpButton2_on edecl ()
Sub BmpButton2_on()
    Var hFile As Byte

    FileName = Edit(0).GetWindowText

    If Edit(2).GetWindowText = "" Then
        Exit Sub                                  'Buffer(Edit(2))に何も入っていない場合
    Else If FileName = "" Then
        FileName = "default.htm"                  'ファイル名が無い場合(デフォルト名)
        Edit(1).SetWindowText FileName
    End If

    FileName = Edit(1).GetWindowText　　　　　　  'ファイル名はEdit(1)より取得

    If IsExistFile(FileName) Then kill FileName
    hFile = FreeFile

    Open FileName For BinIo As hFile
        Buffer = Edit(2).GetWindowText
        fwrite hFile, Buffer
    Close hFile

    SetFocus
End Sub

'================================================================
'= 文字列置換実行
'================================================================
Declare Sub BmpButton3_on edecl ()
Sub BmpButton3_on()
    If Edit(3).GetWindowText = "" Then
        A% = MessageBox("Attention!", "検索文字列を指定してください！", 0, 2)
        Exit Sub
    End If
 
    Var strOrg As String
    Var strCor As String
    Var strRep As String

    strCor = Edit(3).GetWindowtext                '検索文字列
    strRep = Edit(4).GetWindowtext                '置換後文字列
    strOrg = Edit(2).GetWindowtext                'バッファ内の文字列

    '----------------------------------------
    Buffer = Replace(strOrg, strCor, strRep)
    '----------------------------------------

    EDit(2).SetWindowText Buffer
    SetFocus
End Sub

'================================================================
'= ソース → HTML変換
'================================================================
Declare Sub BMpButton4_on edecl ()
Sub BmpButton4_on()
    If Edit(2).GetWindowText = "" Then SetFocus : Exit Sub

    ExtensionSet
    Radio2_on
    Radio(0).SetCheck 0
    Radio(1).SetCheck 1

    If Edit(2).GetWindowText = "" Then
        SetFocus : Exit Sub
    Else if Ucase$(Left$(Edit(2).GetWindowText, 9)) = "<TT><PRE>" Or Ucase$(Left$(Edit(2).GetWindowText, 9)) = "<BODY BGC" Or Ucase$(Left$(Edit(2).GetWindowText, 6)) = "<HTML>" Then
        A% = MessageBox(GetWindowText, "既に変換されています！",0, 2)
        SetFocus : Exit Sub
    End If

    Edit(2).SetWindowText TextToHTML(Edit(2).GetWindowText)
    SetFocus
End Sub

'================================================================
'=    コピー
'================================================================
Declare Sub BmpButton6_on edecl ()
Sub BmpButton6_on()
    Edit(2).SetSelText 0, -1
    Edit(2).Copy
    Edit(2).SetSelText -1, 0
    SetFocus
End sub

'================================================================
'=
'================================================================
Declare Sub MainForm_Start edecl ()
Sub MainForm_Start()
    Line(0, 1) - (GetWidth, 1),, 1 : Line(0, 2) - (GetWidth, 2),, 15
    Line(0, 33) - (GetWidth, 33),, 1 : Line(0, 34) - (GetWidth, 34),, 15
End Sub

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