mysubfunction.bas

传奇网吧伴侣源码

Attribute VB_Name = "MySubFunction"
'Option Explicit
' *********************************************
' The replacement window proc.
' *********************************************
'替换原有中断
Public Function NewWindowProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If Msg = TRAY_CALLBACK Then
        ' The user clicked on the tray icon.
        ' Look for click events.
        If lParam = WM_LBUTTONUP Then
            ' On left click, show the form.
            If TheForm.WindowState = vbMinimized Then _
                TheForm.WindowState = TheForm.LastState
            'TheForm.SetFocus
            Exit Function
        End If
        If lParam = WM_RBUTTONUP Then
            ' On right click, show the menu.
            TheForm.PopupMenu TheMenu
            Exit Function
        End If
    End If
    
    ' Send other messages to the original
    ' window proc.
    NewWindowProc = CallWindowProc( _
        OldWindowProc, hwnd, Msg, _
        wParam, lParam)
End Function
' *********************************************
' Add the form's icon to the tray.
' *********************************************
'载入托盘
Public Sub AddToTray(frm As Form, mnu As Menu)
    ' ShowInTaskbar must be set to False at
    ' design time because it is read-only at
    ' run time.

    ' Save the form and menu for later use.
    Set TheForm = frm
    Set TheMenu = mnu
    
    ' Install the new WindowProc.
    OldWindowProc = SetWindowLong(frm.hwnd, _
        GWL_WNDPROC, AddressOf NewWindowProc)
    
    ' Install the form's icon in the tray.
    With TheData
        .uID = 0
        .hwnd = frm.hwnd
        .cbSize = Len(TheData)
        .hIcon = frm.Icon.Handle
        .uFlags = NIF_ICON
        .uCallbackMessage = TRAY_CALLBACK
        .uFlags = .uFlags Or NIF_MESSAGE
        .cbSize = Len(TheData)
    End With
    Shell_NotifyIcon NIM_ADD, TheData
End Sub
' *********************************************
' Remove the icon from the system tray.
' *********************************************
'卸载托盘
Public Sub RemoveFromTray()
    ' Remove the icon from the tray.
    With TheData
        .uFlags = 0
    End With
    Shell_NotifyIcon NIM_DELETE, TheData
    
    ' Restore the original window proc.
    SetWindowLong frmTrayIcon.hwnd, GWL_WNDPROC, _
        OldWindowProc
End Sub
' *********************************************
' Set a new tray tip.
' *********************************************
'设置标题
Public Sub SetTrayTip(tip As String)
    With TheData
        .szTip = tip & vbNullChar
        .uFlags = NIF_TIP
    End With
    Shell_NotifyIcon NIM_MODIFY, TheData
End Sub
' *********************************************
' Set a new tray icon.
' *********************************************
'设置图标
Public Sub SetTrayIcon(pic As Picture)
    ' Do nothing if the picture is not an icon.
    If pic.Type <> vbPicTypeIcon Then Exit Sub

    ' Update the tray icon.
    With TheData
        .hIcon = pic.Handle
        .uFlags = NIF_ICON
    End With
    Shell_NotifyIcon NIM_MODIFY, TheData
End Sub


'判断窗口是否符合要求
Public Function TaskWindow(hwcurr As Long) As Long
Dim lngStyle As Long
'获取窗口风格，并判断是否符合要求
lngStyle = GetWindowLong(hwcurr, GWL_STYLE)
If (lngStyle And IsTask) = IsTask Then
 TaskWindow = True
End If
End Function

Public Sub FindAllApps(frmForm As Form)
Dim hwcurr As Long
Dim intLen As Long
Dim strTitle As String
Dim IsNumTitle As Boolean
Dim i As Long
Dim C As String
'列表清空

'获得第一个窗口的句柄
hwcurr = GetWindow(frmForm.hwnd, GW_HWNDFIRST)
'循环，找出主窗口列表中所有的窗口
Do While hwcurr
 If hwcurr <> frmForm.hwnd And TaskWindow(hwcurr) Then
 '获得该窗口的标题长度及标题
 intLen = GetWindowTextLength(hwcurr) + 1
 strTitle = Space$(intLen)
 intLen = GetWindowText(hwcurr, strTitle, intLen)
 If intLen > 0 Then

  Debug.Print Len(strTitle)
          
          IsNumTitle = True
          For i = 1 To Len(strTitle) - 1
          C = Mid(strTitle, i, 1)
          '判断程序标题是否为纯数字，因为QQ在运行中是以QQ号为标题
          If InStr(1, "0123456789", C) = 0 Then IsNumTitle = False
          Next i
          If IsNumTitle = True Then
          Debug.Print "========================================"
          SendMessage hwcurr, WM_CLOSE, 0, 0
          End If

 End If
 End If
'获得下一个窗口的句柄
hwcurr = GetWindow(hwcurr, GW_HWNDNEXT)
Loop
End Sub


Public Function SysDir()
'查找系统目录
Dim bufstr As String
bufstr = Space(50)
If GetSystemDirectory(bufstr, 50) > 0 Then
    SysDir = bufstr
    SysDir = RTrim(SysDir)
    SysDir = StripTerminator(SysDir)
     If Right$(SysDir, 1) <> "\" Then
        SysDir = SysDir + "\"
     End If
    
Else
    SysDir = ""
End If

End Function

Public Function WinDir()
'查找windows安装目录
Dim bufstr As String
bufstr = Space(50)
If GetWindowsDirectory(bufstr, 50) > 0 Then
    WinDir = bufstr
    WinDir = RTrim(WinDir)
    WinDir = StripTerminator(WinDir)
     If Right$(WinDir, 1) <> "\" Then
        WinDir = WinDir + "\"
     End If
    
Else
    WinDir = ""
End If

End Function


Public Function StripTerminator(ByVal strString As String) As String

    Dim intZeroPos As Integer

    intZeroPos = InStr(strString, Chr$(0))
    If intZeroPos > 0 Then
        StripTerminator = Left$(strString, intZeroPos - 1)
    Else
        StripTerminator = strString
    End If

End Function

Public Sub TransBlt(ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, _
                 ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal TransColor As Long)
       Dim dl              As Long
       Dim dWidth          As Long
       Dim dx              As Long
       
       Dim OrigColor       As Long
       Dim OrigMode        As Long
       
       Dim saveDC          As Long
       Dim maskDC          As Long
       Dim invDC           As Long
       Dim resultDC        As Long
       Dim BackDC          As Long
       
       Dim hSaveBmp        As Long
       Dim hMaskBmp        As Long
       Dim hInvBmp         As Long
       Dim hResultBmp      As Long
       Dim hBackBmp        As Long
       
       Dim hSavePrevBmp    As Long
       Dim hMaskPrevBmp    As Long
       Dim hInvPrevBmp     As Long
       Dim hDestPrevBmp    As Long
       Dim hBackPrevBmp    As Long
    
       
       saveDC = CreateCompatibleDC(hDestDC)
       maskDC = CreateCompatibleDC(hDestDC)
       invDC = CreateCompatibleDC(hDestDC)
       resultDC = CreateCompatibleDC(hDestDC)
       BackDC = CreateCompatibleDC(hDestDC)
       
       
       hMaskBmp = CreateBitmap(nWidth, nHeight, 1, 1, ByVal 0&)
       hInvBmp = CreateBitmap(nWidth, nHeight, 1, 1, ByVal 0&)
       
       hResultBmp = CreateCompatibleBitmap(hDestDC, nWidth, nHeight)
       hSaveBmp = CreateCompatibleBitmap(hDestDC, nWidth, nHeight)
       hBackBmp = CreateCompatibleBitmap(hDestDC, nWidth, nHeight)
       
       hSavePrevBmp = SelectObject(saveDC, hSaveBmp)
       hMaskPrevBmp = SelectObject(maskDC, hMaskBmp)
       hInvPrevBmp = SelectObject(invDC, hInvBmp)
       hDestPrevBmp = SelectObject(resultDC, hResultBmp)
       hBackPrevBmp = SelectObject(BackDC, hBackBmp)
           
       dl& = BitBlt(BackDC, 0, 0, nWidth, nHeight, hDestDC, X, Y, vbSrcCopy)
            PatBmp maskDC
            OrigColor = SetBkColor(hSrcDC, TransColor)
       For dWidth = 0 To nWidth Step 6
            dx = (nWidth - dWidth) \ 2
            
            StretchBlt maskDC, dx, 0, dWidth, nHeight, hSrcDC, xSrc, ySrc, nWidth, nHeight, vbSrcCopy
            dl& = BitBlt(invDC, 0, 0, nWidth, nHeight, maskDC, 0, 0, vbNotSrcCopy)
            dl& = BitBlt(resultDC, 0, 0, nWidth, nHeight, BackDC, 0, 0, vbSrcCopy)
            dl& = BitBlt(resultDC, 0, 0, nWidth, nHeight, maskDC, 0, 0, vbSrcAnd)
            StretchBlt saveDC, dx, 0, dWidth, nHeight, hSrcDC, xSrc, ySrc, nWidth, nHeight, vbSrcCopy
            dl& = BitBlt(saveDC, 0, 0, nWidth, nHeight, invDC, 0, 0, vbSrcAnd)
            dl& = BitBlt(resultDC, 0, 0, nWidth, nHeight, saveDC, 0, 0, vbSrcInvert)
            dl& = BitBlt(hDestDC, X, Y, nWidth, nHeight, resultDC, 0, 0, vbSrcCopy)
       Next

            dl& = SetBkColor(hSrcDC, OrigColor)
       
       SelectObject saveDC, hSavePrevBmp
       SelectObject resultDC, hDestPrevBmp
       SelectObject maskDC, hMaskPrevBmp
       SelectObject invDC, hInvPrevBmp
       SelectObject BackDC, hBackPrevBmp
       
       DeleteObject hSaveBmp
       DeleteObject hMaskBmp
       DeleteObject hInvBmp
       DeleteObject hResultBmp
       DeleteObject hBackBmp
       
       DeleteDC saveDC
       DeleteDC maskDC
       DeleteDC invDC
       DeleteDC resultDC
       DeleteDC BackDC
End Sub
                
Public Sub SelectFont(hDC As Long, FontName As String)
    Dim Myfont As LOGFONT
    Dim FontHandle As Long
    Dim oldhdc&
    Dim TempByteArray() As Byte
    Dim dl As Long
    
    Myfont.lfHeight = 40
    Myfont.lfWidth = 23
    Myfont.lfEscapement = 0
    Myfont.lfWeight = 1
    Myfont.lfItalic = 0
    Myfont.lfUnderline = 0
    Myfont.lfStrikeOut = 0
    Myfont.lfOutPrecision = OUT_DEFAULT_PRECIS
    Myfont.lfClipPrecision = OUT_DEFAULT_PRECIS
    Myfont.lfQuality = DEFAULT_QUALITY
    Myfont.lfPitchAndFamily = DEFAULT_PITCH Or FF_DONTCARE
    Myfont.lfCharSet = DEFAULT_CHARSET
    Myfont.lfOrientation = 0
    Myfont.lfFaceName = FontName & Chr$(0)


    FontHandle = CreateFontIndirect(Myfont)
    oldhdc = SelectObject(hDC, FontHandle)
End Sub
Public Sub PatBmp(hDC As Long)    '用白色填充设备场景
    Dim OldBrush As Long
    Dim NewBrush As Long
    Dim ary
    Dim hBitmap As Long
    Dim ARRY(1 To 16) As Integer
    Dim i As Integer
    Dim dl As Long
    
    ary = Array(&H0, &H0, &HFF, &H0, _
                &HFF, &H0, &HFF, &H0, _
                &HFF, &H0, &HFF, &H0, _
                &HFF, &H0, &HFF, &H0)
    For i = 1 To 16
       ARRY(i) = ary(i - 1)
    Next i
    hBitmap& = CreateBitmap(7, 7, 1, 1, ARRY(1))
    NewBrush = CreatePatternBrush(hBitmap)           '通过以上几个步骤创建实体刷子
    OldBrush& = SelectObject(hDC, NewBrush)
         PatBlt hDC, 0, 0, frmADScreen.Width, 50, PATCOPY
    dl& = SelectObject(hDC, OldBrush)
    dl& = DeleteObject(NewBrush)
End Sub

Public Sub PaintText(hDC As Long, strText As String)
    Dim dl As Long
    Dim TextSize As SIZE
    Dim X As Long
    Dim Y As Long
    
    dl& = GetTextExtentPoint32(hDC, strText, LenB(StrConv(strText, vbFromUnicode)), TextSize)
    X = (frmADScreen.ScaleWidth - TextSize.cx) \ 2
    Y = (50 - TextSize.cy) \ 2
    
    SetBkColor hDC, vbWhite
    TextOut hDC, X, Y, strText, LenB(StrConv(strText, vbFromUnicode))
End Sub

Public Function GetFromINI(AppName As String, KeyName As String, FileName As String) As String
   Dim RetStr As String
   RetStr = String(255, Chr(0))
   GetFromINI = Left(RetStr, GetPrivateProfileString(AppName, ByVal KeyName, "", RetStr, Len(RetStr), FileName))
End Function

Public Sub ExitWindows(ExitMode As String)
 Select Case ExitMode
 Case Is = "shutdown"
     t& = ExitWindowsEx(EWX_SHUTDOWN, 0)
 Case Is = "reboot"
     t& = ExitWindowsEx(EWX_REBOOT Or EXW_FORCE, 0)
 Case Else
    MsgBox ("无法关闭系统，请检查系统设置！")
 End Select
  
 End Sub