浏览器

开发平台：
Visual Basic

frmCollectBoard.frm：源码内容
							VERSION 5.00
Begin VB.Form frmCollectBoard 
   Caption         =   "简易收集板"
   ClientHeight    =   3165
   ClientLeft      =   165
   ClientTop       =   735
   ClientWidth     =   4860
   BeginProperty Font 
      Name            =   "宋体"
      Size            =   9
      Charset         =   134
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmCollectBoard.frx":0000
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   MinButton       =   0   'False
   NegotiateMenus  =   0   'False
   ScaleHeight     =   211
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   324
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  'Windows Default
   Begin VB.TextBox Text2 
      BeginProperty Font 
         Name            =   "Fixedsys"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   1695
      HideSelection   =   0   'False
      Left            =   1800
      MultiLine       =   -1  'True
      OLEDragMode     =   1  'Automatic
      OLEDropMode     =   1  'Manual
      ScrollBars      =   2  'Vertical
      TabIndex        =   1
      Top             =   420
      Visible         =   0   'False
      Width           =   1335
   End
   Begin VB.TextBox Text1 
      BeginProperty Font 
         Name            =   "Fixedsys"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   1575
      HideSelection   =   0   'False
      Left            =   420
      MultiLine       =   -1  'True
      OLEDragMode     =   1  'Automatic
      OLEDropMode     =   1  'Manual
      ScrollBars      =   3  'Both
      TabIndex        =   0
      Top             =   240
      Width           =   1935
   End
   Begin VB.PictureBox pctFont 
      Height          =   2085
      Left            =   1020
      ScaleHeight     =   2025
      ScaleWidth      =   2985
      TabIndex        =   2
      Top             =   240
      Visible         =   0   'False
      Width           =   3045
      Begin VB.Frame Frame1 
         Caption         =   "字体设置"
         Height          =   1815
         Left            =   120
         TabIndex        =   3
         Top             =   120
         Width           =   2775
         Begin VB.CommandButton cmdFontCancel 
            Caption         =   "取消"
            Height          =   375
            Left            =   1920
            TabIndex        =   10
            Top             =   1320
            Width           =   735
         End
         Begin VB.CommandButton cmdFontOk 
            Caption         =   "确定"
            Height          =   375
            Left            =   1080
            TabIndex        =   9
            Top             =   1320
            Width           =   735
         End
         Begin VB.ComboBox cmbFontName 
            Height          =   300
            Left            =   600
            Sorted          =   -1  'True
            TabIndex        =   6
            Text            =   "Combo1"
            Top             =   360
            Width           =   1935
         End
         Begin VB.ComboBox cmbFontSize 
            Height          =   300
            Left            =   600
            TabIndex        =   5
            Text            =   "Combo2"
            Top             =   840
            Width           =   1095
         End
         Begin VB.CheckBox chkBold 
            Caption         =   "粗体"
            Height          =   255
            Left            =   1920
            TabIndex        =   4
            Top             =   840
            Width           =   735
         End
         Begin VB.Label Label1 
            Caption         =   "字体"
            Height          =   255
            Left            =   120
            TabIndex        =   8
            Top             =   360
            Width           =   375
         End
         Begin VB.Label Label2 
            Caption         =   "大小"
            Height          =   255
            Left            =   120
            TabIndex        =   7
            Top             =   840
            Width           =   375
         End
      End
   End
   Begin VB.Menu mnuALPHA 
      Caption         =   "不透明度"
      Begin VB.Menu mnuALPHA_ss 
         Caption         =   ""
         Index           =   0
      End
   End
   Begin VB.Menu mnuFile 
      Caption         =   "文件(&F)"
      Begin VB.Menu mnuFile_New 
         Caption         =   "新建标签(&N)"
      End
      Begin VB.Menu mnuFile_Open 
         Caption         =   "打开(&O)..."
      End
      Begin VB.Menu mnuFile_Save 
         Caption         =   "另存为(&S)..."
      End
      Begin VB.Menu mnuFile_CloseTab 
         Caption         =   "关闭标签(&C)"
      End
      Begin VB.Menu mnuFile_none 
         Caption         =   "-"
      End
      Begin VB.Menu mnuFile_Close 
         Caption         =   "关闭(&X)"
      End
   End
   Begin VB.Menu mnuFormat 
      Caption         =   "格式(&O)"
      Begin VB.Menu mnuFormat_Font 
         Caption         =   "字体(&F)..."
      End
      Begin VB.Menu mnuFormat_AutoLine 
         Caption         =   "自动换行(&W)"
      End
   End
   Begin VB.Menu mnuRunScript 
      Caption         =   "脚本(&S)"
      Begin VB.Menu mnuRunScript_Vb 
         Caption         =   "VBScript(&B)"
      End
      Begin VB.Menu mnuRunScript_Java 
         Caption         =   "JavaScript(&J)"
         Checked         =   -1  'True
      End
      Begin VB.Menu mnuRunScript_none 
         Caption         =   "-"
      End
      Begin VB.Menu mnuRunScript_Run 
         Caption         =   "执行脚本(&R)"
         Shortcut        =   ^{F5}
      End
   End
End
Attribute VB_Name = "frmCollectBoard"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'Private Type TBBUTTONINFOA
'    cbSize As Long
'    dwMask As Long
'    idCommand As Long
'    iImage As Long
'    fsState As Byte
'    fsStyle As Byte
'    cx As Integer
'    lParam As Long
'    pszText As String
'    cchText As Long
'End Type
'
'Private Const TBIF_STYLE As Long = &H8
'Private Const BTNS_AUTOSIZE As Long = &H10
'Private Const TB_SETBUTTONINFOA As Long = (WM_USER + 66)
'Private Const TB_SETIMAGELIST As Long = (WM_USER + 48)
'Private Const TB_AUTOSIZE As Long = (WM_USER + 33)
'Private Const TB_SETPADDING As Long = (WM_USER + 87)
'Private Sub Form_Load()
'Dim hSysMenu As Long
'Dim menuCount As Long
'hSysMenu = GetSystemMenu(Me.hwnd, False)
'menuCount = GetMenuItemCount(hSysMenu)
'Call RemoveMenu(hSysMenu, menuCount - 1, MF_BYPOSITION Or MF_REMOVE)
'End Sub
Private WithEvents mMainTxt As TextBox
Attribute mMainTxt.VB_VarHelpID = -1
Private mFontName As String
Private mFontSize As Single
Private mFontBold As Long
Private mText() As String   '1 base
Private mTextCount As Long
Private mSelIndex As Long
'0:VbScript,<>0:JavaScript
Private mScriptLanguage As Long
Private WithEvents m_cTabMain As cTabControl32
Attribute m_cTabMain.VB_VarHelpID = -1
Private Sub cmdFontCancel_Click()
ShowFontOption False
End Sub
Private Sub cmdFontOk_Click()
On Error Resume Next
ShowFontOption False
mFontSize = Val(cmbFontSize.Text)
mFontName = cmbFontName.Text
mFontBold = chkBold.Value
With Text1
    .FontName = mFontName
    .FontSize = mFontSize
    .FontBold = (mFontBold = 1)
End With
With Text2
    .FontName = mFontName
    .FontSize = mFontSize
    .FontBold = (mFontBold = 1)
End With
End Sub
Private Sub Form_Initialize()
mFontSize = 12
mFontName = "Fixedsys"
mFontBold = 0
mScriptLanguage = 1
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyA And Shift = vbCtrlMask Then
    mMainTxt.SelStart = 0
    mMainTxt.SelLength = Len(mMainTxt.Text)
End If
End Sub
Private Sub Form_Load()
mnuALPHA.Enabled = IsWin2k
Me.Move GetSystemMetrics(SM_CXSCREEN) / 2 * 15, _
        GetSystemMetrics(SM_CYSCREEN) / 2 * 15
Dim i&
For i = 1 To 10
Load mnuALPHA_ss(i)
mnuALPHA_ss(i).Caption = LTrim(Str((11 - i) * 10)) & "%"
mnuALPHA_ss(i).Visible = True
Next i
mnuALPHA_ss(1).Checked = True
mnuALPHA_ss(0).Visible = False
Set mMainTxt = Text1
mTextCount = 0
ReDim mText(0 To mTextCount)
Call IniTabCtrl
'TabStrip1.Tabs.Clear
Call AddTab("")
Call Form_Resize
End Sub
Private Sub Form_Resize()
On Error Resume Next
'If Me.WindowState = 1 Then
'    Me.Visible = False
'  Else
   
'End If
Dim tRc As RECT
If Not m_cTabMain Is Nothing Then
    m_cTabMain.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight
    m_cTabMain.GetAdjustRect tRc.Left, tRc.Top, tRc.Right, tRc.Bottom
    mMainTxt.Move tRc.Left, tRc.Top, tRc.Right - tRc.Left, tRc.Bottom - tRc.Top
End If
'With TabStrip1
'    .Move 0, 0, Me.ScaleWidth, Me.ScaleHeight
'    mMainTxt.Move .clientLeft, .clientTop, .clientWidth, .clientHeight
'End With
End Sub
Private Sub Form_Unload(Cancel As Integer)
If Not isExit Then
    Cancel = 1
    Me.Hide
Else
    Set m_cTabMain = Nothing
End If
End Sub
Private Sub m_cTabMain_Changed(vPos As Long)
mSelIndex = vPos + 1
mMainTxt.Text = mText(mSelIndex)
End Sub
Private Sub mMainTxt_Change()
mText(mSelIndex) = mMainTxt.Text
End Sub
Private Sub mnuALPHA_ss_Click(index As Integer)
Dim i&, tAl&
For i = 1 To 10
mnuALPHA_ss(i).Checked = False
Next i
mnuALPHA_ss(index).Checked = True
tAl = CLng((11 - index) * 25.5)
SetWindowLong Me.hWnd, GWL_EXSTYLE, GetWindowLong(Me.hWnd, GWL_EXSTYLE) Or WS_EX_LAYERED
SetLayeredWindowAttributes Me.hWnd, 0, tAl, LWA_ALPHA
End Sub
Private Sub mMainTxt_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
If Data.GetFormat(vbCFText) Then
    mMainTxt.SelText = Data.GetData(vbCFText)
'ElseIf Data.GetData(vbCFLink) Then
'    Text1.SelText = Data.GetData(vbCFLink)
End If
End Sub
Private Sub mMainTxt_OLEStartDrag(Data As DataObject, AllowedEffects As Long)
Data.SetData mMainTxt.SelText, vbCFText
AllowedEffects = vbDropEffectCopy
End Sub
Private Sub mnuFile_Close_Click()
Me.Hide
End Sub
Private Sub mnuFile_CloseTab_Click()
Call RemoveTab(mSelIndex)
End Sub
Private Sub mnuFile_New_Click()
Call AddTab
End Sub
Private Sub mnuFile_Open_Click()
On Error GoTo due
Dim tOpen As OpenSaveDlg
Dim tFN&
Set tOpen = New OpenSaveDlg
With tOpen
    .Filter = "*.txt|*.txt|*.*|*.*"
    .flags = OFN_FILEMUSTEXIST
    If .ShowOpen(Me.hWnd) Then
        tFN = FreeFile
        Open .FileName For Binary As tFN
            mMainTxt.Text = StrConv(InputB(LOF(tFN), tFN), vbUnicode)
        Close tFN
    End If
End With
Exit Sub
due:
    MsgBox Err.Description, vbOKOnly Or vbCritical, "Error"
    Reset
End Sub
Private Sub mnuFile_Save_Click()
On Error GoTo due
Dim tSave As OpenSaveDlg
Dim tFN&
Dim tstr$
Set tSave = New OpenSaveDlg
With tSave
    .Filter = "*.txt|*.txt|*.*|*.*"
    .flags = OFN_OVERWRITEPROMPT
    If .ShowSave(Me.hWnd) Then
        tFN = FreeFile
        Open .FileName For Binary As tFN
            tstr = mMainTxt.Text
            Put tFN, , tstr
        Close tFN
    End If
End With
Exit Sub
due:
    MsgBox Err.Description, vbOKOnly Or vbCritical, "Error"
    Reset
End Sub
Private Sub mnuFormat_AutoLine_Click()
mnuFormat_AutoLine.Checked = Not mnuFormat_AutoLine.Checked
If mnuFormat_AutoLine.Checked Then
'    Set Text2.Font = mMainTxt.Font
    Set mMainTxt = Text2
    Text1.Visible = False
    Text2.Text = Text1.Text
Else
'    Set Text1.Font = mMainTxt.Font
    Set mMainTxt = Text1
    Text2.Visible = False
    Text1.Text = Text2.Text
End If
Call Form_Resize
mMainTxt.Visible = True
End Sub
Private Sub mnuFormat_Font_Click()
ShowFontOption True
End Sub
Private Sub ShowFontOption(nShow As Boolean)
Dim i&
Static tLoadFont&
If nShow Then
    If tLoadFont <> 2 Then
        Me.MousePointer = vbArrowHourglass
        cmbFontName.Clear
        For i = 1 To Screen.FontCount
            If Screen.Fonts(i) <> "" Then
                cmbFontName.AddItem Screen.Fonts(i)
            End If
        Next i
        
        For i = 8 To 12
            cmbFontSize.AddItem i
        Next i
        For i = 14 To 24 Step 2
            cmbFontSize.AddItem i
        Next i
        
        Me.MousePointer = vbDefault
        tLoadFont = 2
    End If
    
    
        
    cmbFontName.Text = mFontName
    cmbFontSize.Text = mFontSize
    chkBold.Value = mFontBold
End If
pctFont.Visible = nShow
pctFont.ZOrder
mnuFormat.Enabled = Not nShow
mMainTxt.Enabled = Not nShow
'TabStrip1.Enabled = Not nShow
If Not m_cTabMain Is Nothing Then
    m_cTabMain.Enabled = Not nShow
End If
Me.Refresh
End Sub
'添加标签
Public Sub AddTab(Optional ByVal nStr$ = "")
If mTextCount > 0 Then
    If mMainTxt.Text = "" Then
        mText(mSelIndex) = nStr
    Else
        mTextCount = mTextCount + 1
        ReDim Preserve mText(0 To mTextCount)
        mText(mTextCount) = nStr
        mSelIndex = mTextCount
        'TabStrip1.Tabs.Add , , "标签"
        m_cTabMain.AddItem mTextCount - 1, "标签"
    End If
Else
    mTextCount = mTextCount + 1
    ReDim Preserve mText(0 To mTextCount)
    mSelIndex = mTextCount
    mText(mTextCount) = nStr
    'TabStrip1.Tabs.Add , , "标签"
    m_cTabMain.AddItem mTextCount - 1, "标签"
End If
mMainTxt.Text = mText(mSelIndex)
'Set TabStrip1.SelectedItem = TabStrip1.Tabs(mSelIndex)
m_cTabMain.SelectIndex = mSelIndex - 1
m_cTabMain_Changed mSelIndex - 1
'If mTextCount > 0 Then
'    If mMainTxt.Text = "" Then
'        mText(mSelIndex) = nStr
'    Else
'        mTextCount = mTextCount + 1
'        ReDim Preserve mText(0 To mTextCount)
'        mText(mTextCount) = nStr
'        mSelIndex = mTextCount
'        TabStrip1.Tabs.Add , , "标签"
'    End If
'Else
'    mTextCount = mTextCount + 1
'    ReDim Preserve mText(0 To mTextCount)
'    mSelIndex = mTextCount
'    mText(mTextCount) = nStr
'    TabStrip1.Tabs.Add , , "标签"
'End If
'mMainTxt.Text = mText(mSelIndex)
'Set TabStrip1.SelectedItem = TabStrip1.Tabs(mSelIndex)
End Sub
Public Sub RemoveTab(nIndex&)
Dim i&
If mTextCount > 1 Then
    For i = nIndex To mTextCount - 1
        mText(i) = mText(i + 1)
    Next i
    mTextCount = mTextCount - 1
    If mSelIndex > mTextCount Then mSelIndex = mTextCount
    m_cTabMain.DelItem nIndex - 1
    m_cTabMain.SelectIndex = mSelIndex - 1
    m_cTabMain_Changed mSelIndex - 1
'    TabStrip1.Tabs.Remove nIndex
'    Set TabStrip1.SelectedItem = TabStrip1.Tabs(mSelIndex)
End If
End Sub
Private Sub mnuRunScript_Java_Click()
mnuRunScript_Java.Checked = True
mnuRunScript_Vb.Checked = False
mScriptLanguage = 1
End Sub
Private Sub mnuRunScript_Run_Click()
Dim tLanguage$
If loadedBrowserCount > 0 Then
    If mScriptLanguage = 0 Then
        tLanguage = "vbscript"
    Else
        tLanguage = "javascript"
    End If
    
    If mMainTxt.SelText <> "" Then
        webbState(gActiveWebIndex).webForm.RunScript mMainTxt.SelText, tLanguage
    Else
        webbState(gActiveWebIndex).webForm.RunScript mMainTxt.Text, tLanguage
    End If
End If
End Sub
Private Sub mnuRunScript_Vb_Click()
mnuRunScript_Java.Checked = False
mnuRunScript_Vb.Checked = True
mScriptLanguage = 0
End Sub
'Private Sub TabStrip1_Click()
'Debug.Print "click"
'mSelIndex = TabStrip1.SelectedItem.index
'mMainTxt.Text = mText(mSelIndex)
'End Sub
'---------------------------------------------------------------------------------------
' Procedure : IniTabCtrl
' DateTime  : 2005-3-30 13:15
' Author    : Lingll
' Purpose   :
'---------------------------------------------------------------------------------------
Private Sub IniTabCtrl()
Set m_cTabMain = CreateCmmCtrl(strCLSID_cTabControl32)   'New cTabControl32
With m_cTabMain
    .Create Me.hWnd, TCS_BOTTOM, 0, 0, 100, 100
    .SetFont
End With
End Sub

						