★URLを含む文字列（１文）の中の、URL部分だけを、「新たにタブを開いてジャンプするリンクのHTMLタグ」に置換する関数と、テキストファイルをHTMLに変換するプログラム。（※ただし、URLの末尾に、全角か半角のスペースが入っている必要があります。）

　　
※まだ書きかけです。すみません。
※間違ってたらすみません。
※メモ書きなので、自分でも意味不明な箇所も多いです。ごめんなさい。
　　
　　

●URLを含む文字列（１文）の中の、URL部分だけを、「新たにタブを開いてジャンプするリンクのHTMLタグ」に置換する関数

UrlPartOnlyConv01("http://www.・・・・・・", "")

といった形で呼び出します。

第二引数は、特に何もなければ「""」で。

'
'

Option Explicit

'###############################################################################
'
'URLを含む文字列（１文）の中の、URL部分だけを、
'「新たにタブを開いてジャンプするリンクのHTMLタグ」に置換する関数。
'
'※ただし、URLの末尾に、全角か半角のスペースが入っている必要があります。
'　（基本、全角のスペースを入れておくほうが、のちのち、色々とラクちんかも）
'
'###############################################################################
Function UrlPartOnlyConv01(s_Str04 As String, s_UrlEndText As String) As String

'    Dim s_Str04                 As String
    Dim i_Str01Len              As String
    Dim s_UrlStr01              As String
    Dim i_PosiRrlEndSpace01     As Integer
    Dim s_ConvStr01             As String
    
'    Debug.Print s_Str04
    
    Let s_UrlStr01 = GetURLStr01(s_Str04)
'    Debug.Print URLConv01(s_UrlStr01)
'    Debug.Print s_Str04
    
    Let s_ConvStr01 = Replace(s_Str04, s_UrlStr01, URLConv01(s_UrlStr01) & s_UrlEndText, , , vbTextCompare)

    Let UrlPartOnlyConv01 = s_ConvStr01
 

End Function


'##########################################################################
'
'URLを含む文字列の中の、URL部分だけの、そのURLの長さを返す関数
'
'マイナスの数値が返ったら＝「-1」以下の数値が返ったら、
'URL自体が存在しないか、httpがタイプミスか、
'URLの最後にスペースが無い＝URLの長さが計算できない、など。
'一応、最後のスペースは、半角、全角、いずれかが選べます。
'ただ、基本的には全角がいいです。
'文章内容が決まるまでの「編集の繰り返し」などを考えると。
'
'「s_Str09」・・・URLの含まれた１文の文字列。
'
'「s_UrlEndSpace01」・・・今現在のURLの末尾に付いているスペース
'                         原則、全角のスペースを指定する。
'
'「s_ReplaceSpace01」・・・プログラム上、プログラム内でだけだけど、
'                          置換したいスペース。
'                          原則、半角のスペースを指定する。
'
'##########################################################################

Function GetURLLen01(s_Str09 As String, s_UrlEndSpace01 As String, s_ReplaceSpace01 As String) As Integer

'    Dim s_Str09                 As String
    Dim i_PosiRrlEndSpace01     As Integer
    Dim s_Str10                 As String
    Dim s_Str11                 As String
    
    Dim i_PosiUrlStart01        As Integer
    Dim i_PosiUrlEnd01          As Integer
    Dim i_UrlLen01              As Integer
    
'    Let s_Str09 = "https://amzn.asia/d/fPxKb1s "
    Let s_Str10 = s_Str09

    Let s_Str11 = Replace(s_Str10, s_UrlEndSpace01, s_ReplaceSpace01, , , vbBinaryCompare)
    'いったん、全角のスペースを半角に変換。
    '全角スペースの位置をチェックするコードを書くのが面倒なので。
    'URLの長さを知りたいだけなので、問題無し。
    'ただし、ByRefしてるので、のちのプログラムで半角スペースが
    '全角スペースに置換されたままになってしまうので、
    '「s_Str09」を右辺にはおかない。s_Str10でやる。
    '引数に「ByVal」使えば、このようなコードは多分不要。
       
    
    If 1 <= InStr(1, s_Str11, "http", vbBinaryCompare) Then
    
        Let i_PosiUrlStart01 = InStr(1, s_Str11, "http", vbBinaryCompare)
        
        Let i_PosiRrlEndSpace01 = InStr(i_PosiUrlStart01, s_Str11, s_ReplaceSpace01, vbBinaryCompare)
        
        Let i_PosiUrlEnd01 = i_PosiRrlEndSpace01
        
        Let i_UrlLen01 = i_PosiUrlEnd01 - i_PosiUrlStart01
        
'        Debug.Print i_UrlLen01
        
        Let GetURLLen01 = i_UrlLen01
        
    Else
    
    
    End If

    
End Function

'############################################################
'
'URLを含む１文の文字列から、URLだけを抜き出す関数
'（ただし、URLの末尾に半角か全角のスペースが無いとダメ。
'　じゃないとURLの切れ目が分からないため。）
'
'############################################################

Function GetURLStr01(s_Str01 As String) As String

'    Dim s_Str01                 As String
    Dim i_Str01Len              As String
    Dim s_UrlStr01              As String
    Dim i_PosiRrlEndSpace01     As Integer
    Dim s_Str02                 As String
    
    
    Dim i_PosiUrlStart01        As Integer
    Dim i_PosiUrlEnd01          As Integer
    Dim i_UrlLen01              As Integer
    
    
'    Let s_Str01 = "https://amzn.asia/d/fPxKb1s aa"
    
    Let i_Str01Len = Len(s_Str01)

    Let i_UrlLen01 = GetURLLen01(s_Str01, " ", "　")
    
        Let i_PosiUrlStart01 = InStr(1, s_Str01, "http", vbBinaryCompare)
        
'        Let i_PosiRrlEndSpace01 = InStr(i_PosiUrlStart01, s_Str01, " ", vbBinaryCompare)

        Let i_PosiUrlEnd01 = i_PosiRrlEndSpace01
        
'        Let i_UrlLen01 = i_PosiUrlEnd01 - i_PosiUrlStart01

    Let GetURLStr01 = Mid(s_Str01, i_PosiUrlStart01, i_UrlLen01)
 
End Function

'##########################################################################
'
'URLの文字列のみを、
'「新たにタブを開いてジャンプするリンクのHTMLタグ」
'に変換する関数。
'
'##########################################################################

Function URLConv01(s_Str03 As String) As String
      
      Let URLConv01 = "<a href=""" & s_Str03 & """ target=""_blank"">" & s_Str03 & "</a>"
        
End Function



'
'

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

Option Explicit

'###############################################################################

'URLを含む文字列（１文）の中の、URL部分だけを、

'「新たにタブを開いてジャンプするリンクのHTMLタグ」に置換する関数。

'※ただし、URLの末尾に、全角か半角のスペースが入っている必要があります。

'　（基本、全角のスペースを入れておくほうが、のちのち、色々とラクちんかも）

'###############################################################################

Function UrlPartOnlyConv01(s_Str04 As String, s_UrlEndText As String) As String

' Dim s_Str04 As String

Dim i_Str01Len As String

Dim s_UrlStr01 As String

Dim i_PosiRrlEndSpace01 As Integer

Dim s_ConvStr01 As String

' Debug.Print s_Str04

Let s_UrlStr01 = GetURLStr01(s_Str04)

' Debug.Print URLConv01(s_UrlStr01)

' Debug.Print s_Str04

Let s_ConvStr01 = Replace(s_Str04, s_UrlStr01, URLConv01(s_UrlStr01) & s_UrlEndText, , , vbTextCompare)

Let UrlPartOnlyConv01 = s_ConvStr01

End Function

'##########################################################################

'URLを含む文字列の中の、URL部分だけの、そのURLの長さを返す関数

'マイナスの数値が返ったら＝「-1」以下の数値が返ったら、

'URL自体が存在しないか、httpがタイプミスか、

'URLの最後にスペースが無い＝URLの長さが計算できない、など。

'一応、最後のスペースは、半角、全角、いずれかが選べます。

'ただ、基本的には全角がいいです。

'文章内容が決まるまでの「編集の繰り返し」などを考えると。

'「s_Str09」・・・URLの含まれた１文の文字列。

'「s_UrlEndSpace01」・・・今現在のURLの末尾に付いているスペース

' 原則、全角のスペースを指定する。

'「s_ReplaceSpace01」・・・プログラム上、プログラム内でだけだけど、

' 置換したいスペース。

' 原則、半角のスペースを指定する。

'##########################################################################

Function GetURLLen01(s_Str09 As String, s_UrlEndSpace01 As String, s_ReplaceSpace01 As String) As Integer

' Dim s_Str09 As String

Dim i_PosiRrlEndSpace01 As Integer

Dim s_Str10 As String

Dim s_Str11 As String

Dim i_PosiUrlStart01 As Integer

Dim i_PosiUrlEnd01 As Integer

Dim i_UrlLen01 As Integer

' Let s_Str09 = "https://amzn.asia/d/fPxKb1s "

Let s_Str10 = s_Str09

Let s_Str11 = Replace(s_Str10, s_UrlEndSpace01, s_ReplaceSpace01, , , vbBinaryCompare)

'いったん、全角のスペースを半角に変換。

'全角スペースの位置をチェックするコードを書くのが面倒なので。

'URLの長さを知りたいだけなので、問題無し。

'ただし、ByRefしてるので、のちのプログラムで半角スペースが

'全角スペースに置換されたままになってしまうので、

'「s_Str09」を右辺にはおかない。s_Str10でやる。

'引数に「ByVal」使えば、このようなコードは多分不要。

If 1 <= InStr(1, s_Str11, "http", vbBinaryCompare) Then

Let i_PosiUrlStart01 = InStr(1, s_Str11, "http", vbBinaryCompare)

Let i_PosiRrlEndSpace01 = InStr(i_PosiUrlStart01, s_Str11, s_ReplaceSpace01, vbBinaryCompare)

Let i_PosiUrlEnd01 = i_PosiRrlEndSpace01

Let i_UrlLen01 = i_PosiUrlEnd01 - i_PosiUrlStart01

' Debug.Print i_UrlLen01

Let GetURLLen01 = i_UrlLen01

Else

End If

End Function

'############################################################

'URLを含む１文の文字列から、URLだけを抜き出す関数

'（ただし、URLの末尾に半角か全角のスペースが無いとダメ。

'　じゃないとURLの切れ目が分からないため。）

'############################################################

Function GetURLStr01(s_Str01 As String) As String

' Dim s_Str01 As String

Dim i_Str01Len As String

Dim s_UrlStr01 As String

Dim i_PosiRrlEndSpace01 As Integer

Dim s_Str02 As String

Dim i_PosiUrlStart01 As Integer

Dim i_PosiUrlEnd01 As Integer

Dim i_UrlLen01 As Integer

' Let s_Str01 = "https://amzn.asia/d/fPxKb1s aa"

Let i_Str01Len = Len(s_Str01)

Let i_UrlLen01 = GetURLLen01(s_Str01, " ", "　")

Let i_PosiUrlStart01 = InStr(1, s_Str01, "http", vbBinaryCompare)

' Let i_PosiRrlEndSpace01 = InStr(i_PosiUrlStart01, s_Str01, " ", vbBinaryCompare)

Let i_PosiUrlEnd01 = i_PosiRrlEndSpace01

' Let i_UrlLen01 = i_PosiUrlEnd01 - i_PosiUrlStart01

Let GetURLStr01 = Mid(s_Str01, i_PosiUrlStart01, i_UrlLen01)

End Function

'##########################################################################

'URLの文字列のみを、

'「新たにタブを開いてジャンプするリンクのHTMLタグ」

'に変換する関数。

'##########################################################################

Function URLConv01(s_Str03 As String) As String

Let URLConv01 = "<a href=""" & s_Str03 & """ target=""_blank"">" & s_Str03 & "</a>"

End Function

●テキストファイルをHTMLに変換するプログラム

テキストファイルの内容を、ExcelのA列にコピペしてから実行します。
B列に、HTML内容が出力されます。

'
'

Option Explicit

Sub test()

    Dim o_ItemRng01 As Range
    Dim i_Cnt01 As Integer
    
    
    Let i_Cnt01 = 1
    
    For Each o_ItemRng01 In Worksheets.Item("Sheet1").UsedRange
    
        If 1 <= InStr(1, o_ItemRng01.Value, "http", vbBinaryCompare) Then
            Let Range("B" & i_Cnt01) = UrlPartOnlyConv01(o_ItemRng01.Value, "") & "<BR>"
        Else
            Let Range("B" & i_Cnt01) = o_ItemRng01.Value & "<BR>"
        End If
        
        
        Let i_Cnt01 = i_Cnt01 + 1
        
    Next o_ItemRng01
    

End Sub


'
'

Option Explicit

Sub test()

Dim o_ItemRng01 As Range

Dim i_Cnt01 As Integer

Let i_Cnt01 = 1

For Each o_ItemRng01 In Worksheets.Item("Sheet1").UsedRange

If 1 <= InStr(1, o_ItemRng01.Value, "http", vbBinaryCompare) Then

Let Range("B" & i_Cnt01) = UrlPartOnlyConv01(o_ItemRng01.Value, "") & "<BR>"

Else

Let Range("B" & i_Cnt01) = o_ItemRng01.Value & "<BR>"

End If

Let i_Cnt01 = i_Cnt01 + 1

Next o_ItemRng01

End Sub

'
'


'
'

投稿タグ: Ac2000-Win32API, AccessVBA, Accessの独学, ExcelVBA, Excelの独学, パソコンでの自動化, マクロ, 独学, 自動化

MENU

関連記事

最近の投稿

カテゴリー