_mastertips.txt

包括各种各样的系统功能

        Else
            x = (Asc(Mid(dNum, Len(dNum) - Power + 1, 1)) - 55)
        End If
        BaseXto10 = BaseXto10 + (x * (lBase ^ (Power - 1)))
    Next Power
    Exit Function
Shit:
    BaseXto10 = Err.Description & " (" & Err.Number & ")"
End Function

[TIP]compare 2 user defined types
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As _
    Any, source As Any, ByVal bytes As Long)

' a sample UDT structure, that contains almost every possible type of data
Private Type MyUDT
    item1 As Boolean
    item2(10) As Integer
    item3 As Long
    item4 As Single
    item5 As Double
    item6 As Currency
    item7 As String * 20
End Type
Dim udt1 As MyUDT, udt2 As MyUDT

' init the first UDT
udt1.item1 = 10
udt1.item2(1) = 4
udt1.item3 = 12345
udt1.item4 = 345.567
udt1.item5 = 111.333444
udt1.item6 = 223344.5566
udt1.item7 = "this is a test"

' init the second UDT
' (in this test both UDTs contains the same value)
udt2 = udt1

' the number of bytes to be compared
Dim bytes As Long
bytes = LenB(udt1)

' the strings used for the comparison
Dim s1 As String, s2 As String
' make them long enough to host the UDTs
s1 = Space$((bytes + 1) \ 2)
s2 = s1

' copy the UDTs into the strings
CopyMemory ByVal StrPtr(s1), ByVal VarPtr(udt1), bytes
CopyMemory ByVal StrPtr(s2), ByVal VarPtr(udt2), bytes

' now you can perform the comparison
If s1 = s2 Then
    MsgBox "Equal"
Else
    MsgBox "Different"
End If

[TIP]VB to Excel example
Dim objExcel As Excel.Application
Dim objWorksheet As Excel.Worksheet
Const BMWFont As String = "BMW Helvetica Light"
Const XL_NOTRUNNING As Long = 429
Const Bold As Boolean = True
Const Regular As Boolean = False
Const Wrap As Boolean = True
Const NoWrap As Boolean = True


Sub OpenExcelSheet()
    Set objExcel = Excel.Application
    objExcel.Visible = False
    objExcel.SheetsInNewWorkbook = 1
    objExcel.Workbooks.Add
    Set objWorksheet = objExcel.Worksheets("Sheet1")
      
End Sub
Sub WriteCell(sText As String, lCol As Long, lRow As Long, sFontName As String, _
              iFontSize As Integer, bBold As Boolean, sAlignment As String)
              
    With objWorksheet
        If Left(sText, 1) = "'" Then
            .Cells(lRow, lCol).Value = sText
        Else
            .Cells(lRow, lCol).Formula = sText
        End If
        .Cells(lRow, lCol).Font.Name = sFontName
        .Cells(lRow, lCol).Font.Size = iFontSize
        .Cells(lRow, lCol).Font.Bold = IIf(bBold, True, False)
        .Cells(lRow, lCol).VerticalAlignment = xlTop
        .Cells(lRow, lCol).HorizontalAlignment = IIf(LCase(sAlignment) = "left", xlLeft, xlRight)
        '.Cells(lRow, lCol).Font.Color = RGB(255,0,0)
    End With
End Sub
Function CloseExcelSheet(ByVal EmployeeNo As Long, ByVal P11DFromDate As Date, ByVal P11DToDate As Date) As String
Dim sLoc As String
    sLoc = GetSetting(App.Title, "Settings", "P11DSaveLocation")
    If sLoc = "" Then
        SaveSetting App.Title, "Settings", "P11DSaveLocation", "c:\"
        P11D_MsgBox "The location where your P11D reports has not been defined." & vbCrLf & vbCrLf & "The save location is now set to C:\" & vbCrLf & vbCrLf & "You can change this location from the Main menu/Options", 99, App.Title
    End If
    CloseExcelSheet = GetSetting(App.Title, "Settings", "P11DSaveLocation") & "P11D " & IIf(bForecast, "Forecast", "Actual") & " Emp " & _
                    Format(EmployeeNo, "000000") & " From " & Format(P11DFromDate, "dd.mm.yyyy") & _
                    " To " & Format(P11DToDate, "dd.mm.yyyy") & " Created " & _
                    Format(Now, "dd.mm.yyyy HH.MM.SS") & ".xls"
    objWorksheet.SaveAs FileName:=CloseExcelSheet, FileFormat:=xlNormal, _
                    Password:="", WriteResPassword:="", _
                    ReadOnlyRecommended:=False, CreateBackup:=False
    objExcel.Quit
    Set objWorksheet = Nothing
    Set objExcel = Nothing
    
End Function
Sub ExcelPageSetup(ByVal P11DFromDate As Date, ByVal P11DToDate As Date, _
                        ByVal EmployeeNo As Long)
Dim sPageSetup As String
    SBInfo "Formatting excel wooksheet (Page setup)"
    With objWorksheet
        .Range("S1").Select
        .Pictures.Insert(App.Path & "\bmw_logo.bmp").Select
        With Selection
            .ShapeRange.ScaleWidth 0.66, 0, 0
            .ShapeRange.ScaleHeight 0.66, 0, 0
        End With
       
        sPageSetup = "PAGE.SETUP(,,.5,.5,1,1,False,False,False,False,2,9,True," & Chr(34) & "Auto" & Chr(34) & ",1,False," & Chr(34) & "620" & Chr(34) & ",0.5,0.5,False,False)"
        'PAGE.SETUP(head, foot, left, right, top, bot, hdng, grid, h_cntr, v_cntr, orient, paper_size, scale, pg_num, pg_order, bw_cells, quality, head_margin, foot_margin, notes, draft)
        Application.ExecuteExcel4Macro sPageSetup
        
        
        'line 1 header
        SBInfo "Formatting excel wooksheet (Header line 1)"
        WriteCell "'A Subsidiary of BMW AG", 1, 1, BMWFont, 6, Regular, "right"
        .Range("A1").Select
        With Selection
            .VerticalAlignment = xlTop
            .WrapText = True
        End With
        WriteCell "'" & OrganisationDescription(CurrentOrganisation), 2, 1, BMWFont, 18, Bold, "left"
        WriteCell "'" & Year(P11DFromDate) & " - " & Year(P11DToDate), 8, 1, BMWFont, 18, Bold, "left"
        
        
        'line 2 employee header
        SBInfo "Formatting excel wooksheet (Header line 2)"
        WriteCell "'" & Format(EmployeeNo, "000000"), 1, 3, BMWFont, 10, Bold, "Left"
        WriteCell "'" & GetEmloyeeName(EmployeeNo), 4, 3, BMWFont, 10, Bold, "Left"
        WriteCell "'" & GetEmloyeeNI(EmployeeNo), 9, 3, BMWFont, 10, Bold, "Left"
        
        'line 3 Vehicles
        SBInfo "Formatting excel wooksheet (Header line 3)"
        WriteCell "'Vehicles", 1, 5, BMWFont, 10, Bold, "Left"
        WriteCell "'Mileage", 6, 6, BMWFont, 9, Bold, "left"
        WriteCell "'Loan", 14, 6, BMWFont, 9, Bold, "left"
        WriteCell "'Depreciation", 16, 6, BMWFont, 9, Bold, "left"
        SBInfo ".", True
        
        'column headers
        SBInfo "Formatting excel wooksheet (Column headers)"
        WriteCell "'From", 1, 7, BMWFont, 8, Bold, "left"
        WriteCell "'To", 2, 7, BMWFont, 8, Bold, "left"
        WriteCell "'PPN", 3, 7, BMWFont, 8, Bold, "left"
        WriteCell "'Reg No", 4, 7, BMWFont, 8, Bold, "left"
        WriteCell "'Model", 5, 7, BMWFont, 8, Bold, "left"
        WriteCell "'Business", 6, 7, BMWFont, 8, Bold, "left"
        WriteCell "'Private", 7, 7, BMWFont, 8, Bold, "left"
        WriteCell "'PMR", 8, 7, BMWFont, 8, Bold, "left"
        WriteCell "'Ins", 9, 7, BMWFont, 8, Bold, "left"
        WriteCell "'Maint", 10, 7, BMWFont, 8, Bold, "left"
        WriteCell "'RFL", 11, 7, BMWFont, 8, Bold, "left"
        WriteCell "'PDI", 12, 7, BMWFont, 8, Bold, "left"
        WriteCell "'Amount", 13, 7, BMWFont, 8, Bold, "left"
        WriteCell "'Benefit", 14, 7, BMWFont, 8, Bold, "left"
        WriteCell "'Residual", 15, 7, BMWFont, 8, Bold, "left"
        WriteCell "'Amount", 16, 7, BMWFont, 8, Bold, "left"
        WriteCell "'Benefit", 17, 7, BMWFont, 8, Bold, "left"
        WriteCell "'Fuel", 18, 7, BMWFont, 8, Bold, "left"
        WriteCell "'Total", 19, 7, BMWFont, 8, Bold, "left"
        
        'column widths
        SBInfo "Formatting excel wooksheet (Column widths)"
        .Columns(1).ColumnWidth = 9.14
        .Columns(2).ColumnWidth = 9.14
        .Columns(3).ColumnWidth = 3.71
        .Columns(4).ColumnWidth = 8.43
        .Columns(5).ColumnWidth = 11
        .Columns(6).ColumnWidth = 7.29
        .Columns(7).ColumnWidth = 5.75
        .Columns(8).ColumnWidth = 4
        .Columns(9).ColumnWidth = 3
        .Columns(10).ColumnWidth = 5
        .Columns(11).ColumnWidth = 4.3
        .Columns(12).ColumnWidth = 4.14
        .Columns(13).ColumnWidth = 6.86
        .Columns(14).ColumnWidth = 6.3
        .Columns(15).ColumnWidth = 6.86
        .Columns(16).ColumnWidth = 6.43
        .Columns(17).ColumnWidth = 6
        .Columns(18).ColumnWidth = 6.29
        .Columns(19).ColumnWidth = 8.43
        
    End With
End Sub
[TIP]laser draw effect
Private Declare Function GetTickCount Lib "Kernel32" () As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Dim stopMe As Boolean

Private Sub Command1_Click()
  Dim pCol As Long
  Dim pW As Long
  Dim pH As Long

  DisableButtons
  Picture2.Cls
  pW = Picture1.Width
  pH = Picture1.Height
  For X = 0 To pW - 1
    For Y = 0 To pH - 1
      pCol = GetPixel(Picture1.hDC, X, Y)
      Picture2.Line (pW, pH / 2)-(X, Y), pCol
      SetPixel Picture2.hDC, X, Y, pCol
    Next Y
    'Sleep 10
    Picture2.Refresh
    If stopMe = True Then
      stopMe = False
      EnableButtons
      Exit Sub
    End If
  Next X
  EnableButtons
End Sub
[TIP]list files and folders under a folder
Dim FSO As New FileSystemObject
Dim objFolders As Folders
Dim objFolder As Folder
Dim objFiles As Files
Dim objFile As File
Set objFolder = FSO.GetFolder("C:\")
Set objFolders = objFolder.SubFolders
Set objFiles = objFolder.Files



For Each objFolder In objFolders
    List1.AddItem objFolder.Name
Next



For Each objFile In objFiles
    List2.AddItem objFile.Name
Next

[TIP]capture screen to file (screen print)
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, _ ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Public Function Capture_Desktop(ByVal Destination$) as Boolean 

On Error goto errl 
DoEvents 
Call keybd_event(vbKeySnapshot, 1, 0, 0) 'Get the screen and copy it to clipboard 
DoEvents 'let computer catch up 
SavePicture Clipboard.GetData(vbCFBitmap), Destination$ ' saves the clipboard data to a BMP file 
Capture_Desktop = True 
Exit Function 
errl: 
Msgbox "Error number: " & err.number & ". " & err.description 
Capture_Desktop = False 
End Function 'A lil' example 
Private Sub Command1_Click() 
Capture_Desktop "c:\windows\desktop\desktop.bmp" 'That's it
[TIP]sleep API
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'Sleep (1000)
[TIP]get remote server time
option Explicit
                          '
                          '
                          private Declare Function NetRemoteTOD Lib "Netapi32.dll" ( _
                              tServer as Any, pBuffer as Long) as Long
                          '
                          private Type SYSTEMTIME
                              wYear as Integer
                              wMonth as Integer
                              wDayOfWeek as Integer
                              wDay as Integer
                              wHour as Integer
                              wMinute as Integer
                              wSecond as Integer
                              wMilliseconds as Integer
                          End Type
                          '
                          private Type TIME_ZONE_INFORMATION
                              Bias as Long
                              StandardName(32) as Integer
                              StandardDate as SYSTEMTIME
                              StandardBias as Long
                              DaylightName(32) as Integer
                              DaylightDate as SYSTEMTIME
                              DaylightBias as Long
                          End Type
                          '
                          private Declare Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation as TIME_ZONE_INFORMATION) as Long
                          '
                          private Declare Function NetApiBufferFree Lib "Netapi32.dll" (byval lpBuffer as Long) as Long
                          '
                          private Type TIME_OF_DAY_INFO
                              tod_elapsedt as Long
                              tod_msecs as Long
                              tod_hours as Long
                              tod_mins as Long
                              tod_secs as Long
                              tod_hunds as Long
                              tod_timezone as Long
                              tod_tinterval as Long
                              tod_day as Long
                              tod_month as Long
                              tod_year as Long
                              tod_weekday as Long
                          End Type
                          '
                          private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination as Any, Source as Any, byval Length as Long)
                          '
                          '
                          public Function getRemoteTOD(byval strServer as string) as date
                          '    
                              Dim result as date
                              Dim lRet as Long
                              Dim tod as TIME_OF_DAY_INFO
                              Dim lpbuff as Long
                              Dim tServer() as Byte
                          '
                              tServer = strServer & vbNullChar
                              lRet = NetRemoteTOD(tServer(0), lpbuff)
                          '    
                              If lRet = 0 then
                                  CopyMemory tod, byval lpbuff, len(tod)
                                  NetApiBufferFree lpbuff
                                  result = DateSerial(tod.tod_year, tod.tod_month, tod.tod_day) + _
                                  TimeSerial(tod.tod_hours, tod.tod_mins - tod.tod_timezone, tod.tod_secs)
                                  getRemoteTOD = result
                              else
                                  Err.Raise Number:=vbObjectError + 1001, _
                                  Description:="cannot get remote TOD"
                              End If
                          '
                          End Function

                          - to use in your program, call it like this : 


                          private Sub Command1_Click()
                              Dim d as date
                          '
                              d = GetRemoteTOD("your NT server name goes here")
                              MsgBox d
                          End Sub