frmmain.frm

baidu_IM源程序,解压后就可以看到。自己还没有试过,不过貌似很不错的

         Height          =   1695
         Left            =   -74880
         TabIndex        =   1
         Top             =   1320
         Width           =   2895
         Begin VB.CommandButton cmdLogin 
            Caption         =   "登 录"
            Height          =   375
            Left            =   1560
            TabIndex        =   6
            Top             =   1200
            Width           =   1215
         End
         Begin VB.TextBox UserKey 
            BeginProperty Font 
               Name            =   "宋体"
               Size            =   10.5
               Charset         =   134
               Weight          =   400
               Underline       =   0   'False
               Italic          =   0   'False
               Strikethrough   =   0   'False
            EndProperty
            Height          =   375
            IMEMode         =   3  'DISABLE
            Left            =   720
            PasswordChar    =   "*"
            TabIndex        =   5
            Top             =   720
            Width           =   2055
         End
         Begin VB.TextBox UserName 
            BeginProperty Font 
               Name            =   "宋体"
               Size            =   10.5
               Charset         =   134
               Weight          =   400
               Underline       =   0   'False
               Italic          =   0   'False
               Strikethrough   =   0   'False
            EndProperty
            Height          =   375
            Left            =   720
            TabIndex        =   3
            Top             =   240
            Width           =   2055
         End
         Begin VB.Label Label2 
            Caption         =   "密码："
            Height          =   255
            Left            =   120
            TabIndex        =   4
            Top             =   720
            Width           =   855
         End
         Begin VB.Label Label1 
            Caption         =   "用户名："
            Height          =   255
            Left            =   120
            TabIndex        =   2
            Top             =   360
            Width           =   975
         End
      End
      Begin VB.Label LableLogin 
         Caption         =   "Hello.BaiDu!"
         Height          =   975
         Left            =   -74880
         TabIndex        =   13
         Top             =   240
         Width           =   2895
      End
      Begin VB.Label LabelChat 
         Caption         =   "你加入的群列表："
         Height          =   255
         Left            =   -74880
         TabIndex        =   30
         Top             =   240
         Width           =   2895
      End
      Begin VB.Label Label6 
         Caption         =   "群服务器地址："
         Height          =   255
         Left            =   -74880
         TabIndex        =   28
         Top             =   5520
         Width           =   1695
      End
      Begin VB.Label Labelbad 
         Caption         =   "你的黑名单列表："
         Height          =   255
         Left            =   -74880
         TabIndex        =   22
         Top             =   240
         Width           =   2895
      End
      Begin VB.Label Labelfri 
         Caption         =   "你的好友列表："
         Height          =   255
         Left            =   -74880
         TabIndex        =   21
         Top             =   240
         Width           =   2895
      End
      Begin VB.Label Labelmsg 
         Caption         =   "你的信息列表："
         Height          =   255
         Left            =   -74880
         TabIndex        =   19
         Top             =   240
         Width           =   2895
      End
   End
   Begin InetCtlsObjects.Inet Inethttp 
      Index           =   0
      Left            =   4080
      Top             =   840
      _ExtentX        =   1005
      _ExtentY        =   1005
      _Version        =   393216
   End
   Begin VB.Label Label12 
      Caption         =   "Label12"
      Height          =   255
      Left            =   4080
      TabIndex        =   32
      Top             =   480
      Width           =   1095
   End
   Begin VB.Label Label13 
      Caption         =   "Label13"
      Height          =   255
      Left            =   4080
      TabIndex        =   31
      Top             =   120
      Width           =   975
   End
   Begin VB.Menu menuFri 
      Caption         =   "menuFri"
      Begin VB.Menu menuFriFresh 
         Caption         =   "刷新"
      End
      Begin VB.Menu menuFriAdd 
         Caption         =   "查找"
      End
      Begin VB.Menu menuFriMsg 
         Caption         =   "留言"
      End
      Begin VB.Menu menuFriDel 
         Caption         =   "删除"
      End
      Begin VB.Menu menuFriInfo 
         Caption         =   "查看资料"
      End
      Begin VB.Menu menuFriBad 
         Caption         =   "列入黑名单"
      End
   End
   Begin VB.Menu menuMsg 
      Caption         =   "menuMsg"
      Begin VB.Menu menuMsgRefresh 
         Caption         =   "刷新"
      End
      Begin VB.Menu menuMsgTalk 
         Caption         =   "内容"
      End
      Begin VB.Menu menuMsgDel 
         Caption         =   "删除"
      End
      Begin VB.Menu menuMsgInfo 
         Caption         =   "查看资料"
      End
      Begin VB.Menu menuMsgAdd 
         Caption         =   "加入好友"
      End
      Begin VB.Menu menuMsgBad 
         Caption         =   "列入黑名单"
      End
   End
   Begin VB.Menu menuBad 
      Caption         =   "menuBad"
      Begin VB.Menu menuBadRefresh 
         Caption         =   "刷新"
      End
      Begin VB.Menu menuBadInfo 
         Caption         =   "查看资料"
      End
      Begin VB.Menu menuBadtoFri 
         Caption         =   "列入好友"
      End
      Begin VB.Menu menuBadDel 
         Caption         =   "删除"
      End
   End
   Begin VB.Menu menuChat 
      Caption         =   "menuChat"
      Begin VB.Menu menuChatLogin 
         Caption         =   "登记"
      End
      Begin VB.Menu menuChatEnter 
         Caption         =   "进入"
      End
      Begin VB.Menu menuChatLogout 
         Caption         =   "退出"
      End
      Begin VB.Menu menuChatInfo 
         Caption         =   "查看资料"
      End
   End
   Begin VB.Menu menuPOP 
      Caption         =   "menuPOP"
      Begin VB.Menu menuPOPhelp 
         Caption         =   "帮助"
      End
      Begin VB.Menu menuPOPshow 
         Caption         =   "显示"
      End
      Begin VB.Menu menuPOPexit 
         Caption         =   "退出"
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long
Private Declare Function sndPlaySoundFromMemory Lib "winmm.dll" Alias "sndPlaySoundA" (lpszSoundName As Any, ByVal uFlags As Long) As Long

Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long

Private Const SND_ASYNC = &H1&
Private Const SND_MEMORY = &H4&

Dim Fgroup() As New frmGroup
Dim Ftalk() As New frmTalk
Dim MyPostStar As Boolean
Dim NextPagePost As String
Dim LoginERR As Boolean

Dim DOdebug As Boolean 'debug

Dim ret As Long 'hotkey

Public Sub MyPost(strUrl As String, txtpost As String, strCookie As String, DoCmd As String)
On Error GoTo errinet
If DoCmd = "login" Then GoTo PostStar
If MyPostStar = False Then Exit Sub
PostStar:
Dim strHost As String '主机
Dim intPost As Integer
Dim strHead As String
If Len(strCookie) = 0 Then strCookie = ""
If DoCmd = "login" Then
strCookie = ""
Else
strCookie = "Cookie: " & tmpCookie
End If
If LCase(Left(strUrl, 7)) <> "http://" Then strUrl = "http://" & strUrl
intPost = InStr(8, strUrl, "/")
If intPost > 0 Then
    strHost = Mid(strUrl, 8, intPost - 8)
Else
    strHost = Mid(strUrl, 8, Len(strUrl) - 8)
End If
strHead = "POST " & strUrl & " HTTP/1.0" & vbCrLf
strHead = strHead & "Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/vnd.ms-powerpoint, application/vnd.ms-excel, application/msword, application/x-shockwave-flash, */*" & vbCrLf
strHead = strHead & "Referer: http://www.baidu.com/" & vbCrLf
strHead = strHead & "Accept -Language: zh -cn" & vbCrLf
strHead = strHead & "Content-Type: application/x-www-form-urlencoded" & vbCrLf
strHead = strHead & "Proxy -Connection: Keep -Alive" & vbCrLf
strHead = strHead & "User-Agent: Molla/4.0 (compatible; MSIE 5.5; Windows 98; Maxthon; .NET CLR 1.1.4322)" & vbCrLf
strHead = strHead & "Host: " & strHost & vbCrLf
strHead = strHead & "Content-Length: " & Len(txtpost) & vbCrLf
strHead = strHead & "Pragma: no -cache" & vbCrLf
strHead = strHead & strCookie & vbCrLf & vbCrLf
Dim i As Long
If DoCmd = "login" Then
If LoginERR = True Then Exit Sub
i = 0
InetListUrl(i) = strUrl
InetListPost(i) = txtpost
InetListHead(i) = strHead
InetListCmd(i) = DoCmd
If Inethttp(i).StillExecuting = False Then Inethttp(i).Execute strUrl, "post", txtpost, strHead
Exit Sub
End If
StarSub:

ReDim Preserve InetListTxt(Inethttp.Count) As String
ReDim Preserve InetListUrl(Inethttp.Count) As String
ReDim Preserve InetListPost(Inethttp.Count) As String
ReDim Preserve InetListHead(Inethttp.Count) As String
ReDim Preserve InetListCmd(Inethttp.Count) As String
    If NextInet > Inethttp.Count Then NextInet = 1
    For i = NextInet To Inethttp.Count - 1
        If Inethttp(i).StillExecuting = False Then
       ' InetPostNO = InetPostNO + 1
       Label12.Caption = i
            Inethttp(i).Execute strUrl, "post", txtpost, strHead
            InetListUrl(i) = strUrl
            InetListPost(i) = txtpost
            InetListHead(i) = strHead
            InetListCmd(i) = DoCmd
            
            NextInet = i + 1
            DoEvents
            Exit Sub
        End If
    Next
    For i = 1 To NextInet - 1
        If Inethttp(i).StillExecuting = False Then
       ' InetPostNO = InetPostNO + 1
       Label12.Caption = i
            Inethttp(i).Execute strUrl, "post", txtpost, strHead
            InetListUrl(i) = strUrl
            InetListPost(i) = txtpost
            InetListHead(i) = strCookie
            InetListCmd(i) = DoCmd
          
            NextInet = i + 1
            DoEvents
            Exit Sub
        End If
    Next
Load Inethttp(Inethttp.UBound + 1)

GoTo StarSub

errinet:

If DoCmd <> "login" Then Call cmdlogin_Click
If DoCmd = "TMPGET" Then
MsgBox "错误:" & vbCrLf & strUrl & "?" & txtpost & vbCrLf & "请检查网络或重试.", , "Hello,Baidu.Debug:"
Else
'MsgBox "错误:请检查网络或重试.", , "Hello,Baidu."
If DoCmd = "login" Then cmdLogin.Enabled = True
End If
End Sub

Public Sub readmsglist(tmpMsgList As String, tmpRid As Long) '读出信息列表
If InStr(tmpMsgList, "+gp+") = 0 And InStr(tmpMsgList, "百度个人中心_网友留言") = 0 Then Exit Sub
Dim xi As Long
Dim tmpform As String

Dim tmptxt As String
Dim ti As Long
Dim tmpti As Long
Dim tmptii As Long
Dim tmptiii As Long
Dim tmpTime As String
Dim tmpuser As String
Dim tmpId As Long
Dim tmpVar As Variant
ReDim MsgList0(0)
ReDim MsgList1(0)
ti = 5000
tmptxt = "+gp+" '信息总数
tmptxt = Mid(tmpMsgList, InStr(tmpMsgList, tmptxt) - 4, 3)
'MsgBox tmptxt & "信息"
If tmptxt = "0" Then Exit Sub
tmptii = Val(Replace(tmptxt, """", ""))
ReDim Vmsglist(tmptii) As String
For tmpti = 1 To tmptii
If InStr(tmpMsgList, "var resultno=2;") Then
    tmptxt = ";showMSG" '消息号
    ti = InStr(ti, tmpMsgList, tmptxt)
    tmptiii = InStr(ti, tmpMsgList, ")")
    tmptxt = Mid(tmpMsgList, ti + 9, tmptiii - ti - 11)
    tmptiii = InStr(tmptxt, ",")
    tmptxt = Right(tmptxt, Len(tmptxt) - tmptiii)
    tmptxt = Replace(tmptxt, ",", "")
    tmptxt = Replace(tmptxt, " ", "")
    tmpId = tmptxt
     ' MsgBox Tmptxt & Len(Tmptxt)
    tmpuser = "系统管理员"
    Vmsglist(tmpti) = Vmsglist(tmpti) & tmptxt & ",系统管理员,"
    tmptxt = ";showMSG" '信息日期
    ti = InStr(ti, tmpMsgList, tmptxt)
    ti = InStr(ti, tmpMsgList, "</td>")
    ti = InStr(ti + 5, tmpMsgList, "</td>")
    tmptxt = Mid(tmpMsgList, ti - 16, 16)
    tmptxt = Replace(tmptxt, """", "")
    tmpTime = tmptxt
    Vmsglist(tmpti) = tmptxt & "," & Vmsglist(tmpti)
    'MsgBox Vmsglist(Tmpti)
Else
    tmptxt = ";showMSG" '信息日期
    ti = InStr(ti, tmpMsgList, tmptxt)
    ti = InStr(ti, tmpMsgList, "</td>")
    ti = InStr(ti + 5, tmpMsgList, "</td>")
    tmptxt = Mid(tmpMsgList, ti - 16, 16)
    tmptxt = Replace(tmptxt, """", "")
    Vmsglist(tmpti) = Vmsglist(tmpti) & tmptxt & ","
    tmpTime = tmptxt
    tmptxt = "dis_rt('" '消息号,发信人
    ti = InStr(ti, tmpMsgList, tmptxt)