module2.bas

adsl拨号工具 有很多功能 不错啊 大家试试

Attribute VB_Name = "Module2"
' #MndSoft#************************************************************
' * 文件名    : Module2.bas
' * 程序内容  : NX-3型抄表器数据通讯主程序
' * 建立日期  : 2001/11/17
' * 修改日期  : 2002/03/18
' * 主页地址  : http://mnd.my163.com
' * 电子信箱  : [e-mail]
' * Copyright (c) 2000-2002, MndSoftware, Inc.
' **********************************************************************
' * 注释      :2002.6.3添加上下进度条
' **********************************************************************
Option Explicit

Public Const TTS_ALWAYSTIP = &H1
Public Const TTS_NOPREFIX = &H2
Public Const TTS_BALLOON = &H40
Public Const CW_USEDEFAULT = &H80000000
Public Const WS_POPUP = &H80000000
Public Const WM_USER = &H400
' 提示的消息
Public Const TTM_SETDELAYTIME = (WM_USER + 3)
Public Const TTM_ADDTOOL = (WM_USER + 4)
Public Const TTM_SETTIPBKCOLOR = (WM_USER + 19)
Public Const TTM_SETTIPTEXTCOLOR = (WM_USER + 20)
Public Const TTM_GETTIPBKCOLOR = (WM_USER + 22)
Public Const TTM_GETTIPTEXTCOLOR = (WM_USER + 23)
Public Const TTM_SETMAXTIPWIDTH = (WM_USER + 24)

Public Const TTDT_AUTOMATIC = 0
Public Const TTDT_RESHOW = 1
Public Const TTDT_AUTOPOP = 2
Public Const TTDT_INITIAL = 3

Public Const TTF_IDISHWND = &H1
Public Const TTF_CENTERTIP = &H2
Public Const TTF_SUBCLASS = &H10

Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Public Type TOOLINFO
    cbSize      As Long
    uFlags      As Long
    hwnd        As Long
    uId         As Long
    cRect       As RECT
    hInst       As Long
    lpszText    As String
End Type
Public Declare Function CreateWindowEx Lib "user32" _
Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal _
lpClassName As String, ByVal lpWindowName As String, ByVal _
dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth _
As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal _
hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Public Declare Function DestroyWindow Lib "user32" (ByVal hwnd _
As Long) As Long
Public Declare Function GetClientRect Lib "user32" (ByVal hwnd _
As Long, lpRect As RECT) As Long
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
Public Declare Function SendMessageLong Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Public bCreated As Boolean, hTT As Long
Public hCreated() As Long
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Public Const MF_BYPOSITION = &H400&

Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Public Const MF_DISABLED = &H2&

Public Sub CreateTTWindow(hParent As Long, Optional _
   bBalloon As Boolean = False)

  Dim h As Long, lStyle As Long
  lStyle = TTS_NOPREFIX Or TTS_ALWAYSTIP
  If bBalloon Then lStyle = lStyle Or TTS_BALLOON
  hTT = CreateWindowEx(0, "tooltips_class32", 0, lStyle, _
  CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, _
  hParent, 0, App.hInstance, 0)
  If Not bCreated Then
     ReDim hCreated(0)
     bCreated = True
  Else
     ReDim Preserve hCreated(UBound(hCreated) + 1)
  End If
  hCreated(UBound(hCreated)) = hTT
End Sub

Public Sub SetToolTip(objTT As Object, sTipText As String, _
                      Optional BkColor As Long = &HEEFFFF, _
                      Optional TxtColor As Long = vbBlack, _
                      Optional MaxWidth As Long = 300, _
                      Optional DelayTime As Long = 500, _
                      Optional VisibleTime As Long = 2000, _
                      Optional bCenter As Boolean = False)
    Dim TI As TOOLINFO
    With TI
        GetClientRect objTT.hwnd, .cRect
        .hwnd = objTT.hwnd
        .uFlags = TTF_IDISHWND Or TTF_SUBCLASS
        If bCenter Then
            .uFlags = .uFlags Or TTF_CENTERTIP
        End If
        .uId = objTT.hwnd
        .lpszText = sTipText
        .cbSize = Len(TI)
    End With
    SendMessageLong hTT, TTM_SETMAXTIPWIDTH, 0, MaxWidth
    SendMessageLong hTT, TTM_SETDELAYTIME, TTDT_INITIAL, _
             DelayTime
    SendMessageLong hTT, TTM_SETDELAYTIME, TTDT_AUTOPOP, _
           VisibleTime
    SendMessageLong hTT, TTM_SETTIPTEXTCOLOR, TxtColor, 0&
    SendMessageLong hTT, TTM_SETTIPBKCOLOR, BkColor, 0&
    SendMessage hTT, TTM_ADDTOOL, 0, TI
End Sub

Public Sub DestroyTT()
  If Not bCreated Then Exit Sub
  Dim i As Integer
  For i = 0 To UBound(hCreated)
      DestroyWindow hCreated(i)
  Next
End Sub

Public Sub DisableX(Frm As Form)
    Dim hMenu As Long, nCount As Long
    hMenu = GetSystemMenu(Frm.hwnd, 0)
    nCount = GetMenuItemCount(hMenu)
    Call RemoveMenu(hMenu, nCount - 1, MF_DISABLED Or MF_BYPOSITION)
    DrawMenuBar Frm.hwnd
End Sub