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) '次元１の０にフィールド"DATAS"が、１にフィールド"ALERTWAIT"と言う様に次元１の段がフィールドの次元で、次元２が行の次元でゲット

      modsn = ari mod 2

      if modsn = 0 then

        scpolor = ocolor

      else

        scpolor = tcolor

      end if

・・・出力に出すなど

  Next

・・・・コード利用例ここまで