Attribute VB_Name = "basAutoFollow"
Option Explicit

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Const TWITTER_TIMELINE = "http://twitter.com/statuses/user_timeline/"
Private sTwitterId   As String
Private sPassword  As String

Sub Main()

    On Error Resume Next

    Dim objHttp  As New MSXML2.XMLHTTP
    Dim objXML As New MSXML2.DOMDocument
    Dim objIDs  As New MSXML2.DOMDocument
    Dim cXmlRoot    As Collection
    Dim cIds        As Collection
    Dim vLoop       As Variant
    Dim vLoop2      As Variant
    
    Dim vFrendIds       As Variant
    Dim vFollowersIds   As Variant
    Dim fp          As Integer
    Dim vCommand    As Variant
    Dim sWho        As String
    Dim i           As Integer
    Dim cSkipId As New Collection
    Dim sReadBuf    As String
    
    
    
    
    vCommand = GetCommandLine
    If UBound(vCommand) <> 2 Then
        sTwitterId = Trim$(InputBox("Twitterユーザー名を入力してください。", "ユーザ名の入力"))
        If sTwitterId = "" Then End
        
        sPassword = Trim$(InputBox("パスワードを入力してください。", "パスワードの入力"))
        If sPassword = "" Then End
    Else
        sTwitterId = vCommand(1)
        sPassword = vCommand(2)
    
    End If
    
    
    fp = FreeFile
    If Dir(App.Path & "\Skip" & sTwitterId & ".txt") <> "" Then
        Open App.Path & "\Skip" & sTwitterId & ".txt" For Input As #fp
        If Err = 0 Then
            Do While Not EOF(fp)
                Line Input #fp, sReadBuf
                cSkipId.Add sReadBuf
            Loop
            Close #fp
        End If
    End If
    
    objHttp.open "GET", "http://twitter.com/friends/ids/" & sTwitterId & ".xml", False, sTwitterId, sPassword   'フォローしている人の一覧を取得
    objHttp.send
    
    If objHttp.Status = 200 Then
        objXML.async = False
        objXML.loadXML objHttp.responseText
        Set cXmlRoot = ExpandXML(objXML)
        
        objIDs.async = False
        objIDs.loadXML cXmlRoot("ids")(1).xml
        vFrendIds = Split(objIDs.childNodes(0).Text, " ")
    
        objHttp.open "GET", "http://twitter.com/followers/ids/" & sTwitterId & ".xml", False, sTwitterId, sPassword 'フォローされている人の一覧を取得
        objHttp.send
        If objHttp.Status = 200 Then
            objXML.async = False
            objXML.loadXML objHttp.responseText
            Set cXmlRoot = ExpandXML(objXML)
            objIDs.async = False
            objIDs.loadXML cXmlRoot("ids")(1).xml
            vFollowersIds = Split(objIDs.childNodes(0).Text, " ")
        Else
            End
        End If
    Else
        End
    End If
    
    Dim cId As New Collection
    On Error Resume Next
    For Each vLoop In vFollowersIds
        cId.Add Key:="KEY" & (vLoop), Item:=(vLoop)
    Next
    
    For Each vLoop In vFrendIds
        cId.Remove "KEY" & vLoop
    Next
        
    For Each vLoop In cSkipId
        cId.Remove "KEY" & vLoop
    Next
    
    'http://twitter.com/statuses/user_timeline/8671832.rss
    Dim cMessageExpand  As Collection
    Dim sTwitterMessage As String
    
    Set cMessageExpand = New Collection
    MkDir App.Path & "\posts"
    LogPrint String$(100, "="), ""
    LogPrint "ＩＤ総数", cId.Count
    
    
    For Each vLoop In cId
        fp = FreeFile
        objXML.async = False
        objXML.Load App.Path & "\posts\" & vLoop & ".xml"
        If objXML.Text = "" Then
            
            
            objXML.async = False
            objXML.Load TWITTER_TIMELINE & vLoop & ".xml"
            Wait 30
            
            If objXML.Text = "" Or objXML.parseError.reason = "アクセスが拒否されました。" Then
                objHttp.open "GET", TWITTER_TIMELINE & vLoop & ".xml", False, sTwitterId, sPassword
                objHttp.send
                If objHttp.Status = 200 Then
                    objXML.async = False
                    objXML.loadXML objHttp.responseText
                End If
                Wait 15
            End If
            
            If objXML.Text <> "" Then
                objXML.save App.Path & "\posts\" & vLoop & ".xml"
            End If
            
            If objHttp.Status = 400 Then
                LogPrint "API実行回数制限に引っかかりました。しばらくしてから再チャレンジしてください。", "(´･ω･`)"
                Exit For
            End If
            
        End If
        sTwitterMessage = ""
        sWho = ""
        If objXML.Text <> "" Then
            
            For Each vLoop2 In objXML.documentElement.selectNodes("/statuses/status")
                Set cMessageExpand = ExpandXML(vLoop2)
                sTwitterMessage = sTwitterMessage & cMessageExpand("text")(1).Text & vbCrLf
            Next
            
            sWho = objXML.documentElement.selectNodes("/statuses/status/user/screen_name").Item(0).Text & ":" & _
                            "「" & objXML.documentElement.selectNodes("/statuses/status/user/name").Item(0).Text & "」さん"
            
            If Abs(LenB(StrConv(StrConv(StrConv(sTwitterMessage, vbKatakana), vbNarrow), vbFromUnicode)) - LenB(StrConv(sTwitterMessage, vbFromUnicode))) < 20 Then
                LogPrint sWho & "をSkipしました。(日本語が含まれていない) " & vbTab & "http://twitter.com/" & objXML.documentElement.selectNodes("/statuses/status/user/screen_name").Item(0).Text, TWITTER_TIMELINE & vLoop & ".xml"
            Else
                objHttp.open "POST", "http://twitter.com/friendships/create/" & vLoop & ".xml", False, sTwitterId, sPassword
                objHttp.send
                If objHttp.Status = 200 Then
                    LogPrint sWho & "をフォローしました。 " & vbTab & "http://twitter.com/" & objXML.documentElement.selectNodes("/statuses/status/user/screen_name").Item(0).Text, TWITTER_TIMELINE & vLoop & ".xml"
                Else
                    LogPrint sWho & "のフォローに失敗。 (" & objHttp.Status & ")" & vbTab & "http://twitter.com/" & objXML.documentElement.selectNodes("/statuses/status/user/screen_name").Item(0).Text, TWITTER_TIMELINE & vLoop & ".xml"
                    cSkipId.Add (vLoop)
                End If
                Wait 15
            End If
        Else
            sWho = ""
            objXML.async = False
            objXML.Load "http://twitter.com/users/show/" & vLoop & ".xml"
            
            sWho = objXML.documentElement.selectNodes("/user/screen_name").Item(0).Text & ":" & _
                            "「" & objXML.documentElement.selectNodes("/user/name").Item(0).Text & "」さん"
            If objXML.documentElement.selectNodes("/user/protected").Item(0).Text = "true" Then
                LogPrint sWho & "をSkipしました。(Protect)" & vbTab & "http://twitter.com/" & objXML.documentElement.selectNodes("/user/screen_name").Item(0).Text, objHttp.Status & vbTab & objXML.parseError.reason
                cSkipId.Add (vLoop)
            Else
                LogPrint sWho & "をSkipしました。(発言が見つからない。spam？)" & vbTab & "http://twitter.com/" & objXML.documentElement.selectNodes("/user/screen_name").Item(0).Text, "(" & objHttp.Status & ")" & objXML.parseError.reason & vbTab & TWITTER_TIMELINE & vLoop & ".xml"
                cSkipId.Add (vLoop)
            End If
        End If
        
    Next
        
    Open App.Path & "\Skip" & sTwitterId & ".txt" For Output As #fp
    For Each vLoop In cSkipId
        Print #fp, vLoop
    Next
    Close #fp
    
    If UBound(vCommand) <> 2 Then
        Shell "cmd /start " & App.Path & "\FollowLog.txt"
    End If
    
    End
    
End Sub

'childNodes展開
Private Function ExpandXML(ByRef objData As Variant) As Collection
    Dim vLoop   As Variant
    Dim cRet    As New Collection
    For Each vLoop In objData.childNodes
        cRet.Add Key:=vLoop.baseName, Item:=Array(vLoop.baseName, vLoop)
    Next
    Set ExpandXML = cRet
End Function

Private Sub LogPrint(sMsg As String, sTwitterMessage As String)
    Dim fp As Integer
    
    fp = FreeFile
    
    sTwitterMessage = Replace(sTwitterMessage, vbCr, "")
    sTwitterMessage = Replace(sTwitterMessage, vbLf, "")
    Open App.Path & "\FollowLog.txt" For Append As #fp
    Print #fp, Now & " (" & sTwitterId & ")" & sMsg, sTwitterMessage
    Close #fp


End Sub
Function GetCommandLine(Optional MaxArgs)
   ' 変数を宣言します。
   Dim C, CmdLine, CmdLnLen, InArg, i, NumArgs
   ' MaxArgs が提供されるかどうかを調べます。
   If IsMissing(MaxArgs) Then MaxArgs = 10
   ' 現在のサイズの配列にします。
   ReDim ArgArray(MaxArgs)
   NumArgs = 0: InArg = False
   ' コマンド ラインの引数を取得します。
   CmdLine = Command()
   CmdLnLen = Len(CmdLine)
   ' 同時にコマンド ラインの引数を取得します。
   For i = 1 To CmdLnLen
      C = Mid(CmdLine, i, 1)
      ' スペースまたはタブを調べます。
      If (C <> " " And C <> vbTab) Then
         ' スペースまたはタブのいずれでもありません。
         ' 既に引数の中ではないかどうかを調べます。
         If Not InArg Then
         ' 新しい引数が始まります。
         ' 引数が多すぎないかを調べます。
            If NumArgs = MaxArgs Then Exit For
               NumArgs = NumArgs + 1
               InArg = True
            End If
         ' 現在の引数に文字を追加します。
         ArgArray(NumArgs) = ArgArray(NumArgs) & C
      Else
         ' スペースまたはタブを見つけました。
         ' InArg フラグに False を設定します。
         InArg = False
      End If
   Next i
   ' 引数がすべて格納できるように配列のサイズを変更します。
   ReDim Preserve ArgArray(NumArgs)
   ' 関数名に配列を返します。
   GetCommandLine = ArgArray()
End Function

Private Sub Wait(iTime As Integer)
    Dim sNow As String
    sNow = Now
    Do While DateDiff("s", sNow, Now) < iTime
        Sleep 1
        DoEvents
    Loop
    

End Sub