网址收集器.frm

个人VB学习源码精选,自己学习时的一些编程小程序,希望对大家有帮助

VERSION 5.00
Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX"
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   3810
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   5340
   LinkTopic       =   "Form1"
   ScaleHeight     =   3810
   ScaleWidth      =   5340
   StartUpPosition =   3  '窗口缺省
   Begin VB.CheckBox Check1 
      Caption         =   "总在最上"
      Height          =   195
      Left            =   4185
      TabIndex        =   6
      ToolTipText     =   "设置窗口在屏幕最上层"
      Top             =   3285
      Width           =   1095
   End
   Begin VB.CommandButton Command2 
      Caption         =   "保存"
      Height          =   285
      Left            =   4275
      TabIndex        =   5
      Top             =   2430
      Width           =   780
   End
   Begin VB.CommandButton Command1 
      Caption         =   "添加"
      Height          =   285
      Left            =   4275
      TabIndex        =   4
      Top             =   1935
      Width           =   780
   End
   Begin VB.PictureBox Picture1 
      Height          =   510
      Left            =   4365
      Picture         =   "网址收集器.frx":0000
      ScaleHeight     =   450
      ScaleWidth      =   495
      TabIndex        =   2
      Top             =   270
      Width           =   555
   End
   Begin VB.TextBox Text1 
      Height          =   285
      Left            =   855
      TabIndex        =   1
      Top             =   3285
      Width           =   3075
   End
   Begin RichTextLib.RichTextBox RichTextBox1 
      Height          =   3075
      Left            =   135
      TabIndex        =   0
      Top             =   45
      Width           =   3795
      _ExtentX        =   6694
      _ExtentY        =   5424
      _Version        =   393217
      BackColor       =   16777215
      Enabled         =   -1  'True
      ScrollBars      =   3
      TextRTF         =   $"网址收集器.frx":030A
   End
   Begin VB.Label Label2 
      Caption         =   "网址为："
      Height          =   240
      Left            =   135
      TabIndex        =   7
      Top             =   3330
      Width           =   735
   End
   Begin VB.Label Label1 
      Caption         =   "请拖动图标到浏览器地址栏上"
      Height          =   600
      Left            =   4230
      TabIndex        =   3
      Top             =   990
      Width           =   960
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Const WM_GETTEXT = &HD
Private Const WM_GETTEXTLENGTH = &HE
Private Type POINTAPI
        X As Long
        Y As Long
End Type
Dim AppPath As String
Dim IsDragging As Boolean
Private Sub SetOnTop(ByVal IsOnTop As Long)
    Dim Rtn As Long
    If IsOnTop = 1 Then
        Rtn = SetWindowPos(Form1.hwnd, -1, 0, 0, 0, 0, 3) '窗口设为最高层
    Else
        Rtn = SetWindowPos(Form1.hwnd, -2, 0, 0, 0, 0, 3) '所有最高层窗口后
    End If
End Sub

Private Sub Check1_Click()
    SetOnTop (Check1.Value)
End Sub

Private Sub Command1_Click()
    RichTextBox1.Text = RichTextBox1.Text & Text1.Text & vbCrLf
End Sub

Private Sub Command2_Click()
    RichTextBox1.SaveFile AppPath & "WebAddress.txt", rtfText
End Sub


Private Sub Form_Load()
    If App.PrevInstance Then Unload Me
    Check1.Value = 1
    IsDragging = False
    AppPath = IIf(Len(App.Path) > 3, App.Path & "\", App.Path)
    If Dir(AppPath & "WebAddress.txt") <> "" Then
        RichTextBox1.LoadFile AppPath & "WebAddress.txt"
    End If
    Form1.ScaleMode = 3
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If IsDragging Then
        Dim Rtn As Long, CurWnd As Long
        Dim TempStr As String
        Dim strLong As Long
        Dim Point As POINTAPI
        Point.X = X
        Point.Y = Y
        '客户坐标转换为屏幕坐标
        If ClientToScreen(Form1.hwnd, Point) = 0 Then
            Exit Sub
        End If
        '获取鼠标所在窗口的句柄
        CurWnd = WindowFromPoint(Point.X, Point.Y)
        TempStr = Space(255)
        strLong = Len(TempStr)
        '获取该窗口的类名
        Rtn = GetClassName(CurWnd, TempStr, strLong)
        If Rtn = 0 Then Exit Sub    '返回的窗口类名非法时退出
        '获取窗口文本的长度
        strLong = SendMessage(CurWnd, WM_GETTEXTLENGTH, 0, 0)
        If strLong > 0 Then
            TempStr = Space(255)
            '获取窗口的文本
            Rtn = SendMessage(CurWnd, WM_GETTEXT, strLong + 1, ByVal TempStr)
            TempStr = Trim(TempStr)
            Text1.Text = TempStr
        End If
    End If
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If IsDragging Then
        Screen.MousePointer = vbDefault
        IsDragging = False
        ReleaseCapture  '释放 Form1的鼠示捕获
    End If
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Not IsDragging Then
        IsDragging = True
        Screen.MouseIcon = Picture1.Picture
        Screen.MousePointer = vbCustom
        SetCapture (Form1.hwnd) ' Form1 捕获鼠标输入
    End If
End Sub