_mastertips.txt

包括各种各样的系统功能

'Converts screen coordinates of a DWORD 
'     to a point structure, of a client


Sub MakeClientPoints(ByVal hwnd As Long, ByVal pts As Long, PT As POINTAPI)
    PT.x = LoWord(pts)
    PT.y = HiWord(pts)
    ScreenToClient hwnd, PT
End Sub
'***************************************
'     ****************************************
'     *
'FUNCTION: DrawControlBox
'ARGUMENTS: hwndhandle of window to draw
'     on to
'bGround Background color of button
'Bdm1Bottom border color
'Bdm22nd level bottom border
'Top1Top border color
'Top22nd level top border
'lOffset Amount to offset the ellipse by
'     
'
'COMMENTS: This is the sub routine that 
'     draws the actual control box. It is not
'a generic function, however. You may sp
'     ecify the border colors, but
'you cannot specify the shape inside or 
'     the size. I will try to update this late
'     r
'***************************************
'     ****************************************
'     *


Sub DrawControlBox(ByVal hwnd As Long, ByVal bGround As Long, ByVal Bdm1 As Long, ByVal Bdm2 As Long, ByVal Top1 As Long, ByVal Top2 As Long, ByVal lOffset As Byte)
    Dim hBrush As Long 'Handle of the background brush
    Dim hOldBrush As Long'Handle of the previous brush
    Dim hPen As Long'Handle of the new pen
    Dim hOldPen As Long 'Handle of the previous pen
    Dim lWidth As Long 'Width of the window
    Dim DC As Long 'Device context of window
    Dim PT As POINTAPI 'Stores previous points in MoveToEx
    lWidth = gSubClassedForm.Width / Screen.TwipsPerPixelX
    DC = GetWindowDC(hwnd)
    hBrush = CreateSolidBrush(bGround)
    hOldBrush = SelectObject(DC, hBrush)
    hPen = CreatePen(0, 1, Top1)
    hOldPen = SelectObject(DC, hPen)
    Rectangle DC, lWidth - 74, 6, lWidth - 58, 20
    DeleteObject (SelectObject(DC, hOldPen))
    'Draw ellipse (Black, regardless of othe
    '     r colors)
    hPen = CreatePen(0, 1, vbBlack)
    hOldPen = SelectObject(DC, hPen)
    Ellipse DC, lWidth - 70 + lOffset, 8 + lOffset, lWidth - 63 + lOffset, 17 + lOffset
    DeleteObject (SelectObject(DC, hOldPen))
    'Draw bottom border
    hPen = CreatePen(0, 1, Bdm1)
    hOldPen = SelectObject(DC, hPen)
    DeleteObject (hOldPen)
    MoveToEx DC, lWidth - 74, 19, PT
    LineTo DC, lWidth - 58, 19
    MoveToEx DC, lWidth - 59, 6, PT
    LineTo DC, lWidth - 59, 19
    DeleteObject (SelectObject(DC, hOldPen))
    DeleteObject (SelectObject(DC, hOldBrush))
    'Draw 2nd bottom border
    hPen = CreatePen(0, 1, Bdm2)
    hOldPen = SelectObject(DC, hPen)
    DeleteObject (hOldPen)
    MoveToEx DC, lWidth - 73, 18, PT
    LineTo DC, lWidth - 59, 18
    MoveToEx DC, lWidth - 60, 7, PT
    LineTo DC, lWidth - 60, 19
    DeleteObject (SelectObject(DC, hOldPen))
    'Draw 2nd top border
    hPen = CreatePen(0, 1, Top2)
    hOldPen = SelectObject(DC, hPen)
    DeleteObject (hOldPen)
    MoveToEx DC, lWidth - 73, 7, PT
    LineTo DC, lWidth - 60, 7
    MoveToEx DC, lWidth - 73, 7, PT
    LineTo DC, lWidth - 73, 18
    DeleteObject (SelectObject(DC, hOldPen))
    ReleaseDC hwnd, DC
End Sub


Public Sub SubClassForm(frm As Form)
    WndProcOld& = SetWindowLong(frm.hwnd, GWL_WNDPROC, AddressOf WindProc)
    Set gSubClassedForm = frm
End Sub


Public Sub UnSubclassForm(frm As Form)
    SetWindowLong frm.hwnd, GWL_WNDPROC, WndProcOld&
    WndProcOld& = 0
End Sub
'***************************************
'     **********
'ADD THIS SECTION OF CODE TO A FORM (CAL
'     LED FORM1)
'***************************************
'     **********


Private Sub Form_Load()


SubClassForm Form1
End Sub


Private Sub Form_Unload(Cancel As Integer)
    UnSubclassForm Form1
End Sub
'Make sure that the Sub "ControlBoxClick
'     ()" is in the Form that you are
'adding the control box to. Whatever is 
'     in this sub routine will be executed
'when the button is pressed


Public Sub ControlBoxClick()
    ' <-- Add code for when the button is cl
    '     icked -->
    MsgBox "You pressed the button"
End Sub
		

[TIP]disable close button
Declare Function GetSystemMenu Lib "user32" _
(ByVal hwnd As Long, ByVal bRevert As Long) As Long

Declare Function GetMenuItemCount Lib "user32" _
(ByVal hMenu As Long) As Long

Declare Function DrawMenuBar Lib "user32" _
(ByVal hwnd As Long) As Long

Declare Function RemoveMenu Lib "user32" _
(ByVal hMenu As Long, ByVal nPosition As Long, _
ByVal wFlags As Long) As Long
Public Const MF_BYPOSITION = &H400&
Public Const MF_REMOVE = &H1000&

Form code----------------
Dim hSysMenu As Long
Dim nCnt As Long

'First, show the form
Me.Show

'Get handle to our form's system menu 
'(Restore, Maximize, Move, close etc.)
hSysMenu = GetSystemMenu(Me.hwnd, False)

If hSysMenu Then
'Get System menu's menu count
nCnt = GetMenuItemCount(hSysMenu)

If nCnt Then

'Menu count is based on 0 (0, 1, 2, 3...)

RemoveMenu hSysMenu, nCnt - 1, _
MF_BYPOSITION Or MF_REMOVE

RemoveMenu hSysMenu, nCnt - 2, _
MF_BYPOSITION Or MF_REMOVE 'Remove the seperator

DrawMenuBar Me.hwnd 
'Force caption bar's refresh. Disabling X button

Me.Caption = "Try to close me!"
End If
End If

[TIP]return sub directories
Function SubFolders(ByVal strRootDir As String) As Variant
    On Error Goto ehSubFolders 'Trap For errors
    Dim strSubDir As String, strDelimiter As String, strReturn As String

    If Trim(strRootDir) = "" Then
        strRootDir = CurDir
    End If
    strRootDir = AppendBackslash(strRootDir)
    strDelimiter = ";"
    strSubDir = Dir(strRootDir, vbDirectory) 'Retrieve the first entry


    Do While strSubDir <> "" 
        If strSubDir <> "." And strSubDir <> ".." Then
	    If (GetAttr(strRootDir & strSubDir) And vbDirectory) = vbDirectory Then
        	strReturn = strReturn & strSubDir & strDelimiter
	    End If
	End If
	strSubDir = Dir 'Get Next entry
    Loop


    SubFolders = Split(strReturn, strDelimiter)
    Exit Function
ehSubFolders:
    SubFolders = Empty
End Function
[TIP]typed URL location
HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\TypedURLs
[TIP]transparent form when out of focus
[form code]
Private Sub Form_Load()
Dim NormalWindowStyle As Long
    Label1 = App.Path
    Me.Show
    DoEvents
    gHW = Me.hwnd   'Store handle to this form's window
    Hook    'Call procedure to begin capturing messages for this window

 
    NormalWindowStyle = GetWindowLong(Me.hwnd, GWL_EXSTYLE)
    SetWindowLong Me.hwnd, GWL_EXSTYLE, NormalWindowStyle Or WS_EX_LAYERED

    SetLayeredWindowAttributes Me.hwnd, 0, 255, LWA_ALPHA

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
SetLayeredWindowAttributes Me.hwnd, 0, 155, LWA_ALPHA
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Unhook
End Sub

[module code]
Public Const GWL_EXSTYLE = (-20)
Public Const WS_EX_LAYERED = &H80000
Public Const WS_EX_TRANSPARENT = &H20&
Public Const LWA_ALPHA = &H2&

Declare Function CallWindowProc Lib "user32" Alias _
    "CallWindowProcA" (ByVal lpPrevWndFunc As Long, _
    ByVal hwnd As Long, ByVal Msg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long
 
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crey As Byte, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long

Private Const WM_ACTIVATEAPP = &H1C
Private Const GWL_WNDPROC = -4
Public lpPrevWndProc As Long
Public gHW As Long

Public Sub Hook()

    'Establish a hook to capture messages to this window
    lpPrevWndProc = SetWindowLong(gHW, GWL_WNDPROC, AddressOf WindowProc)

End Sub

Public Sub Unhook()

    Dim temp As Long
    
    'Reset the message handler for this window
    temp = SetWindowLong(gHW, GWL_WNDPROC, lpPrevWndProc)
    
End Sub

Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long

    'Check for the ActivateApp message
    If uMsg = WM_ACTIVATEAPP Then
        'Check to see if Activating the application
        If wParam = 0 Then  'Application Received Focus
            SetLayeredWindowAttributes gHW, 0, 155, LWA_ALPHA
        Else
            'Application Lost Focus
            SetLayeredWindowAttributes gHW, 0, 255, LWA_ALPHA
        End If
    End If
    
    'Pass message on to the original window message handler
    WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
End Function
[TIP]ExitProcess - exit with return code
Private Declare Sub ExitProcess Lib "kernel32" (ByVal uExitCode As Long)
[TIP]press virtual key
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Long
Private Const KEYEVENTF_KEYUP = &H2


Sub PressVirtualKey(ByVal virtKeyCode As KeyCodeConstants, Optional ByVal Action As Integer)
    If Action >= 0 Then keybd_event virtKeyCode, 0, 0, 0
    If Action <= 0 Then keybd_event virtKeyCode, 0, KEYEVENTF_KEYUP, 0
    End If
End Sub
[TIP]INI processing - the coolest
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As Any, ByVal lpFileName As String) As Long

Function ReadINI(Section, KeyName, filename As String) As String
    Dim sRet As String
    sRet = String(255, Chr(0))
    ReadINI = Left(sRet, GetPrivateProfileString(Section, ByVal KeyName, "", sRet, Len(sRet), filename))
End Function
Function writeINI(sSection As String, sKeyName As String, sNewString As String, sFileName) As Integer
    Dim r
    r = WritePrivateProfileString(sSection, sKeyName, sNewString, sFileName)
End Function
 

[TIP]task invisibility
Private Sub Command1_Click()
    command1.caption = "Hide"
    App.TaskVisible = False
    MsgBox "Now press control-Alt-Delete together, and hey presto, it aint there"
End Sub


Private Sub Command2_Click()
    command2.caption = "Show"
    App.TaskVisible = True
    MsgBox "Now press control-Alt-Delete together and it will be there again"
End Sub
[TIP]BASE Conversion dec to any
Function Base10toX(dNum As Double, lBase As Long) As String
On Error GoTo Shit
Dim x As Double
Dim y As Double
Dim Power As Integer
    If lBase > 35 Then Err.Raise -849151, , "Base too large"
    If lBase < 2 Then Err.Raise -849151, , "Base too small"
    Base10toX = "": Power = 1
    Do: Power = Power + 1: Loop Until lBase ^ Power >= dNum: x = dNum
    While x >= lBase And Power > 0
        y = x \ (lBase ^ Power)
        If (y = 0 And Base10toX > "") Or y > 0 Then Base10toX = Base10toX & IIf(y < 10, CStr(y), Chr(65 + y - 10))
        x = x - (y * (lBase ^ Power)): Power = Power - 1: DoEvents
    Wend
    Base10toX = Base10toX & IIf(x < 10, CStr(x), Chr(65 + x - 10))
    Exit Function
Shit:
    Base10toX = Err.Description & " (" & Err.Number & ")"
End Function
[TIP]BASE conversion any to dec
Function BaseXto10(dNum As String, lBase As Long) As Double
On Error GoTo Shit
Dim x As Integer
Dim Power As Integer
    If lBase > 35 Then Err.Raise -849151, , "Base too large"
    If lBase < 2 Then Err.Raise -849151, , "Base too small"
    BaseXto10 = 0
    For Power = Len(dNum) To 1 Step -1
        If IsNumeric(Mid(dNum, Len(dNum) - Power + 1, 1)) Then
            x = CInt(Mid(dNum, Len(dNum) - Power + 1, 1))