Const MAX_PATH As Long = 260

'--------------------------------------------------
'コード内に含まれる、特定KEYを含むリンクを抽出する。
'--------------------------------------------------
'strSRC :ソース
'strKEY：検索ＫＥＹ　結果：抽出リンクアドレス
'bPerfectUnity:true=検索ＫＥＹ完全一致/false=あいまい
'＊失敗した場合には、空白が返される
'検索ＫＥＹは結果には含まれない。
'--------------------------------------------------
Public Function GetSearchTAGKEYLIST( _
ByVal strSRC As String, _
ByVal strKEY As String, _
ByVal strTAG1 As String, _
ByVal  strTAG2 As String, _
ByVal  bPerfectUnity As Boolean, _
ByRef strLst() As String, _
ByRef  intIndex As Integer, _
Optional ByVal strTAG1D As String, _
Optional ByVal strTAG2D As String) As String

'Aタグ格納用の動的配列用
Dim SLINK() As String

Dim sTagStart As String
Dim sTagEnd As String

Dim intA As Long
Dim intB As Long

Dim i As Long, J As Long

Dim iStart As Long
Dim iNext As Long
Dim iEnd As Long
Dim iMax As Long

Dim S As String
Dim sCD As String

If 0 < InStr(1, strSRC, strTAG1) Then
sTagStart = strTAG1
sTagEnd = strTAG2
ElseIf 0 < Len(strTAG1D) Then
If 0 < InStr(1, strSRC, strTAG1D) Then
sTagStart = strTAG1D
sTagEnd = strTAG2D
Else
Exit Function
End If
Else
Exit Function
End If

strSRC = Replace(strSRC, vbCrLf, " ")

intA = GetStrByte(sTagStart)
intB = GetStrByte(sTagEnd)
iMax = Len(strSRC)

S = strSRC
If Not bPerfectUnity Then S = LCase(S)
iMax = Len(strSRC)

S = strSRC
For i = 0 To 9999
If intA = 0 Or intB = 0 Then Exit For
sCD = GetSpaceCharacterAtoB(strSRC, sTagStart, sTagEnd, True)
If Len(sCD) = 0 Then Exit For

ReDim Preserve SLINK(J) As String
SLINK(J) = sCD

If 0 < InStr(1, strSRC, sTagStart & sCD & sTagEnd) Then
strSRC = Replace(strSRC, sTagStart & sCD & sTagEnd, "", , 1)
Else
'タグが不正のため、続行不可
Exit For
End If

'FrmMain.Text.Text = strSRC
J = J + 1
DoEvents
Next i
strLst = SLINK() 'KEY HIT
For i = 0 To UBound(SLINK)
If bPerfectUnity Then
J = InStr(1, SLINK(i), ">" & strKEY)
Else
strKEY = LCase(strKEY)
J = InStr(1, SLINK(i), strKEY)
End If
If J > 0 Then Exit For
Next
If i < 0 Then Exit Function
intIndex = i
'アドレス部分の抽出
GetSearchTAGKEYLIST = SLINK(intIndex)
End Function

'--------------------------------------------------
'開始文字列と終端文字列に囲まれた文字列を抽出する。
'--------------------------------------------------
'strSRC :ソース
'strA：開始文字列　strB:終端文字列 reSTR：抽出文字列
'＊失敗した場合には、空白が返される
'bKeyVisible:false=開始文字列と終端文字列は結果には含まれない。
'--------------------------------------------------
Public Function GetSpaceCharacterAtoB(ByVal strSRC As String, _
ByVal strA As String, _
ByVal strB As String, _
Optional ByVal bCRLFspaceChange As Boolean = False, _
Optional ByVal bKeyVisible As Boolean = False) As String
Dim intA As Long
Dim intB As Long

Dim i As Long
Dim iStart As Long
Dim iEnd As Long
Dim iMax As Long

Dim S As String

'文字数取得
intA = Len(strA) 'GetStrByte(strA)
intB = Len(strB) 'GetStrByte(strB)
S = LCase(strSRC)
strA = LCase(strA)
strB = LCase(strB)
'改行を考慮する
If bCRLFspaceChange Then
S = Replace(S, vbCrLf, " ")
End If

iMax = Len(S)
If intA = 0 Or intB = 0 Then Exit Function

iStart = InStr(1, S, strA)
If iStart = 0 Then Exit Function
If Not bKeyVisible Then
iStart = iStart + intA
iEnd = InStr(iStart, S, strB)
If iEnd = 0 Then Exit Function
S = Mid(strSRC, iStart, iEnd - iStart)
Else
iEnd = InStr(iStart, S, strB)
If iEnd = 0 Then Exit Function
S = Mid(strSRC, iStart, iEnd - iStart + intB)
End If

i = InStr(iStart, S, vbCrLf)
If i > 0 Then
'改行を考慮する
If bCRLFspaceChange Then
S = Replace(S, vbCrLf, " ")
End If
End If
GetSpaceCharacterAtoB = S
End Function

’----------以下共通関数----------------
Public Function GetStrByte(ByRef strA As String)
GetStrByte = LenB(StrConv(strA, vbFromUnicode))
End Function
Public Function ReplaceLink_TwoSpace(ByVal S As String) As String

Dim tmpS As String

Dim intStart As Long
Dim intEnd As Long
Dim intMax As Long

intMax = Len(S)
intStart = InStr(1, S, "<A")
intEnd = InStr(1, S, "</A>")
tmpS = S
If Len(S) > (Len("<A") + intStart) Then
tmpS = Mid(S, intStart + Len("<A"), intMax - Len("<A") - Len("</A>"))
tmpS = Replace(tmpS, " ", " ")
End If
ReplaceLink_TwoSpace = tmpS

End Function
Public Function ReplaseUtoL(ByRef strSRC As String, ByVal S As String) As String
strSRC = Replace(strSRC, UCase(S), LCase(S))
End Function