浏览器

开发平台：
Visual Basic

main.frm：源码内容
							VERSION 5.00
Begin VB.Form frmMain 
   BorderStyle     =   0  'None
   Caption         =   "Form1"
   ClientHeight    =   5460
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   2880
   BeginProperty Font 
      Name            =   "新宋体"
      Size            =   9
      Charset         =   134
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   LinkTopic       =   "Form1"
   ScaleHeight     =   364
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   192
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  'Windows Default
   Begin VB.PictureBox pctSlide 
      BorderStyle     =   0  'None
      HasDC           =   0   'False
      Height          =   135
      Left            =   180
      ScaleHeight     =   9
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   81
      TabIndex        =   0
      Top             =   2760
      Width           =   1215
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'---------------------------------------------------------------------------------------
' Module    : frmMain
' DateTime  : 2005-6-13 11:49
' Author    : Lingll
' Purpose   :
'---------------------------------------------------------------------------------------
Option Explicit
Private Declare Function LoadMenuIndirect Lib "user32.dll" Alias "LoadMenuIndirectA" (ByVal lpMenuTemplate As Long) As Long
Private Declare Function DestroyMenu Lib "user32.dll" (ByVal hMenu As Long) As Long
Private Declare Function GetSubMenu Lib "user32.dll" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function RemoveMenu Lib "user32.dll" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Const MF_BYPOSITION As Long = &H400&
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Const WM_USER As Long = &H400
Private Const TTM_SETTITLEW As Long = (WM_USER + 33)
Private Const TTM_SETTITLEA As Long = (WM_USER + 32)
Private WithEvents m_cRss As cRss
Attribute m_cRss.VB_VarHelpID = -1
Private m_StartLoad As Boolean
Private WithEvents m_cLvwLinks As LCmnCtrl32.cSysListView32
Attribute m_cLvwLinks.VB_VarHelpID = -1
Private WithEvents m_cLvwRssz As LCmnCtrl32.cSysListView32
Attribute m_cLvwRssz.VB_VarHelpID = -1
Private WithEvents m_cTbrMain As LCmnCtrl32.cToolBar
Attribute m_cTbrMain.VB_VarHelpID = -1
Private m_cPmnRssz As cPopMenu
Private m_cPmnOption As cPopMenu
Private Const m_TbrID_Rss As Long = 101
Private Const m_TbrID_Option As Long = 102
Private m_RssGroupIndex&
Private WithEvents m_cMove As cMoveControl
Attribute m_cMove.VB_VarHelpID = -1
Private Sub Form_Initialize()
m_StartLoad = False
End Sub
Private Sub Form_Load()
Dim i&
Set m_cRss = New cRss
Call LoadRssGroupInfo
Call IniLvw
Call IniTbr
Call IniPopMnu
Set m_cMove = New cMoveControl
m_cMove.IniMe pctSlide, False, True, 7
pctSlide.ZOrder
End Sub
'---------------------------------------------------------------------------------------
' Procedure : StartLoadRss
' DateTime  : 2005-5-30 18:40
' Author    : Lingll
' Purpose   :
'---------------------------------------------------------------------------------------
Private Sub StartLoadRss(vUrl$)
m_StartLoad = True
With m_cLvwLinks
    .ClearItem
    .AddItem "Loading..."
    .SetColumnWidth 0, -1
    .Enabled = False
End With
m_cRss.Url = vUrl
m_cRss.ReLoad
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Set m_cLvwLinks = Nothing
End Sub
Private Sub Form_Resize()
On Error Resume Next
Static tRc As RECT
Static tVal&
If Not m_cTbrMain Is Nothing Then
    tVal = m_cTbrMain.GetToolbarHeight
    m_cTbrMain.MoveToolbar 0, 0, Me.ScaleWidth, tVal, False, False
End If
If Not m_cLvwRssz Is Nothing Then
    GetWindowRect m_cLvwRssz.hwnd, tRc
    m_cLvwRssz.Move 0, tVal, Me.ScaleWidth, tRc.Bottom - tRc.Top ' Me.ScaleHeight / 3 - m_cTbrMain.GetToolbarHeight
End If
tVal = tVal + tRc.Bottom - tRc.Top + 10
pctSlide.Move 0, tVal - 10, Me.ScaleWidth
If Not m_cLvwLinks Is Nothing Then
    
    
    m_cLvwLinks.Move 0, tVal, Me.ScaleWidth, Me.ScaleHeight - tVal
    'm_cLvwLinks.Move 0, Me.ScaleHeight / 3, Me.ScaleWidth, Me.ScaleHeight / 3 * 2
End If
End Sub
Private Sub m_cLvwLinks_Click(iItem As Long, iSubItem As Long, X As Long, Y As Long)
'On Error Resume Next
'Dim tIndex1&, tIndex2&, tIndex3&
'tIndex1 = cmbGroups.ListIndex + 1
'If tIndex1 > 0 And tIndex1 <= RssGCnt Then
'    tIndex2 = m_cLvwRssz.GetNextItem(-1, LVNI_SELECTED) + 1
'    If tIndex2 > 0 And tIndex2 <= RssGroups(tIndex1).Count Then
'        If iItem >= 0 Then
'            gLEInfo.NewWebWindow m_cRss.GetBmUrl(iItem + 1)
'        End If
'    End If
'End If
Call ClickLinks(iItem)
End Sub
Private Sub m_cLvwLinks_KeyDownd(keycode As Long)
If keycode = vbKeyReturn Then
    Call ClickLinks(m_cLvwLinks.GetNextItem(-1, LVNI_SELECTED))
End If
End Sub
'---------------------------------------------------------------------------------------
' Procedure : ClickLinks
' DateTime  : 2005-6-1 11:35
' Author    : Lingll
' Purpose   : open rss link
'---------------------------------------------------------------------------------------
Private Sub ClickLinks(iItem&)
Dim tWeb As SHDocVw.WebBrowser
If iItem >= 0 Then
    Set tWeb = gLEInfo.GetForegroundWebObj
    If Not tWeb Is Nothing Then
        tWeb.Navigate m_cRss.GetBmUrl(iItem + 1)
    Else
        gLEInfo.NewWebWindow m_cRss.GetBmUrl(iItem + 1)
    End If
End If
End Sub
Private Sub m_cLvwLinks_SetTip(iItem As Long, vTip As String)
If iItem >= 0 Then
    SendMessage m_cLvwLinks.GetToolTipHwnd, TTM_SETTITLEA, 0, ByVal Mid2(m_cRss.GetBmTitle(iItem + 1), 1, 90, "...")
    vTip = m_cRss.GetBmPubdate(iItem + 1) & vbNewLine & _
            m_cRss.GetBmDescription(iItem + 1)
End If
End Sub
Private Sub m_cLvwRssz_Click(iItem As Long, iSubItem As Long, X As Long, Y As Long)
'Call LoadRssLinks(iItem + 1)
End Sub
'---------------------------------------------------------------------------------------
' Procedure : LoadRssLinks
' DateTime  : 2005-6-1 15:58
' Author    : Lingll
' Purpose   : 加载rss links
'---------------------------------------------------------------------------------------
Private Sub LoadRssLinks(index&)
Dim tIndex1&
tIndex1 = m_RssGroupIndex
If tIndex1 > 0 And tIndex1 <= RssGCnt Then
    If index > 0 And index <= RssGroups(tIndex1).Count Then
        Call StartLoadRss(RssGroups(tIndex1).Rssz(index).Link)
    End If
End If
End Sub
Private Sub m_cLvwRssz_ItemChange(vIndex As Long, uNewState As LCmnCtrl32.clveLVIS, uOldState As LCmnCtrl32.clveLVIS)
If (uNewState And LVIS_SELECTED) = LVIS_SELECTED Then
    'If (uOldState And  ) = 0 Then
        Call LoadRssLinks(vIndex + 1)
    'End If
End If
End Sub
Private Sub m_cLvwRssz_KeyDownd(keycode As Long)
'If keycode = vbKeyReturn Then
'    Call LoadRssLinks(m_cLvwRssz.GetNextItem(-1, LVNI_SELECTED) + 1)
'End If
End Sub
Private Sub m_cMove_MoveEnd(offsetX As Long, offsetY As Long)
Dim tRc As RECT
Dim tpt As POINTAPI
GetWindowRect m_cLvwRssz.hwnd, tRc
m_cLvwRssz.Move 0, 0, Me.ScaleWidth, tRc.Bottom - tRc.Top + offsetY
Call Form_Resize
'tPt.x = tRc.Left: tPt.y = tRc.Top
'ScreenToClient m_cLvwRssz.hwnd
End Sub
Private Sub m_cRss_Changed()
Dim tcnt&
Dim i&
If m_StartLoad Then
    tcnt = m_cRss.GetBmCount
    m_cLvwLinks.ClearItem
    For i = 1 To tcnt
        m_cLvwLinks.AddItem LTrim(Str(i)) & ". " & m_cRss.GetBmTitle(i), , 0
    Next i
    m_cLvwLinks.SetColumnWidth 0, -1
    m_cLvwLinks.Enabled = True
    
    m_StartLoad = False
End If
End Sub
'---------------------------------------------------------------------------------------
' Procedure : LoadRssGroupInfo
' DateTime  : 2005-5-30 21:59
' Author    : Lingll
' Purpose   :
'---------------------------------------------------------------------------------------
Private Sub LoadRssGroupInfo(Optional vPath$)
Dim tIni As cINIFile
Dim i&, j&
If LenB(vPath) = 0 Then
    vPath = App.Path
    If Right(vPath, 1) <> "" Then
        vPath = vPath & ""
    End If
    vPath = vPath & "RssGps.ini"
End If
Set tIni = New cINIFile
tIni.bffSize = 1024
tIni.IniFile = vPath
RssGCnt = tIni.ReadInt("Info", "Count")
If RssGCnt > 0 Then
    ReDim RssGroups(0 To RssGCnt)
    For i = 1 To RssGCnt
        RssGroups(i).Title = tIni.ReadKey("Group_" & LTrim(Str(i)), "GTitle")
        RssGroups(i).Count = tIni.ReadInt("Group_" & LTrim(Str(i)), "Count")
        If RssGroups(i).Count > 0 Then
            ReDim RssGroups(i).Rssz(0 To RssGroups(i).Count)
            For j = 1 To RssGroups(i).Count
                RssGroups(i).Rssz(j).Title = tIni.ReadKey("Group_" & Trim(Str(i)), "Title_" & LTrim(Str(j)))
                RssGroups(i).Rssz(j).Link = tIni.ReadKey("Group_" & Trim(Str(i)), "Url_" & LTrim(Str(j)))
            Next j
        Else
            RssGroups(i).Count = 0
        End If
    Next i
Else
    RssGCnt = 0
    ReDim RssGroups(0 To 0)
End If
End Sub
Private Sub IniLvw()
On Error Resume Next
Set m_cLvwLinks = gLEInfo.CreateLCmnCtrl(cmCtrl_ListView)
With m_cLvwLinks
    .Create Me.hwnd, LVS_REPORT Or LVS_NOCOLUMNHEADER Or LVS_SHOWSELALWAYS Or LVS_SINGLESEL, LVS_EX_INFOTIP, 0, 0, Me.ScaleWidth, 200
    .SetImgList LVSIL_SMALL, 0, 16, 16, LoadResPicture(101, vbResBitmap).Handle, &HFF00FF
    .AddColumn 0, "name", 100
End With
Set m_cLvwRssz = gLEInfo.CreateLCmnCtrl(cmCtrl_ListView)
With m_cLvwRssz
    .Create Me.hwnd, LVS_REPORT Or LVS_NOCOLUMNHEADER Or LVS_SHOWSELALWAYS Or LVS_SINGLESEL, 0, 0, 0, Me.ScaleWidth, 100
    .SetImgList LVSIL_SMALL, 0, 16, 16, LoadResPicture(101, vbResBitmap).Handle, &HFF00FF
    .AddColumn 0, "name", 100
End With
End Sub
Private Sub IniTbr()
Set m_cTbrMain = gLEInfo.CreateLCmnCtrl(cmCtrl_ToolBar)
With m_cTbrMain
    .CreateToolbar Me.hwnd, True, True, 16, 16, TBSTYLE_Default, TBSTYLE_EX_Default
    .AddImages LoadResPicture(101, vbResBitmap).Handle, &HFF00FF
    .AddButton m_TbrID_Option, "设置", , BTNS_AUTOSIZE Or BTNS_BUTTON Or BTNS_WHOLEDROPDOWN
    .AddButton m_TbrID_Rss, "RSS", 2, BTNS_AUTOSIZE Or BTNS_BUTTON Or BTNS_WHOLEDROPDOWN
    .SetMaxSize
    .MoveToolbar 0, 0, Me.ScaleWidth, .GetToolbarHeight, False, False
End With
Call OpenGroup(1)
End Sub
Private Sub IniPopMnu()
Call IniRssPMenu
Call IniOptionPMenu
End Sub
'---------------------------------------------------------------------------------------
' Procedure : IniRssPMenu
' DateTime  : 2005-6-13 21:39
' Author    : Lingll
' Purpose   :
'---------------------------------------------------------------------------------------
Public Sub IniRssPMenu()
Dim i&
Set m_cPmnRssz = New cPopMenu
m_cPmnRssz.Create
m_cPmnRssz.Parent = Me.hwnd
m_cPmnRssz.ClearItems
If RssGCnt > 0 Then
    For i = 1 To RssGCnt
        m_cPmnRssz.Add RssGroups(i).Title, , i
    Next i
Else
    m_cPmnRssz.Add "", pmsSeparator
End If
End Sub
'---------------------------------------------------------------------------------------
' Procedure : IniOptionPMenu
' DateTime  : 2005-6-13 21:40
' Author    : Lingll
' Purpose   :
'---------------------------------------------------------------------------------------
Private Sub IniOptionPMenu()
Dim tArr() As Byte
Dim tHMnu&
Set m_cPmnOption = New cPopMenu
With m_cPmnOption
    tArr = LoadResData(100, 4)
    tHMnu = LoadMenuIndirect(VarPtr(tArr(0)))
    .Create GetSubMenu(tHMnu, 0)
    .Parent = Me.hwnd
End With
RemoveMenu tHMnu, 0, MF_BYPOSITION
DestroyMenu tHMnu
End Sub
Private Sub m_cTbrMain_DropDown(id As Long, bLeft As Long, bTop As Long, bRight As Long, bBottom As Long)
Dim tId&, i&
Select Case id
    Case m_TbrID_Rss
        tId = m_cPmnRssz.Popup(False, bLeft, bBottom)
        Call OpenGroup(tId)
    Case m_TbrID_Option
        tId = m_cPmnOption.Popup(False, bLeft, bBottom)
        Select Case tId
            Case 1
                Load frmAddRss
                frmAddRss.RssGroupIndex = m_RssGroupIndex
                frmAddRss.Show vbModal
                If Not frmAddRss.IsCancel Then
                    Call AddRss(frmAddRss.RssGroupIndex, frmAddRss.RssTitle, frmAddRss.RssUrl)
                    Call SaveGroup(frmAddRss.RssGroupIndex)
                    If frmAddRss.RssGroupIndex = m_RssGroupIndex Then
                        Call OpenGroup(m_RssGroupIndex)
                    End If
                End If
                Unload frmAddRss
                Call IniRssPMenu
            Case 2
                frmAddMulRss.Show vbModal
                If Not frmAddMulRss.IsCancel Then
                    Call IniRssPMenu
                End If
                Unload frmAddMulRss
        End Select
End Select
End Sub
'---------------------------------------------------------------------------------------
' Procedure : OpenGroup
' DateTime  : 2005-6-13 12:04
' Author    : Lingll
' Purpose   :
'---------------------------------------------------------------------------------------
Private Sub OpenGroup(index&)
Dim i&
If index > 0 And index <= RssGCnt Then
    m_cLvwLinks.ClearItem
    m_cLvwRssz.ClearItem
    For i = 1 To RssGroups(index).Count
        m_cLvwRssz.AddItem RssGroups(index).Rssz(i).Title, , 1
        
    Next i
    m_cLvwRssz.SetColumnWidth 0, -1
    m_RssGroupIndex = index
    
    m_cTbrMain.SetButtonCaption m_TbrID_Rss, RssGroups(index).Title
End If
End Sub
'---------------------------------------------------------------------------------------
' Procedure : AddRss
' DateTime  : 2005-6-13 12:30
' Author    : Lingll
' Purpose   :
'---------------------------------------------------------------------------------------
Private Sub AddRss(GroupIndex&, vTitle$, vUrl$)
If GroupIndex > 0 And GroupIndex <= RssGCnt Then
    With RssGroups(GroupIndex)
        .Count = .Count + 1
        ReDim Preserve .Rssz(0 To .Count)
        .Rssz(.Count).Title = vTitle
        .Rssz(.Count).Link = vUrl
    End With
End If
End Sub

						