module1.bas

本人初学VB的处女作！ 带单机的端口扫描功能

Attribute VB_Name = "Module1"
'在任务栏添加图标
Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Public Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal hicon As Long) As Long
' Used to set the shape of the form
Public Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
' Used to create the rounded rectangle region
Public Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
' Used to make the form draggable
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
' Also used to make the form draggable
Public Declare Function ReleaseCapture Lib "user32" () As Long
' Used to make the window always on top
Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, Y, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
' Various constants used by the above functions

Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As Any) As Long
Public Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Public Declare Function GetTickCount Lib "kernel32" () As Long
Public Type POINTAPI
    X As Long
    Y As Long
End Type

Public Type NOTIFYICONDATA
    cbSize As Long                   '结构的长度
    hwnd As Long                     '消息接收窗口的句柄
    uID As Long                      '图标的标识
    uFlags As Long                   '设置参数
    uCallbackMessage As Long         '回调消息的值
    hicon As Long                    '图标句柄
    szTip As String * 64             '提示字符串
End Type

Public Const NIM_ADD = 0             '添加图标
Public Const NIM_MODIFY = 1          '修改图标
Public Const NIM_DELETE = 2          '删除图标

Public Const NIF_MESSAGE = 1         '当有鼠标事件发生时产生消息
Public Const NIF_ICON = 2            '
Public Const NIF_TIP = 4             '图标有提示字符串


Public Const WM_LBUTTONDOWN = &H201
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_USER = &H400
Public Const WM_NOTIFYICON = WM_USER + &H100
Public Const WM_COMMAND = &H111
Public Const WM_DESTROY = &H2
Public Const WM_DRAWITEM = &H2B
Public Const WM_INITDIALOG = &H110
Public Const WM_PAINT = &HF
Public Const WM_MENUSELECT = &H11F

Public Const GWL_WNDPROC = (-4) '替换窗口处理函数

Dim pmenu As Long
Dim submenu As Long

Global lproc As Long
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOACTIVATE = &H10
Public Const SWP_SHOWWINDOW = &H40
Public Const TOPMOST_FLAGS = SWP_NOMOVE Or SWP_NOSIZE
           
Public Sub AlwaysOnTop(TheForm As Form, Toggle As Boolean)
' TheForm:  The form you want to make always on top or not
' Toggle:   Boolean (True/False) - True for always on top, False for normal
    
    If Toggle = True Then
        SetWindowPos TheForm.hwnd, HWND_TOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
    Else
        SetWindowPos TheForm.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
    End If
End Sub

Public Sub DoDrag(TheForm As Form)
' TheForm:  The form you want to start dragging
    
    ReleaseCapture
    SendMessage TheForm.hwnd, &HA1, 2, 0&
End Sub

Public Sub MakeWindow(TheForm As Form)
' TheForm:  The form you want to make graphical
    
    TheForm.BackColor = RGB(207, 207, 207)
    TheForm.Caption = TheForm!lblTitle.Caption
    TheForm!lblTitle.Left = 16
    TheForm!lblTitle.Top = 7
    
    With TheForm!imgTitleLeft
        .Top = 0
        .Left = 0
    End With
    
    With TheForm!imgTitleRight
        .Top = 0
        .Left = (TheForm.Width / Screen.TwipsPerPixelX) - 19
    End With
    
    With TheForm!imgTitleMain
        .Top = 0
        .Left = 19
        .Width = (TheForm.Width / Screen.TwipsPerPixelX) - 19
    End With
    
    With TheForm!imgWindowLeft
        .Top = 30
        .Left = 0
        .Height = (TheForm.Height / Screen.TwipsPerPixelY) - 60
    End With
    
    With TheForm!imgWindowBottomLeft
        .Top = (TheForm.Height / Screen.TwipsPerPixelY) - 30
        .Left = 0
    End With
    
    With TheForm!imgWindowBottom
        .Top = (TheForm.Height / Screen.TwipsPerPixelY) - 30
        .Left = 19
        .Width = (TheForm.Width / Screen.TwipsPerPixelX) - 38
    End With
    
    With TheForm!imgWindowBottomRight
        .Top = (TheForm.Height / Screen.TwipsPerPixelY) - 30
        .Left = (TheForm.Width / Screen.TwipsPerPixelX) - 19
    End With
    
    With TheForm!imgWindowRight
        .Top = 30
        .Left = (TheForm.Width / Screen.TwipsPerPixelX) - 19
        .Height = (TheForm.Width / Screen.TwipsPerPixelX) - 38
    End With
    
    With TheForm!imgTitleClose
        .Top = 8
        .Left = (TheForm.Width / Screen.TwipsPerPixelX) - 22
    End With
    
    With TheForm!imgTitleMinimize
        .Top = 8
        .Left = (TheForm.Width / Screen.TwipsPerPixelX) - 39
    End With
    
    With TheForm!imgTitleHelp
        .Top = 8
        .Left = (TheForm.Width / Screen.TwipsPerPixelX) - 56
    End With
    
    DoTransparency TheForm
End Sub

Public Sub DoTransparency(TheForm As Form)
' TheForm:  The form you want to be rounded rectangle shape
    
    Dim TempRegions(6) As Long
    Dim FormWidthInPixels As Long
    Dim FormHeightInPixels As Long
    Dim a
    
' Convert the form's height and width from twips to pixels
    FormWidthInPixels = TheForm.Width / Screen.TwipsPerPixelX
    FormHeightInPixels = TheForm.Height / Screen.TwipsPerPixelY
    
' Make a rounded rectangle shaped region with the dimentions of the form
    a = CreateRoundRectRgn(0, 0, FormWidthInPixels, FormHeightInPixels, 24, 24)
    
' Set this region as the shape for "TheForm"
    a = SetWindowRgn(TheForm.hwnd, a, True)
End Sub



Function CMenu() As Boolean
'这个函数获得Form1的子菜单
  Dim l As Long
  Dim l1 As Long
  
  pmenu = GetMenu(Form1.hwnd)
  submenu = GetSubMenu(pmenu, 0)
  If submenu Then
    CMenu = True
  Else
    CMenu = False
  End If
End Function
Function Icon_Del(ihwnd As Long) As Long
  Dim ano As NOTIFYICONDATA
  Dim l As Long
  
  ano.hwnd = ihwnd
  ano.uID = 0
  ano.cbSize = Len(ano)
  '删除图标
  Icon_Del = Shell_NotifyIcon(NIM_DELETE, ano)
End Function
'这个函数接收图标句柄和窗口句柄并且新建图标
Function Icon_Add(ihwnd As Long, hicon As Long) As Long
  Dim ano As NOTIFYICONDATA
  Dim astr As String
  
  '为图标添加提示行
  astr = "超级工具箱"
  ano.szTip = astr + Chr$(0)
  '设置消息接收窗口
  ano.hwnd = ihwnd
  ano.uID = 0
  '图标有提示并且可以发送消息
  ano.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
  ano.hicon = hicon
  ano.cbSize = Len(ano)
  '将图标的回调消息设置为WM_NOTIFYICON，当在图标区域有鼠标消息，系统就会向
  '消息接收窗口发送WM_NOTIFYICON消息。
  ano.uCallbackMessage = WM_NOTIFYICON
  Icon_Add = Shell_NotifyIcon(NIM_ADD, ano)
End Function

Function DialogProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'该函数为Form2的窗口处理函数。
  Dim l As Long
  Dim l1 As Long
  Dim po As POINTAPI
  
  Select Case uMsg
    Case WM_INITDIALOG
    Case WM_DESTROY
    Case WM_COMMAND
    Case WM_DRAWITEM
    Case WM_NOTIFYICON  '有鼠标事件产生
      Select Case lParam
        Case WM_LBUTTONDOWN     '按下鼠标左键
          '提示是否删除图标
            '删除图标同时恢复窗口处理函数
            l = SetWindowLong(Form1.hwnd, GWL_WNDPROC, lproc)
            frmMain.Show
        Case WM_RBUTTONDOWN     '按下鼠标右键弹出菜单
          If submenu Then
            l = GetCursorPos(po)        '获的光标位置
            '在光标位置处弹出菜单
            l1 = TrackPopupMenu(submenu, (TPM_LEFTALIGN Or TPM_RIGHTBUTTON), po.X, po.Y, 0, Form1.hwnd, vbNull)
          End If
        Case Else
      End Select
    Case Else
      DialogProc = False
  End Select
  DialogProc = True
End Function