sortrecordset.vbs
'文字列配列に含まれたキーワードで重みづけしてソートする例
'VBx VBXXX で利用可能
'文字列配列データをDBレコードの様にt/sqlでソートする例
'IN:s_array 文字列の配列
'OUT: ADODB.Recordset ( https://docs.microsoft.com/ja-jp/sql/ado/reference/ado-api/recordset-object-ado )
Function SortByRecordset(s_array)
Dim s_i, s_rs, s_len
Set s_rs = CreateObject("ADODB.Recordset")
' DATASという列と重みづけ列三つをレコードに定義
' 第2引数はvarcharを表す定数、第3引数はデータ長
Call s_rs.Fields.Append("DATAS", 200, 1024)
Call s_rs.Fields.Append("ALERTWAIT", 200, 2)
Call s_rs.Fields.Append("WARNINGWAIT", 200, 2)
Call s_rs.Fields.Append("ANTWAIT", 200, 2)
Call s_rs.Open()
For s_i = 0 To UBound(s_array)-1
Call s_rs.AddNew() ' データをレコードセットに追加していく
s_rs.Fields("DATAS").Value = s_array(s_i)
'重みの初期化
s_rs.Fields("ALERTWAIT").Value = "0"
s_rs.Fields("WARNINGWAIT").Value = "0"
s_rs.Fields("ANTWAIT").Value = "0"
if instr(s_array(s_i),"おい!") > 0 then
s_rs.Fields("ALERTWAIT").Value = "1"
end if
if instr(s_array(s_i),"まだ?") > 0 then
s_rs.Fields("WARNINGWAIT").Value = "1"
end if
if instr(s_array(s_i),"あんたが!") > 0 then
s_rs.Fields("ANTWAIT").Value = "1"
end if
Next
Call s_rs.Update()
' ソートする
s_rs.Sort = "ALERTWAIT DESC,WARNINGWAIT DESC,ANTWAIT DESC,DATAS"
SortByRecordset = s_rs.GetRows()
Call s_rs.Close()
Set s_rs = Nothing
End Function
・・・上記の利用コード例
Sql = "SELECT twitEntNO,TwitInseq,POOSTS FROM NEORELOAD..TWITTERS where inputdatetime <= '"&CheckDay&" 23:59:59' and ENDFlag<>1 order by inputdatetime"
Dim objRE
dim twittts
dim gtwittts
dim stwittts
dim crsplits
Dim myDic
Set myDic = CreateObject("Scripting.Dictionary") 'これをハッシュテーブルとして使う
Set objRE = new RegExp '正規表現処理OBJECT
objRE.IgnoreCase = True
objRE.pattern = "^.*\#NERO[ | ]([^ |^ ].+).*$"
Set Rds = SqlExecuteSub(connection, Sql) 'SqlExecuteSub は指定のDBコネクションにてSqlを実行しRecordsetオブジェクトを返す
Do Until Rds.EOF '#NERO XXXXXX の部分文字をハッシュキーにしてそのPOSTエントリーNOとINNoを連結させる
twittts= replace(Rds.Fields("POOSTS").value,chr(09),"") 'TABを消して
crsplits =Split(twittts , chr(10)) '改行でスプリットする
gtwittts = ""
stwittts = ""
For each gtwittts in crsplits '改行分文字 #NERO XXXXXX が有るか?有ればハッシュに纏めていく
if objRE.Test(gtwittts) then
stwittts= objRE.Replace(gtwittts,"$1")
if gtwittts<>stwittts then
Exit for
end if
end if
Next
if stwittts<>"" then
if myDic.Exists(stwittts) then
myDic.item(stwittts) = myDic.item(stwittts) & "," & Rds.Fields("twitEntNO").value&":"&Rds.Fields("TwitInseq").value
else
myDic.add stwittts, Rds.Fields("twitEntNO").value&":"&Rds.Fields("TwitInseq").value
end if
end if
Rds.Movenext
Loop
Set objRE = Nothing
Rds.Close
CloseDB(Conn) 'DBコネクションをCLOSE
Dim sortkeyars()
dim ari
ari=1
For Each Var In myDic
redim Preserve sortkeyars(ari)
sortkeyars(ari-1)= Var
ari = ari + 1
Next
Dim sortedkeyars,scpolor,modsn
ari=0
ocolor = "#CCCCFF"
tcolor = "#99CCFF"
cccolor= "#3366CC"
sortedkeyars = SortByRecordset(sortkeyars) '★此処★
for ari=0 to UBound(sortedkeyars,2) 'データ的に2次元配列でRecodeSetがかえるのでそのままアクセスできる
skeys = sortedkeyars(0,ari) '次元1の0にフィールド"DATAS"が、1にフィールド"ALERTWAIT"と言う様に次元1の段がフィールドの次元で、次元2が行の次元でゲット
modsn = ari mod 2
if modsn = 0 then
scpolor = ocolor
else
scpolor = tcolor
end if
・・・出力に出すなど
Next
・・・・コード利用例ここまで