Su | Mo | Tu | We | Th | Fr | Sa |
---|---|---|---|---|---|---|
1 | 2 | 3 | 4 | |||
5 | 6 | 7 | 8 | 9 | 10 | 11 |
12 | 13 | 14 | 15 | 16 | 17 | 18 |
19 | 20 | 21 | 22 | 23 | 24 | 25 |
26 | 27 | 28 | 29 | 30 | 31 |
前から使っていたものですが、
パソコンが新しくなったついでに、URL ドメイン抽出マクロを更新しました。
せっかくなのでここにアップロードしておきます。
Download file
ちょっとした動作なので、大したものではないです。
ここのブログはコメントが少ないので、余計に気を使うというか、
なんというか、よくある自動投稿ロボット対策の画像にぐにゃりと読みにくくした
文字列を表示させて、人間様に入力していただいて、やっとで投稿できるものが
あるんですけど、それをやっちゃうと、こういうどうでもいいサイトには致命傷なわけで
ただでさえ、コメントなんて集まらないのに、そんなもんのをつけたら余計にコメントが
あつまらないっす。
セキュリティをかけるという事により、本来のユーザに面倒をかけるという事自体が、
自動投稿ロボットを使う悪人の思うツボになっている訳でして、そういうものに
屈してはいけないと思うのです。
やれ、ウィルスバスターだのノートンだのマカフィだのにお金を使うのも同じことです。
悪人たちの手によって、われわれの生活スタイルが不便になるのは御免なのです。
わるいことする奴がいるから、普通の人の生活にまで浸食するような規制がかかったり、
余計なコストがかかるのです。税金もそうやって消えて行ってるわけです。
そんなことをするくらいなら、最初から税金をお金のない人に還元して
犯罪をおこそうなんて思わない社会にするべきだと思うのです。
でも、まぁ犯罪はなくならないわけでして、ちょっとした予防はせにゃならん。
それも生活スタイルをかえることなくシンプルにかつ効果的かつ効率よく。
そういう意味では2ちゃんねるは書き込みが楽なので流行っているんだと思います。
誰でも使えて、本音をぶちかまし、ありのままの自分でいられるわけです。
それでいて、モラルを築きあげる努力とか、悪い人も、あとから痛い目に合うシステム。
正しい方向には向かってると思いますね。でも、意見がかみ合うことのない議論の場にも
なりつつあるのも確かです。
またまた前置きが長くなりましたが、
作成したマクロはブログのDBシステムからエクスポートできる
コメントやトラックバック履歴のCSV形式のファイルを
エクセルで開いて
https://www.yo-net.jp/といったURI(Uniform Resource Indicater)から
yo-net.jp ドメイン名を抽出し、
(
'yo-net.jp’,
'yo-net.com'.
'yo-net.info'.
'yo-net.net'.
'yo-net.xxx'
)
のようなPerlやPHPの配列初期化に使える形式に変換するものです。
この配列を投稿時に動作するプログラムの中のチェックプログラムとして使うことができます。
まぁ活用する知識がないとこのマクロは何にもならないわけなので、配布しても
役に立たないっすけど。
おまけに、これまでにやってきた、SPAMerのリストもつけておきまかね。
ともかく
トラックバックスパムやコメントスパムをしてきたサイトやメールアドレスからの書き込みを
排除するためにリスト化します。
メールアドレスも一緒にリスト化する関数もオプションで存在しています。
●メールアドレスとURLを抽出するのがCommentNG_SiteList
●URLだけを抽出するのがTrackBackNG_SiteList
があります。
Call TrackBackNGSite(7, "Comment")
となっている部分の最初の引数がドメインが格納されている列番号を指定しています。
上記の例だと 7列目がドメイン名が格納されている列を示します。
lMailAdrsCol = 6
となっている部分がメールアドレスが格納されている列を示します。
誰でも取得できるトップレベルドメインについては
サブドメインがいくらでも設定できるので、
spam.superspam.com
spam1.superspam.com
spam2.superspam.com
と無限に変化させてスパムを投稿してきますので、
ばっさりと、superspam.comというドメインを一毛打尽にするような処理が
はいっています。
各国のトップレベルドメインと2レベルドメインの組み合わせまでは網羅していないので、
そのあたりは、おいおい改良しないといけないなぁと思ってます。
こういうのは、今はエクセルで区切り位置調整とかを駆使してサブドメイン削除とかやります。
Sub CommentNG_SiteList()
Call TrackBackNGSite(7, "Comment")
End Sub
Sub TrackBackNG_SiteList()
Call TrackBackNGSite(6, "TrackBack")
End Sub
Function TrackBackNGSite(lDomainCol As Long, strMode As String)
Dim strAdrs As String
Dim lAdrsCol As Long
Dim lScanRow As Long
Dim sh As Worksheet
Dim strDomainAdrs As String
Dim strCSVtext As String
Dim lPos As Long
Dim strNGAllList() As String
Dim strNGList() As String
Dim strNGMailAllList() As String
Dim strNGMailList() As String
Dim TopLevelDomain(5) As String '誰でも取得できるトップレベルドメイン一覧
TopLevelDomain(0) = ".com"
TopLevelDomain(1) = ".net"
TopLevelDomain(2) = ".org"
TopLevelDomain(3) = ".info"
TopLevelDomain(4) = ".biz"
TopLevelDomain(5) = ".xxx"
strDateTime = Format(Now, "YYMMDDHHMMSS")
If strMode = "TrackBack" Then
strFileName = "TrackBackNGList" & strDateTime & ".txt"
Else
strFileName = "CommentNGList" & strDateTime & ".txt"
End If
Set sh = ActiveSheet
lAdrsCol = lDomainCol
lMailAdrsCol = 6
lScanRow = 1
strCSVtext = "(" & vbLf
While sh.Cells(lScanRow, 1).Value <> ""
ReDim Preserve strNGAllList(lScanRow - 1)
ReDim Preserve strNGMailAllList(lScanRow - 1)
strDomainAdrs = sh.Cells(lScanRow, lAdrsCol).Value
If strMode = "Comment" Then
strMailAdrs = sh.Cells(lScanRow, 6).Value
End If
'http://の削除と 最初の / 以降の文字列削除
If Len(strDomainAdrs) > 8 Then
If Left(strDomainAdrs, 7) = "http://" Then
strDomainAdrs = Mid(strDomainAdrs, 8)
If InStr(1, strDomainAdrs, "/", vbTextCompare) > 0 Then
lPos = InStr(1, strDomainAdrs, "/", vbTextCompare)
strDomainAdrs = Left(strDomainAdrs, lPos - 1)
End If
End If
End If
'www.の削除処理
If Len(strDomainAdrs) > 4 Then
If Left(strDomainAdrs, 4) = "www." Then
strDomainAdrs = Mid(strDomainAdrs, 5)
End If
End If
'Topレベルドメインのサブドメイン削除処理
For i = 0 To UBound(TopLevelDomain)
If Len(strDomainAdrs) > Len(TopLevelDomain(i)) Then
If Right(strDomainAdrs, Len(TopLevelDomain(i))) = TopLevelDomain(i) Then
If InStrRev(strDomainAdrs, ".", Len(strDomainAdrs) - Len(TopLevelDomain(i)), vbTextCompare) > 0 Then
lPos = InStrRev(strDomainAdrs, ".", Len(strDomainAdrs) - Len(TopLevelDomain(i)), vbTextCompare)
strDomainAdrs = Mid(strDomainAdrs, lPos + 1)
End If
End If
End If
Next
strNGAllList(lScanRow - 1) = strDomainAdrs
If strMode = "Comment" Then
strNGMailAllList(lScanRow - 1) = strMailAdrs
End If
strCSVtext = strCSVtext & "'" & strDomainAdrs & "'"
'最後の行でないなら、区切り,と改行。最後なら)で閉じるだけ。
If sh.Cells(lScanRow + 1, 1).Value <> "" Then
strCSVtext = strCSVtext & "," & vbLf
End If
lScanRow = lScanRow + 1
Wend
'重複部分の削除処理 ドメイン部分
j = -1
For i = 0 To UBound(strNGAllList)
If j = -1 Then
j = 0
ReDim strNGList(0)
strNGList(j) = strNGAllList(i)
Else
strOverlapChk = strNGAllList(i)
bOverlap = False
For j = 0 To UBound(strNGList)
If strOverlapChk = strNGList(j) Then
bOverlap = True
End If
Next
If bOverlap = False Then
ReDim Preserve strNGList(UBound(strNGList) + 1)
strNGList(j) = strOverlapChk
j = j + 1
End If
End If
Next
'重複部分の削除処理 ドメイン部分
If strMode = "Comment" Then
j = -1
For i = 0 To UBound(strNGMailAllList)
If j = -1 Then
j = 0
ReDim strNGMailList(0)
strNGMailList(j) = strNGMailAllList(i)
Else
strOverlapChk = strNGMailAllList(i)
bOverlap = False
For j = 0 To UBound(strNGMailList)
If strOverlapChk = strNGMailList(j) Then
bOverlap = True
End If
Next
If bOverlap = False Then
ReDim Preserve strNGMailList(UBound(strNGMailList) + 1)
strNGMailList(j) = strOverlapChk
j = j + 1
End If
End If
Next
End If
strCSVtext = strCSVtext & vbLf & ")"
lArrSize = UBound(strNGList)
If strMode = "Comment" Then
ReDim Preserve strNGList(UBound(strNGList) + UBound(strNGMailList) + 1)
For j = 0 To UBound(strNGMailList)
strNGList(lArrSize + 1 + j) = strNGMailList(j)
Next
End If
'strNGList配列をPerl配列形式へ書き出す。
strText = "(" & vbLf
For j = 0 To UBound(strNGList)
If j < UBound(strNGList) Then
strText = strText & "'" & strNGList(j) & "'," & vbLf
Else
strText = strText & "'" & strNGList(j) & "'" & vbLf & ")"
End If
Next
Debug.Print strText
strPathName = ActiveWorkbook.Path
strPathFileName = strPathName & "\" & strFileName
Debug.Print strCSVtext
intFF = FreeFile
Open strPathFileName For Output As #intFF
Print #intFF, strText
Close #intFF
End Function