浏览器

开发平台：
Visual Basic

cDragDropEvent.cls：源码内容
							VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cDragDropEvent"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'拖拽各方向相关处理
Option Explicit
Private m_InsideIndex As Long
Private Const mSubCount As Long = 11
Private mItemText(0 To mSubCount) As String
Private mTag As String
Public SpIndex_SaveAuto As Long
Public SpIndex_Save As Long
Public SpIndex_HightLight As Long
Public SpIndex_ShowMenu As Long
Public SpIndex_Replace As Long
'"替换"中对应的index
Private m_ReplaceItemIndex As Long
Public Enum DragDropType
    ddTypeImage = 1
    ddTypeLink = 0
    ddTypeText = 2
End Enum
Public DragType As DragDropType
Private Sub Class_Initialize()
m_InsideIndex = 0
Call IniText
SpIndex_SaveAuto = 5
SpIndex_Save = 6
SpIndex_HightLight = 9
SpIndex_Replace = 10
SpIndex_ShowMenu = 11
End Sub
Public Property Get InsideIndex() As Long
InsideIndex = m_InsideIndex
End Property
Public Property Let InsideIndex(nIndex As Long)
If nIndex >= 0 And nIndex <= mSubCount Then
    m_InsideIndex = nIndex
Else
    m_InsideIndex = 0
End If
End Property
Public Property Get EventText() As String
If m_InsideIndex = SpIndex_Replace Then
    If m_ReplaceItemIndex > 0 And m_ReplaceItemIndex <= gSearchEgnCount Then
        EventText = mItemText(SpIndex_Replace) & "->" & gSearchEgn(m_ReplaceItemIndex).Title
    Else
        EventText = mItemText(SpIndex_Replace)
    End If
Else
    EventText = mItemText(m_InsideIndex)
End If
'If m_InsideIndex = SpIndex_Replace Then
'    If m_ReplaceItemIndex > 0 And m_ReplaceItemIndex <= SearchurlCount Then
'        EventText = mItemText(SpIndex_Replace) & "->" & searchUrl(m_ReplaceItemIndex).Title
'    Else
'        EventText = mItemText(SpIndex_Replace)
'    End If
'Else
'    EventText = mItemText(m_InsideIndex)
'End If
End Property
Public Property Get SubCount() As Long
SubCount = mSubCount
End Property
Public Function GetEventText(ByVal index As Long)
If index < 0 Or index > mSubCount Then index = 0
GetEventText = mItemText(index)
End Function
Public Sub Execute()
Call Execute2(m_InsideIndex)
End Sub
Public Sub Execute2(index As Long)
Select Case index
    Case 1
        If CanNewWebByPageRule(gSelfDrag.SrcStr) Then
            Call gMainForm.NewWebbrowser(gSelfDrag.SrcStr)
        End If
    Case 2
        If CanNewWebByPageRule(gSelfDrag.SrcStr) Then
            Call gMainForm.NewWebbrowser(gSelfDrag.SrcStr, , True, True)
        End If
    Case 3
        Call webbState(gSelfDrag.DragFormIndex).webForm.Navigate(gSelfDrag.SrcStr, False)
    Case 4
        Call gMainForm.NewIE(gSelfDrag.SrcStr)
    Case 5
        Call AutoSave
    Case 6
        Call SaveAs
    Case 7
        frmCollectBoard.Show , gMainForm
        frmCollectBoard.AddTab gSelfDrag.SrcStr
    Case 8
        frmCollectBoard.Show , gMainForm
        frmCollectBoard.AddTab gSelfDrag.SrcHtmlText
    Case 9
        Call webbState(gSelfDrag.DragFormIndex).webForm.HightLight(gSelfDrag.SrcStr)
    Case 10
        Call ReplaceAddress(m_ReplaceItemIndex, gSelfDrag.SrcStr)
    Case 11
        Call PopMenuInWeb
End Select
If index >= 0 And index <= mSubCount Then
    gMainForm.ChangeStatusText ("拖拽: " & mItemText(index))
End If
End Sub
'实施"页面规则"中的"运行外部程序",如果运行了则返回False
Private Function CanNewWebByPageRule(ByVal nUrl As String) As Boolean
Dim i&, j&
nUrl = LCase(nUrl)
If gEnablePageRule = 1 Then
    For i = 1 To PageRuleCnt
        With PageRule(i)
            If .Enabled = 1 And .Type = 1 Then
                For j = 0 To .UrlCnt - 1
                    If MatchUrl(.Urls(j), nUrl) Then
                        ShellExecute 0&, "open", .OutExePath, _
                            Replace(.OutExeParam, "%url%", nUrl), .OutExePath, SW_SHOW
                        CanNewWebByPageRule = False
                        Exit Function
                    End If
                Next j
            End If
        End With
    Next i
End If
CanNewWebByPageRule = True
End Function
'自动保存
Private Sub AutoSave()
Select Case DragType
    Case ddTypeImage
        If gSelfDrag.SrcFilePath <> "" Then
            Call SaveDragImage(gSelfDrag.SrcFilePath)
        End If
    Case ddTypeText
        Call SaveDragText(gSelfDrag.SrcStr)
End Select
End Sub
Private Sub SaveDragText(nTxt As String)
On Error GoTo due
'Dim nfs As New nFileSysObj
Dim tPath As String
Dim tFN As Long
Dim destF As String
If nTxt = "" Then Exit Sub
'If Not nfs.nFolderExists(DragDropSaveTextFolder) Then
If Not FileExist(DragDropSaveTextFolder, False) Then
    Call BrowseForFolder(tPath, "请选择自动保存路径", gMainForm.hWnd)
End If
If tPath <> "" Then DragDropSaveTextFolder = tPath
'If nfs.nFolderExists(DragDropSaveTextFolder) Then
If FileExist(DragDropSaveTextFolder, False) Then
    destF = CreateTextName()
    tFN = FreeFile
    Open destF For Binary As tFN
        Put tFN, , nTxt
    Close tFN
Else
    MsgBox "选择的路径" & Chr(13) & DragDropSaveTextFolder & Chr(13) & _
            "有问题,本次操作取消", vbOKOnly + vbInformation
End If
Exit Sub
due:
    MsgBox Err.Description, vbOKOnly
End Sub
'产生Text自动保存的文件名
Private Function CreateTextName() As String
Dim rtn As String
Dim tFN$
Dim i&
If Right$(DragDropSaveTextFolder, 1) <> "" Then
    DragDropSaveTextFolder = DragDropSaveTextFolder & ""
End If
tFN = Format(Date, "yyyymmdd") & "_" & Format(time, "hhmmss")
rtn = DragDropSaveTextFolder & tFN & ".txt"
If FileExist(rtn) Then
    While FileExist(rtn)
        i = i + 1
        rtn = DragDropSaveTextFolder & tFN & "[" & Trim(Str(i)) & "]" & ".txt"
    Wend
End If
CreateTextName = rtn
End Function
Private Sub SaveDragImage(nfile As String)
'Dim nfs As New nFileSysObj
Dim tPath As String
Dim tFN As String
Dim ggPos As Integer
Dim destF As String
'If Not nfs.nFolderExists(DragDropSaveImageFolder) Then
If Not FileExist(DragDropSaveImageFolder, False) Then
    Call BrowseForFolder(tPath, "请选择自动保存路径", gMainForm.hWnd)
End If
If tPath <> "" Then DragDropSaveImageFolder = tPath
'If nfs.nFolderExists(DragDropSaveImageFolder) Then
If FileExist(DragDropSaveImageFolder, False) Then
    'If nfs.nFileExists(nfile) Then
    If FileExist(nfile) Then
        ggPos = InStrRev(nfile, "")
        tFN = Mid(nfile, ggPos + 1)
        destF = DragDropSaveImageFolder & "" & tFN
        'While nfs.nFileExists(destF)
        While FileExist(destF)
            tFN = "1_" & tFN
            destF = DragDropSaveImageFolder & "" & tFN
        Wend
        Call FileCopy(nfile, destF)
    Else
        MsgBox "源文件" & Chr(13) & nfile & Chr(13) & _
            "不存在,本次操作取消", vbOKOnly + vbInformation
    End If
Else
    MsgBox "选择的路径" & Chr(13) & DragDropSaveImageFolder & Chr(13) & _
            "有问题,本次操作取消", vbOKOnly + vbInformation
End If
End Sub
'手动保存
Private Sub SaveAs()
Select Case DragType
    Case ddTypeImage
        If gSelfDrag.SrcFilePath <> "" Then
            Call SaveAsDragImage(gSelfDrag.SrcFilePath)
        End If
    Case ddTypeText
        Call SaveAsDragText(gSelfDrag.SrcStr)
End Select
End Sub
Private Sub SaveAsDragImage(nPath As String)
On Error GoTo due
Dim tSave As OpenSaveDlg
Dim tPos&, tFN$
Set tSave = New OpenSaveDlg
tPos = InStrRev(nPath, "")
If tPos > 0 Then
    tFN = Mid(nPath, tPos + 1)
End If
tSave.flags = OFN_OVERWRITEPROMPT
tSave.FileName = tFN
tSave.Filter = "所有文件(*.*)|*.*"
If tSave.ShowSave(gMainForm.hWnd) Then
    Call FileCopy(nPath, tSave.FileName)
End If
Exit Sub
due:
    MsgBox Err.Description, vbOKOnly
End Sub
Private Sub SaveAsDragText(nTxt As String)
On Error GoTo due
Dim tSave As OpenSaveDlg
Dim tPos&, tFileName$
Dim tFN&
tPos = InStr(1, nTxt, vbNewLine)
If tPos > 20 Or tPos < 1 Then tPos = 21
tFileName = Left(nTxt, tPos - 1) & ".txt"
FormatFileName tFileName
Debug.Print "SaveAsDragText:"; tFileName
Set tSave = New OpenSaveDlg
tSave.flags = OFN_OVERWRITEPROMPT
tSave.FileName = tFileName
tSave.Filter = "所有文件(*.*)|*.*"
If tSave.ShowSave(gMainForm.hWnd) Then
    If FileExist(tSave.FileName) Then
        Kill tSave.FileName
    End If
    
    tFN = FreeFile
    Open tSave.FileName For Binary As tFN
        Put tFN, , nTxt
    Close tFN
End If
Exit Sub
due:
    MsgBox Err.Description, vbOKOnly
End Sub
Private Sub FormatFileName(nFN$)
nFN = Replace(nFN, "", " ")
nFN = Replace(nFN, "/", " ")
nFN = Replace(nFN, "?", " ")
nFN = Replace(nFN, "*", " ")
nFN = Replace(nFN, "|", " ")
nFN = Replace(nFN, ":", " ")
nFN = Replace(nFN, """", " ")
nFN = Replace(nFN, "<", " ")
nFN = Replace(nFN, ">", " ")
End Sub
Private Sub IniText()
mItemText(0) = "(无)"
mItemText(1) = "新窗口(激活)"
mItemText(2) = "新窗口(后台)"
mItemText(3) = "本页打开"
mItemText(4) = "用IE打开"
mItemText(5) = "保存(自动)"
mItemText(6) = "保存"
mItemText(7) = "编辑(文本)"
mItemText(8) = "编辑(html)"
mItemText(9) = "高亮"
mItemText(10) = "搜索"
mItemText(11) = "显示菜单"
End Sub
Public Property Get Tag() As String
Tag = mTag
End Property
Public Property Let Tag(ByVal vNewValue As String)
mTag = vNewValue
End Property
Public Function PopMenu(hwndParent As Long, Optional nFull As Boolean = True) As Long
'mPopMenu.Popup hwndParent
Dim i&
gDragDropMenu2.ClearItems
For i = 1 To gSearchEgnCount
    If gSearchEgn(i).Title = "-" Then
        gDragDropMenu2.Add "", pmsSeparator
    Else
        gDragDropMenu2.Add gSearchEgn(i).Title, , 200 + i
    End If
Next i
If gSearchEgnCount <= 0 Then
    gDragDropMenu2.Add "(空)", pmsDisabled Or pmsString
End If
gDragDropMenu.UnCheckAll
'gDragDropMenu2.ClearItems
'For i = 1 To SearchurlCount
'    gDragDropMenu2.Add searchUrl(i).Title, , 200 + i
'Next i
'If SearchurlCount <= 0 Then
'    gDragDropMenu2.Add "(空)", pmsDisabled Or pmsString
'End If
'gDragDropMenu.UnCheckAll
If nFull Then
    If m_InsideIndex = SpIndex_ShowMenu Then
        gDragDropMenu.CheckItem SpIndex_ShowMenu + 1, True, False
    Else
        gDragDropMenu.CheckItem m_InsideIndex, True, False
        If m_InsideIndex = SpIndex_Replace Then
            gDragDropMenu2.CheckRadioItem m_ReplaceItemIndex - 1, False
        End If
    End If
End If
Select Case DragType
    Case ddTypeText
        gDragDropMenu.EnableItem SpIndex_SaveAuto, True, False
        gDragDropMenu.EnableItem SpIndex_Save, True, False
        gDragDropMenu.EnableItem SpIndex_HightLight, True, False
        gDragDropMenu.EnableItem SpIndex_Replace, True, False
    Case ddTypeLink
        gDragDropMenu.EnableItem SpIndex_SaveAuto, False, False
        gDragDropMenu.EnableItem SpIndex_Save, False, False
        gDragDropMenu.EnableItem SpIndex_HightLight, False, False
        gDragDropMenu.EnableItem SpIndex_Replace, False, False
    Case ddTypeImage
        gDragDropMenu.EnableItem SpIndex_SaveAuto, True, False
        gDragDropMenu.EnableItem SpIndex_Save, True, False
        gDragDropMenu.EnableItem SpIndex_HightLight, False, False
        gDragDropMenu.EnableItem SpIndex_Replace, False, False
End Select
gDragDropMenu.EnableItem 0, nFull, False
gDragDropMenu.EnableItem SpIndex_ShowMenu + 1, nFull, False
PopMenu = gDragDropMenu.Popup2(hwndParent)
End Function
Public Sub PopMenuInSetup(hwndParent As Long)
Dim tId&
tId = PopMenu(hwndParent)
If tId >= 100 And tId < 200 Then
    m_InsideIndex = tId - 100
ElseIf tId >= 200 And tId < 300 Then
    m_InsideIndex = SpIndex_Replace
    m_ReplaceItemIndex = tId - 200
ElseIf tId = 300 Then
    m_InsideIndex = SpIndex_ShowMenu
End If
End Sub
Private Sub PopMenuInWeb()
Dim tId&
tId = PopMenu(gMainForm.hWnd, False)
If tId >= 100 And tId < 200 Then
    Call Execute2(tId - 100)
ElseIf tId >= 200 And tId < 300 Then
    Call ReplaceAddress(tId - 200, gSelfDrag.SrcStr)
End If
End Sub
'替换地址栏,转换为预设的地址(自动完成地址,例如搜索,域名)
Private Sub ReplaceAddress(nIndex&, SrcStr$)
Dim tUrl$
If nIndex > 0 And nIndex <= gSearchEgnCount Then
    tUrl = Replace$(gSearchEgn(nIndex).Url, SearchUrlKeywordFlag, SrcStr)
    gMainForm.NewWebbrowser tUrl
End If
'Dim tUrl$
'If nIndex > 0 And nIndex <= SearchurlCount Then
'    tUrl = Replace$(searchUrl(nIndex).Url, SearchUrlKeywordFlag, SrcStr)
'    gMainForm.NewWebbrowser tUrl
'End If
End Sub
Public Property Get ReplaceItemIndex() As Long
ReplaceItemIndex = m_ReplaceItemIndex
End Property
Public Property Let ReplaceItemIndex(ByVal vNewValue As Long)
'If vNewValue > 0 And vNewValue <= SearchurlCount Then
If vNewValue > 0 And vNewValue <= gSearchEgnCount Then
    m_ReplaceItemIndex = vNewValue
Else
    m_InsideIndex = 0
End If
End Property

						