_mastertips.txt

包括各种各样的系统功能

 
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
	(ByVal hwnd As Long, ByVal nIndex As Long, _
	ByVal dwNewLong 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
			Form1.Caption = "Focus Restored"
		Else
			'Application Lost Focus
			Form1.Caption = "Focus Lost"
		End If
	End If 
	
	'Pass message on to the original window message handler
	WindowProc =  CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam) 
End Function

In the form....
Option Explicit

Sub Form_Load()

    gHW = Me.hwnd   'Store handle to this form's window
    Hook    'Call procedure to begin capturing messages for this window
    
End Sub
Private Sub Form_Unload(Cancel As Integer)

    'Call procedure to stop intercepting the messages for this window
    Unhook
    
End Sub

[TIP]log time
Sub StartApp()
Open "c:\test.log" For Append As #1
Print #1, Format(Now, "yyyymmdd hh:mm") & " " & UCase(Environ("username")) & " START"
Close #1
End Sub
Sub ExitApp()
Open "c:\test.log" For Append As #1
Print #1, Format(Now, "yyyymmdd hh:mm") & " " & UCase(Environ("username")) & " STOP"
Close #1
Unload Me
End

End Sub
[TIP]screen resolution
Label1 = CStr(Screen.Width / Screen.TwipsPerPixelX) & "x" & CStr(Screen.Height / Screen.TwipsPerPixelY)
[TIP]ini delete
Function INI_D(ByVal sLocation As String, ByVal sField As String) As String
Dim iFnum As Integer
Dim sFile As String
Dim sLines() As String
Dim iX As Integer
    
    If Not FileExists(sLocation) Then
        INI_D = "!INI file not found"
        Exit Function
    End If
    If Left(INI_R(sLocation, sField), 4) = "!INI" Then
        INI_D = "!INI field not found"
        Exit Function
    End If
    
    sFile = FileText(sLocation)
    sLines = Split(sFile, vbCrLf)
    iFnum = FreeFile
    Open sLocation For Output As iFnum
    
    For iX = 0 To UBound(sLines)
        If (Trim(sLines(iX)) = "" Or InStr(sLines(iX), "=") = 0) _
        Or InStr(UCase(sLines(iX)), UCase(sField)) = 0 _
        Or (InStr(UCase(sLines(iX)), UCase(sField)) > 0 And InStr(sLines(iX), "=") < InStr(UCase(sLines(iX)), UCase(sField))) Then
            Print #iFnum, sLines(iX)
        
        End If
    Next iX

    Close iFnum
    INI_D = "!INI RC0"

End Function
[TIP]ini write
Function INI_W(ByVal sLocation As String, ByVal sField As String, ByVal sValue As String) As String
Dim bFieldThere As Boolean
Dim sFile As String
Dim iFnum As Integer
Dim sLines() As String
Dim iX As Integer
Dim sLine() As String

    If Not FileExists(sLocation) Then
        INI_W = "!INI file not found"
        Exit Function
    End If

    bFieldThere = True
    If Left(INI_R(sLocation, sField), 4) = "!INI" Then
        bFieldThere = False
    End If
    sFile = FileText(sLocation)
    sFile = IIf(Right(sFile, 2) = vbCrLf, Left(sFile, Len(sFile) - 2), sFile)
    iFnum = FreeFile
    Open sLocation For Output As iFnum
    
    If Not bFieldThere Then
        sFile = sFile & vbCrLf & sField & "=" & sValue
        Print #iFnum, sFile
    Else
        sLines = Split(sFile, vbCrLf)
        For iX = 0 To UBound(sLines)
            If Trim(sLines(iX)) = "" Or InStr(sLines(iX), "=") = 0 Then
                Print #iFnum, sLines(iX)
            Else
                sLine = Split(sLines(iX), "=")
                If UCase(sLine(0)) = UCase(sField) Then
                    sLine(1) = sValue
                End If
                Print #iFnum, sLine(0) & "=" & sLine(1)
            End If
        Next iX
    End If
    Close iFnum
    INI_W = "!INI RC0"
End Function
[TIP]ini read
Function INI_R(ByVal sLocation As String, ByVal sField As String) As String
'==========================================
'requires fileexists and filetext functions
'==========================================
On Local Error GoTo INIError
    If Not FileExists(sLocation) Then
        INI_R = "!INI file not found"
        Exit Function
    End If
Dim sIn As String
Dim sLines() As String

    sIn = FileText(sLocation)
    sLines = Split(UCase(sIn), UCase(sField))
    If Left(sLines(1), 1) <> "=" Then
        INI_R = "!INI field not found"
        Exit Function
    End If
    INI_R = Mid(sLines(1), 2, IIf(InStr(sLines(1), vbCrLf) > 0, InStr(sLines(1), vbCrLf), Len(sLines(1))) - 1)
    Exit Function
INIError:
    INI_R = "!INI field not found"
End Function
[TIP]trim textbox width to width of text
Text1.Width = Form1.TextWidth("a") 
[TIP]decimal to binary
Private Sub Command1_Click()
    DecValue = Val(Text1.Text)
    BinValue = ""


    Do
        TempValue = DecValue Mod 2
        BinValue = CStr(TempValue) + BinValue
        DecValue = DecValue \ 2
    Loop Until DecValue = 0
    'Print
    'Print BinValue
    Text2.Text = BinValue
End Sub
[TIP]open an app with it's default application
Private 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

'// open file (quotes are used so that the actual value that is passed is "C:\test.doc"
Private Sub cmdOpen_Click()
    If ShellExecute(0, vbNullString, """"C:\test.doc"""", vbNullString, vbNullString, vbNormalFocus) = 2 Then
End Sub

'// open url
Private Sub cmdOpen_Click()
    If ShellExecute(0, vbNullString, "http://www.vbweb.f9.co.uk/", vbNullString, vbNullString, vbNormalFocus) = 2 Then
End Sub

'// open email address
Private Sub cmdOpen_Click()
    If ShellExecute(0, vbNullString, "mailto:[e-mail]", vbNullString, vbNullString, vbNormalFocus) = 2 Then
End Sub 

[TIP]detect internet connection
Option Explicit
Public Declare Function InternetGetConnectedState _
Lib "wininet.dll" (ByRef lpSFlags As Long, _
ByVal dwReserved As Long) As Long

Public Const INTERNET_CONNECTION_LAN As Long = &H2
Public Const INTERNET_CONNECTION_MODEM As Long = &H1

Public Function Online() As Boolean
    'If you are online it will return True, otherwise False
    Online = InternetGetConnectedState(0& ,0&)
End Function

Public Function ViaLAN() As Boolean

Dim SFlags As Long
'return the flags associated with the connection
Call InternetGetConnectedState(SFlags, 0&)

'True if the Sflags has a LAN connection
ViaLAN = SFlags And INTERNET_CONNECTION_LAN

End Function
Public Function ViaModem() As Boolean

Dim SFlags As Long
'return the flags associated with the connection
Call InternetGetConnectedState(SFlags, 0&)

'True if the Sflags has a modem connection
ViaModem = SFlags And INTERNET_CONNECTION_MODEM

End Function


'Add this code to a form with one command button and three text boxes. It will return "True" for which ever 'one you are connected to. 

Option Explicit 

Private Sub Command1_Click() 
Text1 = ViaLAN() 
Text2 = ViaModem() 
Text3 = Online()
End Sub 




[TIP]registry bits n bobs

' Reg Key Security Options...
Const KEY_ALL_ACCESS = &H2003F

' Reg Key ROOT Types...
Const HKEY_LOCAL_MACHINE = &H80000002
Const ERROR_SUCCESS = 0
Const REG_SZ = 1                         ' Unicode nul terminated string
Const REG_DWORD = 4                      ' 32-bit number

Const gREGKEYSYSINFOLOC = "SOFTWARE\Microsoft\Shared Tools Location"
Const gREGVALSYSINFOLOC = "MSINFO"
Const gREGKEYSYSINFO = "SOFTWARE\Microsoft\Shared Tools\MSINFO"
Const gREGVALSYSINFO = "PATH"

Private Declare Function OSWinHelp% Lib "user32" Alias "WinHelpA" (ByVal hwnd&, ByVal HelpFile$, ByVal wCommand%, dwData As Any)
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
Public Sub StartSysInfo()
    On Error GoTo SysInfoErr

    Dim rc As Long
    Dim SysInfoPath As String

    ' Try To Get System Info Program Path\Name From Registry...
    If GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFO, gREGVALSYSINFO, SysInfoPath) Then
        ' Try To Get System Info Program Path Only From Registry...
    ElseIf GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFOLOC, gREGVALSYSINFOLOC, SysInfoPath) Then
        ' Validate Existance Of Known 32 Bit File Version
        If (Dir(SysInfoPath & "\MSINFO32.EXE") <> "") Then
            SysInfoPath = SysInfoPath & "\MSINFO32.EXE"

            ' Error - File Can Not Be Found...
        Else
            GoTo SysInfoErr
        End If
        ' Error - Registry Entry Can Not Be Found...
    Else
        GoTo SysInfoErr
    End If

    Call Shell(SysInfoPath, vbNormalFocus)

    Exit Sub
SysInfoErr:
    MsgBox "System Information Is Unavailable At This Time", vbOKOnly
End Sub
Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, ByRef KeyVal As String) As Boolean
    Dim i As Long                                           ' Loop Counter
    Dim rc As Long                                          ' Return Code
    Dim hKey As Long                                        ' Handle To An Open Registry Key
    Dim hDepth As Long                                      '
    Dim KeyValType As Long                                  ' Data Type Of A Registry Key
    Dim tmpVal As String                                    ' Tempory Storage For A Registry Key Value
    Dim KeyValSize As Long                                  ' Size Of Registry Key Variable
    '------------------------------------------------------------
    ' Open RegKey Under KeyRoot {HKEY_LOCAL_MACHINE...}
    '------------------------------------------------------------
    rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' Open Registry Key

    If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' Handle Error...

    tmpVal = String$(1024, 0)                             ' Allocate Variable Space
    KeyValSize = 1024                                       ' Mark Variable Size

    '------------------------------------------------------------
    ' Retrieve Registry Key Value...
    '------------------------------------------------------------
    rc = RegQueryValueEx(hKey, SubKeyRef, 0, KeyValType, tmpVal, KeyValSize)    ' Get/Create Key Value

    If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' Handle Errors

    tmpVal = VBA.Left(tmpVal, InStr(tmpVal, VBA.Chr(0)) - 1)
    '------------------------------------------------------------
    ' Determine Key Value Type For Conversion...
    '------------------------------------------------------------
    Select Case KeyValType                                  ' Search Data Types...
    Case REG_SZ                                             ' String Registry Key Data Type
        KeyVal = tmpVal                                     ' Copy String Value
    Case REG_DWORD                                          ' Double Word Registry Key Data Type
        For i = Len(tmpVal) To 1 Step -1                    ' Convert Each Bit
            KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1)))   ' Build Value Char. By Char.
        Next
        KeyVal = Format$("&h" + KeyVal)                     ' Convert Double Word To String
    End Select

    GetKeyValue = True                                      ' Return Success
    rc = RegCloseKey(hKey)                                  ' Close Registry Key
    Exit Function                                           ' Exit

GetKeyError:        ' Cleanup After An Error Has Occured...
    KeyVal = ""                                             ' Set Return Val To Empty String
    GetKeyValue = False                                     ' Return Failure
    rc = RegCloseKey(hKey)