_mastertips.txt

包括各种各样的系统功能

[TIP]transaprent form 5
Private 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


Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long


Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long


Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long


Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
    
    
    '2 The Function
    ' This should be in the form's code. 


Private Function fMakeATranspArea(AreaType As String, pCordinate() As Long) As Boolean
    'Name: fMakeATranpArea
    'Author: Dalin Nie
    'Date: 5/18/98
    'Purpose: Create a Transprarent Area in 
    '     a form so that you can see through
    'Input: Areatype : a String indicate wha
    '     t kind of hole shape it would like to ma
    '     ke
    ' PCordinate : the cordinate area needed


    '     for create the shape:
        ' Example: X1, Y1, X2, Y2 for Rectangle
        'OutPut: A boolean
        Const RGN_DIFF = 4
        Dim lOriginalForm As Long
        Dim ltheHole As Long
        Dim lNewForm As Long
        Dim lFwidth As Single
        Dim lFHeight As Single
        Dim lborder_width As Single
        Dim ltitle_height As Single
        On Error Goto Trap
        lFwidth = ScaleX(Width, vbTwips, vbPixels)
        lFHeight = ScaleY(Height, vbTwips, vbPixels)
        lOriginalForm = CreateRectRgn(0, 0, lFwidth, lFHeight)
        
        lborder_width = (lFHeight - ScaleWidth) / 2
        ltitle_height = lFHeight - lborder_width - ScaleHeight


        Select Case AreaType
            
            Case "Elliptic"
            
            ltheHole = CreateEllipticRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))
            Case "RectAngle"
            
            ltheHole = CreateRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))
            
            Case "RoundRect"
            
            ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(5), pCordinate(6))
            Case "Circle"
            ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(3), pCordinate(4))
            
            Case Else
            MsgBox "Unknown Shape!!"
            Exit Function
        End Select
    lNewForm = CreateRectRgn(0, 0, 0, 0)
    CombineRgn lNewForm, lOriginalForm, _
    ltheHole, RGN_DIFF
    
    SetWindowRgn hWnd, lNewForm, True
    Me.Refresh
    fMakeATranspArea = True
    Exit Function
    Trap:
    MsgBox "error Occurred. Error # " & Err.Number & ", " & Err.Description
End Function


' 3 How To Call 

Dim lParam(1 To 6) As Long
lParam(1) = 100
lParam(2) = 100
lParam(3) = 250
lParam(4) = 250
lParam(5) = 50
lParam(6) = 50
Call fMakeATranspArea("RoundRect", lParam())
'Call fMakeATranspArea("RectAngle", lPar
'     am())
'Call fMakeATranspArea("Circle", lParam(
'     ))
'Call fMakeATranspArea("Elliptic", lPara
'     m())


[TIP]fast decimal to binary
Private Function DecToBin2(ByVal dIn As Double) As String
    DecToBin2 = ""


    While dIn >= 1
        DecToBin2 = IIf(dIn Mod 2 = 0, "0", "1") & DecToBin2
        dIn = dIn \ 2
    Wend
End Function

Private Function BinToDec(ByVal sIn As String) As Double
    Dim x As Integer
    BinToDec = 0


    For x = 1 To Len(sIn)
        BinToDec = BinToDec + (CInt(Mid(sIn, x, 1)) * (2 ^ (Len(sIn) - x)))
    Next x
End Function
[TIP]Excel stuff 3 (working)
Dim objExcel As Excel.Application
Dim i As Long

Set objExcel = Excel.Application
objExcel.Visible = False
objExcel.SheetsInNewWorkbook = 1
objExcel.Workbooks.Add ' (Text1)

With objExcel.ActiveSheet
    .Cells(1, 1).Value = "DATE"
    .Cells(1, 2).Value = "CHAPTER"
    .Cells(1, 3).Value = "# QUESTIONS"
    .Cells(1, 4).Value = "RIGHT ANSWERS"
    .Cells(1, 5).Value = "WRONG ANSWERS"
    .Cells(1, 6).Value = "NOT ANSWERED"
    .Cells(1, 7).Value = "PERCENTAGE"
End With

objExcel.ActiveSheet.SaveAs FileName:=Text1, FileFormat:=xlNormal, _
                Password:="", WriteResPassword:="", _
                ReadOnlyRecommended:=False, CreateBackup:=False
objExcel.Quit
Set objExcel = Nothing
[TIP]Excel stuff 2
im objExcel As Excel.Application

Set objExcel = Excel.Application
objExcel.Visible = False
objExcel.SheetsInNewWorkbook = 1
objExcel.Workbooks.Open ("C:/WS_SolarisMTT/Stats")

With objExcel.ActiveSheet
.Cells(1, 1).Value = "DATE"
.Cells(1, 2).Value = "CHAPTER"
.Cells(1, 3).Value = "# QUESTIONS"
.Cells(1, 4).Value = "RIGHT ANSWERS"
.Cells(1, 5).Value = "WRONG ANSWERS"
.Cells(1, 6).Value = "NOT ANSWERED"
.Cells(1, 7).Value = "PERCENTAGE"
End With

I = 2
cellfree:
With objExcel.ActiveSheet

If .Cells(I, 1).Value <> "" Then
I = I + 1
GoTo cellfree
Else
.Cells(I, 1).Value = Date
.Cells(I, 2).Value = "Chap1"
.Cells(I, 3).Value = N
.Cells(I, 4).Value = contador
.Cells(I, 5).Value = Cuentabad
.Cells(I, 6).Value = Cuentanoans
.Cells(I, 7).Value = Percent
End If
End With


objExcel.Save "C:/WS_SolarisMTT/Stats"
objExcel.Quit
Set objExcel = Nothing

[TIP]Excel stuff 1
Private xlApp As Excel.Application  ' Excel Application Object 
Private xlBook As Excel.Workbook    ' Excel Workbook Object 

'************************************************************* 
' Gets the contents of an Excel Worksheet's cell. 
' 
' xlWorksheet: Name of a worksheet in an Excel File, for example, 
'              "Sheet1" 
' xlCellName:  Name of a Cell (Row and Column), for example, 
'              "A1" or "B222". 
' xlFileName:  Name of an Excel File, for example, "C:TestTesting.xls" 
'************************************************************* 
Private Function GetExcel(xlFileName As String, _ 
                          xlWorksheet As String, _ 
                          xlCellName As String) As String 
                          
   On Error GoTo GetExcel_Err 
   
   Dim strCellContents As String 
   ' Create the Excel App Object 
   Set xlApp = CreateObject("Excel.Application") 
   ' Create the Excel Workbook Object. 
   Set xlBook = xlApp.Workbooks.Open(xlFileName) 
   
   ' Get the Cell Contents 
   strCellContents =     xlBook.worksheets(xlWorksheet).range(xlCellName).Value
   
   ' Close the spreadsheet 
   xlBook.Close savechanges:=False 
   xlApp.Quit 
   Set xlApp = Nothing 
   Set xlBook = Nothing 
   
   GetExcel = strCellContents 
   
   Exit Function 
GetExcel_Err: 
   MsgBox "GetExcel Error: " & Err.Number & "-" & Err.Description 
   Resume Next 
End Function 

'************************************************************* 
' Sets the contents of an Excel Worksheet's cell. 
' 
' xlWorksheet: Name of a worksheet in an Excel File, for example, 
'              "Sheet1" 
' xlCellName:  Name of a Cell (Row and Column), for example, 
'              "A1" or "B222". 
' xlFileName:  Name of an Excel File, for example, "C:TestTesting.xls" 
' xlCellContents:  What you want to place into the Cell. 
'************************************************************* 
Private Sub SetExcel(xlFileName As String, _ 
                     xlWorksheet As String, _ 
                     xlCellName As String, _ 
                     xlCellContents As String) 
                          
   On Error GoTo SetExcel_Err 
   
   ' Create the Excel App Object 
   Set xlApp = CreateObject("Excel.Application") 
   
   ' Create the Excel Workbook Object. 
   Set xlBook = xlApp.Workbooks.Open(xlFileName) 
   
   ' Set the value of the Cell 
   xlBook.worksheets(xlWorksheet).range(xlCellName).Value = xlCellContents 
   
   ' Save changes and close the spreadsheet 
   xlBook.Save 
   xlBook.Close savechanges:=False 
   xlApp.Quit 
   Set xlApp = Nothing 
   Set xlBook = Nothing 
   Exit Sub 
SetExcel_Err: 
   MsgBox "SetExcel Error: " & Err.Number & "-" & Err.Description 
   Resume Next 
End Sub
[TIP]array building without subscripts
    ReDim s(0)
    For x = 1 To 10
        ReDim Preserve s(UBound(s) + 1)
        s(UBound(s) - 1) = x
    Next x
    ReDim Preserve s(UBound(s) - 1)
[TIP]kill application
Const MAX_PATH& = 260
Declare Function TerminateProcess Lib "kernel32" (ByVal ApphProcess As Long, ByVal uExitCode As Long) As Long
Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal blnheritHandle As Long, ByVal dwAppProcessId As Long) As Long
Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, lProcessID As Long) As Long
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long


Type PROCESSENTRY32
    dwSize As Long
    cntUsage As Long
    th32ProcessID As Long
    th32DefaultHeapID As Long
    th32ModuleID As Long
    cntThreads As Long
    th32ParentProcessID As Long
    pcPriClassBase As Long
    dwFlags As Long
    szexeFile As String * MAX_PATH
    End Type



Public Function KillApp(myName As String) As Boolean
    
    Const PROCESS_ALL_ACCESS = 0
    Dim uProcess As PROCESSENTRY32
    Dim rProcessFound As Long
    Dim hSnapshot As Long
    Dim szExename As String
    Dim exitCode As Long
    Dim myProcess As Long
    Dim AppKill As Boolean
    Dim appCount As Integer
    Dim i As Integer
    On Local Error Goto Finish
    appCount = 0
    
    Const TH32CS_SNAPPROCESS As Long = 2&
    
    uProcess.dwSize = Len(uProcess)
    hSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
    rProcessFound = ProcessFirst(hSnapshot, uProcess)


    Do While rProcessFound
        i = InStr(1, uProcess.szexeFile, Chr(0))
        szExename = LCase$(Left$(uProcess.szexeFile, i - 1))


        If Right$(szExename, Len(myName)) = LCase$(myName) Then
            KillApp = True
            appCount = appCount + 1
            myProcess = OpenProcess(PROCESS_ALL_ACCESS, False, uProcess.th32ProcessID)
            AppKill = TerminateProcess(myProcess, exitCode)
            Call CloseHandle(myProcess)
        End If
        rProcessFound = ProcessNext(hSnapshot, uProcess)
    Loop
    Call CloseHandle(hSnapshot)
    Finish:
End Function

[TIP]make a .reg file
First, open notepad. Then on the very first line, type, REGEDIT4.
IMPORTANT: Put "Windows Registry Editor Version 5.00" AS THE BEGINING FOR WINDOWS 2000 USERS!!! 
On the next line type, [ Now type the path to your key. (i.e., HKEY_LOCAL_MACHINE\...) 
DO NOT PUT QUOTATION MARKS FOR THE PATH! 
End the key location with, ] On the line RIGHT under that, type a quotation mark, then the key name. 
End your key NAME always with a quotation mark. 
Type an = sign, (with no space in between the key) next type the value for that key. 

If you have multiple keys to add, press enter and add the other key name and so on until you get to the point where you want to add another key to a different location. When you get to this point, press enter and and follow these steps all over again! When your done, save it as: "whatever.reg" An example would look like this: 
REGEDIT4
[HKEY_LOCAL_MACHINE\Software\WINDOWS\]
"Whatever"=Anything
[HKEY_LOCAL_MACHINE\Software\YourApp]
"Color"=&H8000000F
[TIP]detect application focus
in the bas module...
Option Explicit

Private 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