浏览器

开发平台：
Visual Basic

frmMain.frm：源码内容
							VERSION 5.00
Begin VB.Form frmMain 
   Caption         =   "Selecton Html"
   ClientHeight    =   3765
   ClientLeft      =   165
   ClientTop       =   735
   ClientWidth     =   6300
   BeginProperty Font 
      Name            =   "宋体"
      Size            =   9
      Charset         =   134
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   LinkTopic       =   "Form1"
   ScaleHeight     =   3765
   ScaleWidth      =   6300
   StartUpPosition =   3  'Windows Default
   Begin VB.Frame Frame1 
      Caption         =   "格式"
      Height          =   1395
      Left            =   0
      TabIndex        =   1
      Top             =   0
      Width           =   6255
      Begin VB.CheckBox chkLineHeight 
         Caption         =   "行距"
         Height          =   300
         Left            =   2460
         TabIndex        =   11
         Top             =   600
         Width           =   795
      End
      Begin VB.ComboBox cmbLineHeight 
         Height          =   300
         Left            =   3420
         TabIndex        =   10
         Text            =   "Combo1"
         Top             =   600
         Width           =   1215
      End
      Begin VB.ComboBox cmbBkColor 
         Height          =   300
         Left            =   3420
         TabIndex        =   9
         Text            =   "Combo2"
         Top             =   240
         Width           =   1200
      End
      Begin VB.ComboBox cmbFcolor 
         Height          =   300
         Left            =   1080
         TabIndex        =   8
         Text            =   "Combo1"
         Top             =   600
         Width           =   1080
      End
      Begin VB.CheckBox chkClearOFormat 
         Caption         =   "清除原有格式"
         Height          =   300
         Left            =   180
         TabIndex        =   7
         Top             =   1020
         Width           =   1395
      End
      Begin VB.CheckBox chkBkColor 
         Caption         =   "背景色"
         Height          =   300
         Left            =   2460
         TabIndex        =   6
         Top             =   240
         Width           =   900
      End
      Begin VB.CheckBox chkFColor 
         Caption         =   "颜色"
         Height          =   300
         Left            =   180
         TabIndex        =   5
         Top             =   600
         Width           =   720
      End
      Begin VB.CheckBox chkFontSize 
         Caption         =   "大小"
         Height          =   300
         Left            =   180
         TabIndex        =   3
         Top             =   240
         Width           =   720
      End
      Begin VB.CommandButton cmdApply 
         Caption         =   "应用(&A)"
         Height          =   300
         Left            =   3660
         TabIndex        =   4
         Top             =   1020
         Width           =   975
      End
      Begin VB.ComboBox cmbFontsize 
         Height          =   300
         Left            =   1080
         TabIndex        =   2
         Text            =   "12"
         Top             =   240
         Width           =   1080
      End
   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          =   2895
      Left            =   240
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   0
      Text            =   "frmMain.frx":0000
      Top             =   1680
      Width           =   3795
   End
   Begin VB.Menu mnuCopy 
      Caption         =   "复制(&C)"
   End
   Begin VB.Menu mnuReget 
      Caption         =   "获取&HTML"
   End
   Begin VB.Menu mnuApplyHtml 
      Caption         =   "粘贴HTM&L"
   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-8-15 16:58
' Author    : Lingll
' Purpose   :
'---------------------------------------------------------------------------------------
Option Explicit
Private m_Info As LEPluginLib.ILEInfo
'---------------------------------------------------------------------------------------
' Procedure : ChangeFontSize
' DateTime  : 2005-5-18 11:25
' Author    : Lingll
' Purpose   :
'---------------------------------------------------------------------------------------
Private Sub ChangeFontSize()
On Error Resume Next
Dim tWeb As SHDocVw.WebBrowser
Dim tHtml$, tTag$
Dim tRng As Object
Err.Clear
tHtml = GetHtml(m_Info.GetForegroundWebObj, tWeb)
If Len(tHtml) > 0 Then
    tTag = "<span style='"
    If chkFontSize.Value = 1 Then
        tTag = tTag & "font-size:" & cmbFontsize & ";"
    End If
    
    If chkFColor.Value = 1 Then
        tTag = tTag & "color:" & cmbFcolor & ";"
    End If
    
    If chkBkColor.Value = 1 Then
        tTag = tTag & "background-color:" & cmbBkColor & ";"
    End If
    
    If chkLineHeight.Value = 1 Then
        tTag = tTag & "line-height:" & cmbLineHeight & ";"
    End If
    
    tTag = tTag & "'>"
    
    Set tRng = tWeb.Document.Selection.createRange
    If Not tRng Is Nothing Then
        If chkClearOFormat.Value = 1 Then
            tRng.pasteHTML tTag & Replace(tRng.Text, vbNewLine, "<br>") & "</span>"
        Else
            tRng.pasteHTML tTag & tHtml & "</span>"
        End If
    End If
End If
End Sub
Private Sub cmdApply_Click()
ChangeFontSize
End Sub
Private Sub Form_Load()
With cmbFontsize
    .AddItem "9pt"
    .AddItem "10pt"
    .AddItem "12pt"
    .AddItem "16pt"
    .AddItem "20pt"
    
    .Text = "12pt"
End With
With cmbFcolor
    .AddItem "transparent"
    .AddItem "black"
    .AddItem "fuchsia"
    .AddItem "blue"
    .AddItem "aqua"
    .AddItem "lime"
    .AddItem "yellow"
    .AddItem "red"
    
    .AddItem "#000000"
    
    .Text = "black"
End With
With cmbBkColor
    .AddItem "transparent"
    .AddItem "black"
    .AddItem "fuchsia"
    .AddItem "blue"
    .AddItem "aqua"
    .AddItem "lime"
    .AddItem "yellow"
    .AddItem "red"
    
    .AddItem "#000000"
    
    .Text = "transparent"
End With
With cmbLineHeight
    .AddItem "100%"
    .AddItem "150%"
    
    .AddItem "2px"
    .AddItem "4px"
    
    .Text = "150%"
End With
End Sub
Private Sub Form_Resize()
On Error Resume Next
Text1.Move 0, Frame1.Height, Me.ScaleWidth, Me.ScaleHeight - Frame1.Height
End Sub
Public Sub INIme(vTitle$, vHtml$, vInfo As LEPluginLib.ILEInfo)
Me.Caption = vTitle
Text1.Text = vHtml
Set m_Info = vInfo
End Sub
Private Sub mnuApplyHtml_Click()
On Error Resume Next
Dim tWeb As SHDocVw.WebBrowser
Err.Clear
If Len(GetHtml(m_Info.GetForegroundWebObj, tWeb)) > 0 Then
    tWeb.Document.Selection.createRange.pasteHTML Text1.Text
End If
End Sub
Private Sub mnuCopy_Click()
Clipboard.Clear
Clipboard.SetText Text1.Text
End Sub
Private Sub mnuReget_Click()
Dim tStr$
On Error Resume Next
tStr = GetHtml(m_Info.GetForegroundWebObj)
If LenB(tStr) = 0 Then
    tStr = "(error...)"
End If
Text1.Text = tStr
End Sub

						