最美我中文

作者：不详 　来源于：中国VB网 　发布时间：2007-3-7
希望大家好好看看，好多吧里的问题这里都能找到答案，资料是我从网络中搜集来的，今天先发上来一些，希望大家能够从中学到些东西

1. 如何消除textbox中按下回车时的beep声？
Private Sub Text1_KeyPress(KeyAscii As Integer)
  If KeyAscii = 13 Then
     KeyAscii = 0
  End If
End Sub

2.Textbox获得焦点时自动选中。
Private Sub Text1_GotFocus()
  Text1.SelStart = 0
  Text1.SelLength = Len(Text1.Text)
End Sub

3.屏蔽textbox控件自身的右键菜单，并显示自己的菜单。
方法一：
Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y _
As Single)
   If Button = 2 Then
     Text1.Enabled = False
     Text1.Enabled = True
     PopupMenu mymenu
   End If
End Sub

方法二：回调函数
module：
Option Explicit
Public OldWindowProc As Long ' 保存默认的窗口函数的地址
Public Const WM_CONTEXTMENU = &H7B ' 当右击文本框时，产生这条消息
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd _  
As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd _  As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
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
Public Function SubClass_WndMessage(ByVal hWnd As Long, ByVal Msg As Long, ByVal wp _
As Long, ByVal lp As Long) As Long
' 如果消息不是WM_CONTEXTMENU，就调用默认的窗口函数处理
If Msg <> WM_CONTEXTMENU Then
   SubClass_WndMessage = CallWindowProc(OldWindowProc, hWnd, Msg, wp, lp)
   Exit Function
End If
SubClass_WndMessage = True
End Function
窗体中：
Private Const GWL_WNDPROC = (-4)
Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y _  
As Single)
If Button = 1 Then Exit Sub
   OldWindowProc = GetWindowLong(Text1.hWnd, GWL_WNDPROC) ' 取得窗口函数的地址
      ' 用SubClass_WndMessage代替窗口函数处理消息
   Call SetWindowLong(Text1.hWnd, GWL_WNDPROC, AddressOf SubClass_WndMessage)
End Sub
Private Sub Text1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  If Button = 1 Then Exit Sub
    ' 恢复窗口的默认函数
    Call SetWindowLong(Text1.hWnd, GWL_WNDPROC, OldWindowProc)
    PopupMenu mymenu
End Sub

4. 设置TEXTBOX为只读属性
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd _
As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd _ As Long, ByVal nIndex As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const EM_SETREADONLY = &HCF
Private Sub Command1_Click()
  Dim l As Long
  If (GetWindowLong(Text1.hwnd, GWL_STYLE) And &H800) Then
     Text1.Text = "This is a read/write text box."   '文本窗口是只读窗口,设置为可读写窗口
     l = SendMessage(Text1.hwnd, EM_SETREADONLY, False, vbNull)
     Text1.BackColor = RGB(255, 255, 255)   '将背景设置为白色
     Command1.Caption = "Read&Write"
Else
     Text1.Text = "This is a readonly text box."    '文本窗口是可读写窗口,设置为只读窗口
     l = SendMessage(Text1.hwnd, EM_SETREADONLY, True, vbNull)
     Text1.BackColor = vbInactiveBorder   '将背景设置为灰色
     Command1.Caption = "&ReadOnly"
  End If
End Sub

5. 利用API函数MessageBox代替MSGBOX函数可以使得Timer控件正常工作

Private Declare Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As _ Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
Private Sub Command1_Click()
   MsgBox "时钟变的无效了"
End Sub
Private Sub Command2_Click()
   MessageBox Me.hwnd, "时钟正常运行", "hehe", 0
End Sub
Private Sub Timer1_Timer()
  Static i As Integer
  i = i + 1
  Text1.Text = i
End Sub

Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal _ hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal Cx As Long, ByVal Cy _
As Long, ByVal wFlags As Long) As Long
Public Sub SetOnTop(ByVal IsOnTop As Integer)
Dim rtn As Long
    If IsOnTop = 1 Then   
        rtn = SetWindowPos(Form1.hwnd, -1, 0, 0, 0, 0, 3)
    Else
        rtn = SetWindowPos(Form1.hwnd, -2, 0, 0, 0, 0, 3)
    End If
End Sub
Private Sub Command1_Click()
  SetOnTop 1   '将窗口置于最上面
End Sub
Private Sub Command2_Click()
  SetOnTop 0
End Sub

7.只容许运行一个程序实例（利用互斥体）

选择启动对象为sub main()
module:
Public Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexA" _ (lpMutexAttributes As SECURITY_ATTRIBUTES, ByVal bInitialOwner As Long, ByVal lpName _
As String) As Long
Public Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
End Type
Public Const ERROR_ALREADY_EXISTS = 183&
Private Sub Main()
    Dim sa As SECURITY_ATTRIBUTES
    sa.bInheritHandle = 1
    sa.lpSecurityDescriptor = 0
    sa.nLength = Len(sa)
    Debug.Print CreateMutex(sa, 1, App.Title)  '这一行可千万不能删除啊
    Debug.Print Err.LastDllError
    If (Err.LastDllError = ERROR_ALREADY_EXISTS) Then
        MsgBox "More than one instance"
    Else
    Form1.Show
    End If
End Sub

8.窗体标题栏闪烁
Option Explicit
Private Declare Function FlashWindow Lib "user32" (ByVal hwnd As Long, ByVal bInvert _
As Long) As Long
Private Sub tmrFlash_Timer()
    Static mFlash As Boolean
    FlashWindow hwnd, Not mFlash
End Sub

8.  拷屏

方法一：利用模拟键盘
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, _ ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Const theScreen = 1
Const theForm = 0
Private Sub Command1_Click()
Call keybd_event(vbKeySnapshot, theForm, 0, 0)  '若theForm改成theScreen则Copy整个Screen
DoEvents
Picture1.Picture = Clipboard.GetData(vbCFBitmap)
End Sub

9. 为程序注册热键

方法一：修改注册表
Private Declare Function RegisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id _
As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
Private Declare Function UnregisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id _
As Long) As Long
Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, _ ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal _ wRemoveMsg As Long) As Long
Private Declare Function WaitMessage Lib "user32" () As Long
Private Type POINTAPI
    x As Long
    y As Long
End Type
Private Type Msg
    hWnd As Long
    Message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type
'  声明常数
Private Const MOD_ALT = &H1
Private Const MOD_CONTROL = &H2
Private Const MOD_SHIFT = &H4
Private Const PM_REMOVE = &H1
Private Const WM_HOTKEY = &H312
Private HotKey_Fg As Boolean
Private Sub Form_Load()
    Dim Message As Msg
    '注册 Ctrl+Y 为热键
    RegisterHotKey Me.hWnd, &HBFFF&, MOD_CONTROL, vbKeyY
    'RegisterHotKey Me.hWnd, &HBFF2&, MOD_CONTROL, vbKeyU
    Me.Show
    Form1.Hide
    '等待处理消息
    HotKey_Fg = False
    Do While Not HotKey_Fg
        '等待消息
        WaitMessage
        '检查是否热键被按下
        If PeekMessage(Message, Me.hWnd, WM_HOTKEY, WM_HOTKEY, PM_REMOVE) Then
            Form1.Show 1
            End If
        '转让控制权,允许操作系统处理其他事件
        DoEvents
    Loop
End Sub
Private Sub Form_Unload(Cancel As Integer)
    HotKey_Fg = True
    '撤销热键的注册
    Call UnregisterHotKey(Me.hWnd, &HBFFF&)
End Sub

方法二：SendMessage
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As _ Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_SETHOTKEY = &H32
Private Const HOTKEYF_SHIFT = &H1
Private Const HOTKEYF_ALT = &H4
Private Sub Form_Load()
   Dim l As Long
   Dim wHotkey As Long
   wHotkey = (HOTKEYF_ALT) * (2 ^ 8) + 65  '定义ALT+A为热键
   l = SendMessage(Me.hwnd, WM_SETHOTKEY, wHotkey, 0)
End Sub

10.在状态栏显示无边框窗体图标。
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd _ As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd _ As Long, ByVal nIndex As Long) As Long
Const GWL_STYLE = (-16&)
Const WS_SYSMENU = &H80000
Private Sub Form_Load()
'Make Form's Icon visible in the taskbar
SetWindowLong Me.hWnd, GWL_STYLE, GetWindowLong(Me.hWnd, GWL_STYLE) Or WS_SYSMENU
End Sub

11. 记录窗体的大小及位置和程序中的一些设置
Private Sub Form_Load()
    Me.Width = GetSetting(App.Title, Me.Name, "Width", 7200)
    Me.Height = GetSetting(App.Title, Me.Name, "Height", 6300)
    Me.Top = GetSetting(App.Title, Me.Name, "Top", 100)
    Me.Left = GetSetting(App.Title, Me.Name, "Left", 100)
    Check1.Value = GetSetting(App.Title, Me.Name, "check1", 0)
End Sub
Private Sub Form_Unload(Cancel As Integer)
    Call SaveSetting(App.Title, Me.Name, "Width", Me.Width)
    Call SaveSetting(App.Title, Me.Name, "Height", Me.Height)
    Call SaveSetting(App.Title, Me.Name, "Top", Me.Top)
    Call SaveSetting(App.Title, Me.Name, "Left", Me.Left)
    Call SaveSetting(App.Title, Me.Name, "check1", Check1.Value)
End Sub

12. 解决mschart控件数据更改时的闪动现象
1、在有MSChart控件的窗体中另外加入一个PictureBox控件，如MSChart1和Picture1。  
2、使Picture1和MSChart1大小一致，位置相同（通过左对齐和顶端对齐）。  
3、使Picture1在MSChart1前端，设置Picture1的Visible为False，即不可见。只有刷新数据时Picture1才显示。  
'刷新数据过程  
Private Sub Refresh()  
Dim V_newchar() 'n维数组  
……  
Picture1.Visible = True  
MSChart1.ChartData = V_newchar '给MSChart1重新赋值,即刷新数据  
MSChart1.EditCopy '将当前图表的图片复制到剪贴板中  
Picture1.Picture = Clipboard.GetData() '给Picture1赋值剪贴板中的图片  
End Sub  
这样每一次刷新数据时Picture1显示的图片都不会产生闪烁现象

13.  无边框窗体的右键菜单
设计无边框窗体时，如果使用菜单编辑器，就会自动改变成有边框的窗体，此时，可以在另外一个窗体中（一般情况下你的程序应该不止一个窗体的吧，如果真的只有一个，可以利用其他人写的类，添加右键）编辑菜单（VISIBLE属性设为FALSE），然后在本窗体中调用。调用形式如下：
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then
PopupMenu Form2.mymenu
End If
End Sub

14.创建圆角无边框窗体
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Integer, ByVal Y1 _ As Integer, ByVal X2 As Integer, ByVal Y2 As Integer, ByVal x3 As Integer, ByVal y3 As _ Integer) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hrgn As _ Long, ByVal bRedraw As Boolean) As Long
Private Sub Form_Load()
     hround = CreateRoundRectRgn(0, 0, ScaleX(Form1.ScaleWidth, vbTwips, vbPixels), _ ScaleY(Form1.ScaleHeight, vbTwips, vbPixels), 20, 20)
SetWindowRgn Me.hwnd, hround, True
DeleteObject hround
End Sub

15.拖动没有标题栏的窗体
方法一：
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As _ Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const HTCAPTION = 2
Private Const WM_NCLBUTTONDOWN = &HA1
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
   Dim ncl As Long
   Dim rel As Long
   If Button = 1 Then
     i = ReleaseCapture()
     ncl = SendMessage(hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
   End If
End Sub
方法二：回调函数
module:
Public Const GWL_WNDPROC = (-4)
Public Const WM_NCHITTEST = &H84
Public Const HTCLIENT = 1
Public Const HTCAPTION = 2
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 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
Public prevWndProc As Long
Function WndProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal _Param As Long) As Long
   WndProc = CallWindowProc(prevWndProc, hWnd, Msg, wParam, lParam)
   If Msg = WM_NCHITTEST And WndProc = HTCLIENT Then
   WndProc = HTCAPTION
   End If
End Function
窗体中:
Private Sub Form_Load()
   prevWndProc = GetWindowLong(Me.hWnd, GWL_WNDPROC)
   SetWindowLong Me.hWnd, GWL_WNDPROC, AddressOf WndProc
End Sub
Private Sub Form_Unload(Cancel As Integer)
  SetWindowLong Me.hWnd, GWL_WNDPROC, prevWndProc
End Sub

最美我中文

16. 半透明窗体
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, _ ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2
Private Const GWL_EXSTYLE = (-20)
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal _
hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal _
hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Sub Form_Load()
   Dim rtn As Long
   rtn = GetWindowLong(Me.hwnd, GWL_EXSTYLE)  '取的窗口原先的样式
   rtn = rtn Or WS_EX_LAYERED    ' 使窗体添加上新的样式WS_EX_LAYERED
   SetWindowLong Me.hwnd, GWL_EXSTYLE, rtn   ' 把新的样式赋给窗体
   SetLayeredWindowAttributes Me.hwnd, 0, 200, LWA_ALPHA
End Sub

17.开机启动（函数及常数声明略）
Private Sub Form_Load()
   Dim hKey As Long, SubKey As String, Exe As String
   SubKey = "Software\Microsoft\Windows\CurrentVersion\Run"
   Exe = "可执行文件的路径"   
   RegCreateKey HKEY_CURRENT_USER, SubKey, hKey
   RegSetvalueEx hKey, "autorun", 0, REG_SZ, ByVal Exe,LenB(StrConv(Exe, vbFromUnicode)) + 1
   RegCloseKey hKey
End Sub

18.关闭显示器
Private Declare Function SendMessage Lib "user32" Alias  "SendMessageA" (ByVal hwnd _
As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Const WM_SYSCOMMAND = &H112&
Const SC_MONITORPOWER = &HF170&
Private Sub Command1_Click()
    SendMessage Me.hwnd, WM_SYSCOMMAND, SC_MONITORPOWER, ByVal 2& '关闭显示器
End Sub
Private Sub Command2_Click()
    SendMessage Me.hwnd, WM_SYSCOMMAND, SC_MONITORPOWER, ByVal -1& '打开显示器
End Sub

19. 在程序结束时自动关闭由SHELL打开的程序。
Private Const PROCESS_QUERY_INFORMATION = &H400  '关闭由SHELL函数打开的文件
Private Const PROCESS_TERMINATE = &H1
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, _ ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, _
ByVal uExitCode As Long) As Long
Dim ProcessId As Long
Private Sub Command1_Click()
    ProcessId = Shell("notepad.exe.", vbNormalFocus)
End Sub
Private Sub Form_Unload(Cancel As Integer)
    Dim hProcess  As Long
    hProcess = OpenProcess(PROCESS_TERMINATE Or PROCESS_QUERY_INFORMATION, False, _ ProcessId)
    Call TerminateProcess(hProcess, 3838)
End Sub

20. 关闭、重启计算机
Public Declare Function ExitWindowsEx Lib "user32" Alias "ExitWindowsEx" (ByVal _
uFlags As Long, ByVal dwReserved As Long) As Long
ExitWindowsEx 1，0 关机
ExitWindowsEx 0，1 重新启动

21.显示关机提示框
Private Declare Function SHRestartSystemMB Lib "shell32" Alias "#59" (ByVal hOwner _
As Long, ByVal sExtraPrompt As String,  

ByVal uFlags As Long) As Long
Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4
Const EWX_POWEROFF = 8
Private Sub Command1_Click()
SHRestartSystemMB Me.hWnd, PROMPT, EWX_LOGOFF
End Sub

22.右键托盘图标后必须点击他才可以消失，怎么办？
Case WM_RBUTTONUP '鼠标在图标上右击时弹出菜单
      SetForegroundWindow Me.hwnd
        Me.PopupMenu mnuTray
加一句 SetForegroundWindow Me.hwnd

23. 将progressbar嵌入statusbar中
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal _ hWndNewParent As Long) As Long
Private Sub Command1_Click()
    With ProgressBar1
        .Max = 1000
        Dim i As Integer
        For i = 1 To 1000
            .Value = i
        Next i
    End With
End Sub
Private Sub Form_Load()
    ProgressBar1.Appearance = ccFlat
    SetParent ProgressBar1.hWnd, StatusBar1.hWnd
    ProgressBar1.Left = StatusBar1.Panels(1).Left
    ProgressBar1.Top = 100
    ProgressBar1.Width = StatusBar1.Panels(1).Width - 50
    ProgressBar1.Height = StatusBar1.Height - 150
End Sub   '相对位置你可以自己再调一下

24.使你的程序界面具有XP风格
产生一个和你的可执行程序同名的后缀为exe.manifest的文件，并和可执行文件放在同一路径中。
代码中加入:
Private  Declare Sub InitCommonControls Lib "comctl32.dll" ()
Private Sub Form_Initialize()
    InitCommonControls
End Sub
注意：
1 工具栏控件一定要用Microsoft Windows Common Controls 5.0，而不要用Microsoft Windows Common Controls 6.0。因为此InitCommonControls API函数是位于comctl32.dll（Microsoft Windows Common Controls 5.0控件的动态链接库中）。
2 放在FRAME控件中的单远按钮有些“麻烦”！为了解决此问题，可以将单选按钮放在PICTURE控件中（以PICTURE控件作为容器），再将
PICTURE控件放在FRAME控件中，就可以了。
3 必须编译之后才能看到效果
exe.manifest文件中的内容，可用notepad编辑。
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
<assemblyIdentity
version="1.0.0.0"
processorArchitecture="X86"
name="CompanyName.ProductName.YourApp"
type="win32"
/>
<description>Your application description here.</description>
<dependency>
<dependentAssembly>
<assemblyIdentity
type="win32"
name="Microsoft.Windows.Common-Controls"
version="6.0.0.0"
processorArchitecture="X86"
publicKeyToken="6595b64144ccf1df"
language="*"
/>
</dependentAssembly>
</dependency>
</assembly>
25.如何打印PictureBox中的所有控件
添加另外一个PictureBox，然后：
Private Const WM_PAINT = &HF
Private Const WM_PRINT = &H317
Private Const PRF_CLIENT = &H4&
Private Const PRF_CHILDREN = &H10&
Private Const PRF_OWNED = &H20&
Private Const PHYSICALOFFSETX As Long = 112
Private Const PHYSICALOFFSETY As Long = 113
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd _
As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nindex _
As Long) As Long
private Sub Form_Load()
    Picture1.AutoRedraw = True
    Picture2.AutoRedraw = True
    Picture2.BorderStyle = 0
    Picture2.Visible = False
End Sub
Private Sub Command2_Click()
    Dim retval As Long, xmargin As Single, ymargin As Single
    Dim x As Single, y As Single
    x = 1: y = 1
    With Printer
      .ScaleMode = vbInches
      xmargin = GetDeviceCaps(.hdc, PHYSICALOFFSETX)
      xmargin = (xmargin * .TwipsPerPixelX) / 1440
      ymargin = GetDeviceCaps(.hdc, PHYSICALOFFSETY)
      ymargin = (ymargin * .TwipsPerPixelY) / 1440
      Picture2.Width = Picture1.Width
      Picture2.Height = Picture1.Height
      DoEvents
      Picture1.SetFocus
      retval = SendMessage(Picture1.hwnd, WM_PAINT, Picture2.hdc, 0)
      retval = SendMessage(Picture1.hwnd, WM_PRINT, Picture2.hdc, _
      PRF_CHILDREN + PRF_CLIENT + PRF_OWNED)
      DoEvents
      Printer.Print ""
      .PaintPicture Picture2.Image, x - xmargin, y - ymargin
      .EndDoc
      End With
End Sub

最美我中文

26.冒泡排序如下：
Sub BubbleSort(List() As Double)
Dim First As Double, Last As Double
Dim i As Integer, j As Integer
Dim Temp As Double
First = LBound(List)
Last = UBound(List)
For i = First To Last - 1
For j = i + 1 To Last
If List(i) > List(j) Then
Temp = List(j)
List(j) = List(i)
List(i) = Temp
End If
Next j
Next i
End Sub


27.清空回收站

Private Declare Function SHEmptyRecycleBin Lib "shell32.dll" Alias _
"SHEmptyRecycleBinA" (ByVal hwnd As Long, ByVal pszRootPath As String, _
ByVal dwFlags As Long) As Long
Private Declare Function SHUpdateRecycleBinIcon Lib "shell32.dll" () As Long
Private Const SHERB_NOCONFIRMATION = &H1
Private Const SHERB_NOPROGRESSUI = &H2
Private Const SHERB_NOSOUND = &H4
Private Sub Command1_Click()
Dim retval As Long  ' return value
    retval = SHEmptyRecycleBin(RecycleBin.hwnd, "", SHERB_NOPROGRESSUI) ' 清空回收站, 确认
    ' 若有错误出现，则返回回收站图示
        If retval <> 0 Then  ' error
        retval = SHUpdateRecycleBinIcon()
    End If
End Sub
Private Sub Command2_Click()
    Dim retval As Long  ' return value
    ' 清空回收站, 不确认
    retval = SHEmptyRecycleBin(RecycleBin.hwnd, "", SHERB_NOCONFIRMATION)
      ' 若有错误出现，则返回回收站图示
    If retval <> 0 Then  ' error
        retval = SHUpdateRecycleBinIcon()
    End If
    Command1_Click
End Sub


28.获得系统文件夹的路径
Private Declare Function GetSystemDirectory Lib "kernel32" Alias _
"GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Sub Command1_Click()
   Dim syspath As String
   Dim len5 As Long
   syspath = String(255, 0)
   len5 = GetSystemDirectory(syspath, 256)
   syspath = Left(syspath, InStr(1, syspath, Chr(0)) - 1)
   Debug.Print "System Path : "; syspath
End Sub


29.动态增加控件并响应事件
Option Explicit
    '通过使用WithEvents关键字声明一个对象变量为新的命令按钮
    Private WithEvents NewButton As CommandButton
   '增加控件
    Private Sub Command1_Click()
     If NewButton Is Nothing Then
     '增加新的按钮cmdNew
     Set NewButton = Controls.Add("VB.CommandButton", "cmdNew", Me)
     '确定新增按钮cmdNew的位置
      NewButton.Move Command1.Left + Command1.Width + 240, Command1.Top
      NewButton.Caption = "新增的按钮"
      NewButton.Visible = True
     End If
    End Sub
    '删除控件(注：只能删除动态增加的控件)
    Private Sub Command2_Click()
     If NewButton Is Nothing Then
      Else
      Controls.Remove NewButton
        Set NewButton = Nothing
       End If
    End Sub
    '新增控件的单击事件
    Private Sub NewButton_Click()
       MsgBox "您选中的是动态增加的按钮！"
    End Sub
   
30.得到磁盘序列号
Function GetSerialNumber(strDrive As String) As Long
  Dim SerialNum As Long
  Dim Res As Long
  Dim Temp1 As String
  Dim Temp2 As String
   Temp1 = String$(255, Chr$(0))
   Temp2 = String$(255, Chr$(0))
   Res = GetVolumeInformation(strDrive, Temp1, Len(Temp1), SerialNum, 0, 0, Temp2, _
Len(Temp2))
   GetSerialNumber = SerialNum
End Function
调用形式   Label1.Caption = GetSerialNumber("c:\")

31.打开屏幕保护
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd _
As Long, ByVal wMsg As Long, ByVal wParam  

As Long, lParam As Any) As Long
'我们将要调用的那个消息，在MSDN中搜索WM_SYSCOMMAND就可以找到具体说明
Const WM_SYSCOMMAND = &H112
'这个参数指明了我们让系统启动屏幕保护
Const SC_SCREENSAVE = &HF140&
Private Sub Command1_Click()
SendMessage Me.hwnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0
End Sub

最美我中文

32.获得本机IP地址
方法一：利用Winsock控件
winsockip.localip
方法二：
Private Const MAX_IP = 255
    Private Type IPINFO
     dwAddr As Long
     dwIndex As Long
     dwMask As Long
     dwBCastAddr As Long
     dwReasmSize As Long
     unused1 As Integer
     unused2 As Integer
    End Type
    Private Type MIB_IPADDRTABLE
     dEntrys As Long
     mIPInfo(MAX_IP) As IPINFO
    End Type
    Private Type IP_Array
     mBuffer As MIB_IPADDRTABLE
     BufferLen As Long
    End Type
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination _
As Any, Source As Any, ByVal Length As  

Long)
    Private Declare Function GetIpAddrTable Lib "IPHlpApi" (pIPAdrTable As Byte, _
pdwSize As Long, ByVal Sort As Long) As Long
    Dim strIP As String
    Private Function ConvertAddressToString(longAddr As Long) As String
     Dim myByte(3) As Byte
     Dim Cnt As Long
     CopyMemory myByte(0), longAddr, 4
     For Cnt = 0 To 3
     ConvertAddressToString = ConvertAddressToString + CStr(myByte(Cnt)) + "."
     Next Cnt
     ConvertAddressToString = Left$(ConvertAddressToString, Len(ConvertAddressToString) - 1)
    End Function
      
    Public Sub Start()
     Dim Ret As Long, Tel As Long
     Dim bBytes() As Byte
     Dim Listing As MIB_IPADDRTABLE
     On Error GoTo END1
     GetIpAddrTable ByVal 0&, Ret, True
     If Ret <= 0 Then Exit Sub
     ReDim bBytes(0 To Ret - 1) As Byte
     GetIpAddrTable bBytes(0), Ret, False
     CopyMemory Listing.dEntrys, bBytes(0), 4
     strIP = "你机子上有 " & Listing.dEntrys & " 个 IP 地址。" & vbCrLf
     strIP = strIP & "------------------------------------------------" & vbCrLf & vbCrLf
     For Tel = 0 To Listing.dEntrys - 1
     CopyMemory Listing.mIPInfo(Tel), bBytes(4 + (Tel * Len(Listing.mIPInfo(0)))), Len _(Listing.mIPInfo(Tel))
     strIP = strIP & "IP 地址 : " & ConvertAddressToString(Listing.mIPInfo(Tel).dwAddr)  & vbCrLf
     Next
     Exit Sub
END1:
     MsgBox "ERROR"
    End Sub
Private Sub Form_Load()
     Start
     MsgBox strIP
End Sub

33. 用键盘方向键控制COMBOX
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
        (ByVal hwnd As Long, _
        ByVal wMsg As Long, _
        ByVal wParam As Long, _
        lParam As Any) As Long
Const CB_SHOWDROPDOWN = &H14F
Dim bDrop As Boolean
Private isDo As Boolean
Private Sub Combo1_Click()
If Not isDo Then
        isDo = True                   '<----------回置状态
        Exit Sub
Else: MsgBox "safd"
    End If
End Sub
Private Sub Combo1_DropDown()
    bDrop = True
End Sub
Private Sub Combo1_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 40 Then
      isDo = False
        SendMessage Combo1.hwnd, CB_SHOWDROPDOWN, 1, 0
ElseIf KeyCode = 38 Then
      isDo = False
        If Combo1.ListIndex = 0 Then
            If bDrop Then
                bDrop = False
                SendMessage Combo1.hwnd, CB_SHOWDROPDOWN, 0, 0
            End If
        End If
    End If
End Sub
Private Sub Combo1_KeyUp(KeyCode As Integer, Shift As Integer)
If Combo1.Text = Combo1.List(0) Then
isDo = True
End If
End Sub
Private Sub Form_Load()
    isDo = True
    Combo1.AddItem "abcd"
    Combo1.AddItem "abcd1"
    Combo1.AddItem "abcd2"
    Combo1.AddItem "abcd3"
End Sub

最美我中文

35.VB下的CRC校验程序
一 计算法
计算法就是依据CRC校验码的产生原理来设计程序。其优点是模块代码少，修改灵活，可移植性好。其缺点为计算量大。为了便于理解，这里假

定了三位数据，而多项式码为A001(hex)。
　　在窗体上放置一命令按钮Command1，并添加如下代码：

　　Private Sub Command1_Click()
　　　Dim CRC() As Byte
　　　Dim d() As Byte '待传输数据
　　　ReDim d(2) As Byte
　　　d(0) = 123
　　　d(1) = 112
　　　d(2) = 135
　　　CRC = CRC16(d) '调用CRC16计算函数
　　　'CRC(0)为高位
　　　'CRC(1)为低位
　　End Sub
　　注意：在数据传输时CRC的低位可能在前，而高位在后。

　　Function CRC16(data() As Byte) As String
　　　Dim CRC16Lo As Byte, CRC16Hi As Byte　　　'CRC寄存器
　　　Dim CL As Byte, CH As Byte　　　　　　　　'多项式码&HA001
　　　Dim SaveHi As Byte, SaveLo As Byte
　　　Dim i As Integer
　　　Dim Flag As Integer
　　　CRC16Lo = &HFF
　　　CRC16Hi = &HFF
　　　CL = &H1
　　　CH = &HA0
　　　For i = 0 To UBound(data)
　　　　CRC16Lo = CRC16Lo Xor data(i) '每一个数据与CRC寄存器进行异或
　　　　For Flag = 0 To 7
　　　　　SaveHi = CRC16Hi
　　　　　SaveLo = CRC16Lo
　　　　　CRC16Hi = CRC16Hi \ 2　　　　　　'高位右移一位
　　　　　CRC16Lo = CRC16Lo \ 2　　　　　　'低位右移一位
　　　　　If ((SaveHi And &H1) = &H1) Then '如果高位字节最后一位为1
　　　　　　CRC16Lo = CRC16Lo Or &H80　　　'则低位字节右移后前面补1
　　　　　End If　　　　　　　　　　　　　 '否则自动补0
　　　　　If ((SaveLo And &H1) = &H1) Then '如果LSB为1，则与多项式码进行异或
　　　　　　CRC16Hi = CRC16Hi Xor CH
　　　　　　CRC16Lo = CRC16Lo Xor CL
　　　　　End If
　　　　Next Flag
　　　Next i
　　　Dim ReturnData(1) As Byte
　　　ReturnData(0) = CRC16Hi　　　　　　　'CRC高位
　　　ReturnData(1) = CRC16Lo　　　　　　　'CRC低位
　　　CRC16 = ReturnData
　　End Function

2．查表法
　　查表法的优缺点与计算法的正好相反。为了便于比较，这里所有的假定与计算法的完全相同，都而在窗体上放置一个Command1的按钮，其

代码部分与上面的也完全一致。下面只介绍CRC函数的编写源代码。

　　Private Function CRC16(data() As Byte) As String
　　　Dim CRC16Hi As Byte
　　　Dim CRC16Lo As Byte
　　　CRC16Hi = &HFF
　　　CRC16Lo = &HFF
　　　Dim i As Integer
　　　Dim iIndex As Long
　　　For i = 0 To UBound(data)
　　　　iIndex = CRC16Lo Xor data(i)
　　　　CRC16Lo = CRC16Hi Xor GetCRCLo(iIndex)　　　　'低位处理
　　　　CRC16Hi = GetCRCHi(iIndex)　　　　　　　　　　'高位处理
　　　Next i
　　　Dim ReturnData(1) As Byte
　　　ReturnData(0) = CRC16Hi　　　　'CRC高位
　　　ReturnData(1) = CRC16Lo　　　　'CRC低位
　　　CRC16 = ReturnData
　　End Function

　　'CRC低位字节值表
　　Function GetCRCLo(Ind As Long) As Byte
　　　GetCRCLo = Choose(Ind + 1, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40,  

&H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1,
&H81, &H40, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80,  

&H41, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H0,  

&HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H0, &HC1, &H81, &H40, &H1, &HC0,  

&H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H0, &HC1, &H81,  

&H40, &H1, &HC0, &H80, &H41, &H1, &HC0, _
&H80, &H41, &H0, &HC1, &H81, &H40, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80,  

&H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0,  

&HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H0, &HC1,  

&H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81,  

&H40, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H0, &HC1, &H81, &H40, &H1,  

&HC0, &H80, &H41, &H0, &HC1, &H81, &H40, &H1, &HC0, &H80, &H41, &H1, &HC0, &H80, &H41, &H0, &HC1, &H81, &H40)
　　End Function

　　'CRC高位字节值表
　　Function GetCRCHi(Ind As Long) As Byte
　　　GetCRCHi = Choose(Ind + 1, &H0, &HC0, &HC1, &H1, &HC3, &H3, &H2, &HC2, &HC6, &H6, &H7, &HC7, &H5, &HC5, &HC4, &H4,  

&HCC, &HC, &HD, &HCD, &HF, &HCF, &HCE, &HE, &HA, &HCA, &HCB, &HB, &HC9, &H9, &H8, &HC8, &HD8, &H18, &H19, &HD9, &H1B, &HDB,  

&HDA, &H1A, &H1E, &HDE, &HDF, &H1F, &HDD, &H1D, &H1C, &HDC, &H14, &HD4, &HD5, &H15, &HD7, &H17, &H16, &HD6, &HD2, &H12, &H13,  

&HD3, &H11, &HD1, &HD0, &H10, &HF0, &H30, &H31, &HF1, &H33, &HF3, &HF2, &H32, &H36, &HF6, &HF7, &H37, &HF5, &H35, &H34, &HF4,  

&H3C, &HFC, &HFD, &H3D, &HFF, &H3F, &H3E, &HFE, &HFA, &H3A, &H3B, &HFB, &H39, &HF9, &HF8, &H38, &H28, &HE8, &HE9, &H29, &HEB,  

&H2B, &H2A, &HEA, &HEE, &H2E, &H2F, &HEF, &H2D, &HED, &HEC, &H2C, &HE4, &H24, &H25, &HE5, &H27, &HE7, &HE6, &H26, &H22, &HE2,  

&HE3, &H23, &HE1, &H21, &H20, &HE0, &HA0, &H60, _
&H61, &HA1, &H63, &HA3, &HA2, &H62, &H66, &HA6, &HA7, &H67, &HA5, &H65, &H64, &HA4, &H6C, &HAC, &HAD, &H6D, &HAF, &H6F, &H6E,  

&HAE, &HAA, &H6A, &H6B, &HAB, &H69, &HA9, &HA8, &H68, &H78, &HB8, &HB9, &H79, &HBB, &H7B, &H7A, &HBA, &HBE, &H7E, &H7F, &HBF,  

&H7D, &HBD, &HBC, &H7C, &HB4, &H74, &H75, &HB5, &H77, &HB7, &HB6, &H76, &H72, &HB2, &HB3, &H73, &HB1, &H71, &H70, &HB0, &H50,  

&H90, &H91, &H51, &H93, &H53, &H52, &H92, &H96, &H56, &H57, &H97, &H55, &H95, &H94, &H54, &H9C, &H5C, &H5D, &H9D, &H5F, &H9F,  

&H9E, &H5E, &H5A, &H9A, &H9B, &H5B, &H99, &H59, &H58, &H98, &H88, &H48, &H49, &H89, &H4B, &H8B, &H8A, &H4A, &H4E, &H8E, &H8F,  

&H4F, &H8D, &H4D, &H4C, &H8C, &H44, &H84, &H85, &H45, &H87, &H47, &H46, &H86, &H82, &H42, &H43, &H83, &H41, &H81, &H80, &H40)
　　End Function


36.如何打开光驱
Public Declare Function CDdoor Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString
As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Call CDdoor("set CDAudio door open", 0, 0, 0) '打开光驱
Call CDdoor("set CDAudio door closed", 0, 0, 0) '关闭光驱

36.检测是否以联网及联网方式
module:
Public Declare Function InternetGetConnectedStateEx Lib "wininet.dll" _
Alias "InternetGetConnectedStateExA" _
(ByRef lpdwFlags As Long, _
ByVal lpszConnectionName As String, _
ByVal dwNameLen As Long, _
ByVal dwReserved As Long _
) As Long

Public Enum EIGCInternetConnectionState
INTERNET_CONNECTION_MODEM = &H1&
INTERNET_CONNECTION_LAN = &H2&
INTERNET_CONNECTION_PROXY = &H4&
INTERNET_RAS_INSTALLED = &H10&
INTERNET_CONNECTION_OFFLINE = &H20&
INTERNET_CONNECTION_CONFIGURED = &H40&
End Enum

Public Property Get InternetConnected( _
Optional ByRef eConnectionInfo As EIGCInternetConnectionState, _
Optional ByRef sConnectionName As String _
) As Boolean
Dim dwFlags As Long
Dim sNameBuf As String
Dim lR As Long
Dim iPos As Long
  
sNameBuf = String$(513, 0)
lR = InternetGetConnectedStateEx(dwFlags, sNameBuf, 512, 0&)
eConnectionInfo = dwFlags
iPos = InStr(sNameBuf, vbNullChar)
If iPos > 0 Then
sConnectionName = Left$(sNameBuf, iPos - 1)
ElseIf Not sNameBuf = String$(513, 0) Then
sConnectionName = sNameBuf
End If
InternetConnected = (lR = 1)
End Property
窗体中
Private Sub Form_Load()
' Determine whether we have a connection:
bConnected = InternetConnected(eR, sName)

' The connection state info parameter provides details
' about how we connect:
If (eR And INTERNET_CONNECTION_MODEM) = INTERNET_CONNECTION_MODEM Then
sMsg = sMsg & "Connection uses a modem." & vbCrLf
End If
If (eR And INTERNET_CONNECTION_LAN) = INTERNET_CONNECTION_LAN Then
sMsg = sMsg & "Connection uses LAN." & vbCrLf
End If
If (eR And INTERNET_CONNECTION_PROXY) = INTERNET_CONNECTION_PROXY Then
sMsg = sMsg & "Connection is via Proxy." & vbCrLf
End If
If (eR And INTERNET_CONNECTION_OFFLINE) = INTERNET_CONNECTION_OFFLINE Then
sMsg = sMsg & "Connection is Off-line." & vbCrLf
End If
If (eR And INTERNET_CONNECTION_CONFIGURED) = INTERNET_CONNECTION_CONFIGURED Then
sMsg = sMsg & "Connection is Configured." & vbCrLf
Else
sMsg = sMsg & "Connection is Not Configured." & vbCrLf
End If
If (eR And INTERNET_RAS_INSTALLED) = INTERNET_RAS_INSTALLED Then
sMsg = sMsg & "System has RAS installed." & vbCrLf
End If
  
' Display the connection name and info:
If bConnected Then
Text1.Text = "Connected: " & sName & vbCrLf & vbCrLf & sMsg
Else
Text1.Text = "Not Connected: " & sName & vbCrLf & vbCrLf & sMsg
End If
End Sub

最美我中文

37.得到当前windows的版本号

module:
Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128 ' Maintenance string for PSS usage
End Type
Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
End Sub
41.如何在小画面上显示大图片
方法一：
一个picturebox控件，一个image控件（以picturebox为容器），图片加载在image中，一个HScroll1，VScroll1（以picturebox为容器）。
Private Sub Bar1_Change()
Image1.Left = -bar1.Value
End Sub

Private Sub Bar2_Change()
Image1.Top = -Bar2.Value
End Sub

Private Sub Form_Load()
Image1.Left = 0
Image1.Top = 0
bar1.SmallChange = 300
Bar2.SmallChange = 300
bar1.Max = Image1.Width - Picture1.Width
Bar2.Max = Image1.Height - Picture1.Height
bar1.Min = 0
Bar2.Min = 0
End Sub


方法二：利用鼠标移动图片
一个picturebox控件，一个image控件（以picturebox为容器），图片加载在image中
Dim ix As Integer
Dim iy As Integer
Private Sub Form_Load()
Image1.Left = 0
Image1.Top = 0
End Sub
Private Sub Image1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbLeftButton Then
ix = X
iy = Y
End If
End Sub
Private Sub Image1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim ipx As Integer
Dim ipy As Integer
If Button = vbLeftButton Then
ipx = Image1.Left + X - ix
ipy = Image1.Top + Y - iy
If ipx > 0 Then
Image1.Left = 0
Else
If ipx < Picture1.Width - Image1.Width Then
ipx = Picture1.Width - Image1.Width
Else
Image1.Left = ipx
End If
End If
If ipy > 0 Then
Image1.Top = 0
Else
If ipy < Picture1.Height - Image1.Height Then
ipy = Picture1.Height - Image1.Height
Else
Image1.Top = ipy
End If
End If
End If
End Sub
Private Sub Image1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Me.MousePointer = 0
End Sub

42. 使窗体不出屏幕左边界
module:
Option Explicit
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long
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 Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" ( _
lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Public Const GWL_WNDPROC = (-4)
Public Const WM_WINDOWPOSCHANGING = &H46
Type WINDOWPOS
hwnd As Long
hWndInsertAfter As Long
x As Long
y As Long
cx As Long
cy As Long
flags As Long
End Type
Public preWinProc As Long
'而重点就在於Window重新定位之前会传
'出WM_WINDOWPOSCHANGING这个讯息，而lParam指向一个WINDOWPOS的STRUCTURE。
Public Function wndproc(ByVal hwnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lwd As Long, hwd As Long
If Msg = WM_WINDOWPOSCHANGING Then
Dim WPOS As WINDOWPOS
CopyMemory WPOS, ByVal lParam, Len(WPOS)
If WPOS.x < 0 Then
WPOS.x = 0
CopyMemory ByVal lParam, WPOS, Len(WPOS)
End If
End If
'将之送往原来的Window Procedure
wndproc = CallWindowProc(preWinProc, hwnd, Msg, wParam, lParam)
End Function
窗体中
Sub Form_Load()
Dim ret As Long
'记录原本的Window Procedure的位址
preWinProc = GetWindowLong(Me.hwnd, GWL_WNDPROC)
ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf wndproc)
End Sub

Private Sub Form_Unload(Cancel As Integer)
Dim ret As Long
'取消Message的截取，而使之又只送往原来的Window Procedure
ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, preWinProc)
End Sub

最美我中文

43.打开指定的窗体
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
Const SW_SHOWNORMAL = 1
Private Sub Command1_Click() '我的文档
ShellExecute Me.hwnd, "open", "explorer", vbNullString, vbNullString, 1
End Sub
Private Sub Command2_Click() '我的电脑
ShellExecute Me.hwnd, "open", "explorer", "::{20D04FE0-3AEA-1069-A2D8-08002B30309D}", vbnulstring, 1
End Sub
Private Sub Command3_Click() '网上邻居
ShellExecute Me.hwnd, "open", "explorer", "::{208d2c60-3aea-1069-a2d7-08002b30309d}", vbNullString, 1
End Sub
Private Sub Command4_Click() '回收站
ShellExecute Me.hwnd, "open", "explorer", "::{645ff040-5081-101b-9f08-00aa002f954e}", vbNullString, 1
End Sub
Private Sub Command5_Click() '控制面板
ShellExecute Me.hwnd, "open", "explorer", "::{21ec2020-3aea-1069-a2dd-08002b30309d}", vbNullString, 1
End Sub
Private Sub Command6_Click() '打开指定的路径
ShellExecute Me.hwnd, "open", "D:\vb练习事例", vbNullString, vbNullString, 1
End Sub
Private Sub Command7_Click() '音量控制
Shell "sndvol32.exe", vbNormalFocus
End Sub

44.窗体分割条

splitter为一picturebox控件。
Option Explicit
Private Const SPLT_WDTH As Integer = 35
Private currSplitPosX As Long
Dim CTRL_OFFSET As Integer
Dim SPLT_COLOUR As Long
Private Sub Form_Load()
CTRL_OFFSET = 5
SPLT_COLOUR = &H808080
currSplitPosX = &H7FFFFFFF
ListLeft.AddItem "VB俱乐部"
ListLeft.AddItem "VB动画篇"
ListLeft.AddItem "VB网络篇"
ListLeft.AddItem "VB控件类"
ListLeft.AddItem "VB界面类"
TextRight = "经常见到窗体上有二个相邻的列表框，可以用鼠标任意拉动中间分割条，改变列表框大小。"
End Sub
Private Sub Form_Resize()
Dim x1 As Integer
Dim x2 As Integer
Dim height1 As Integer
Dim width1 As Integer
Dim width2 As Integer
On Error Resume Next
height1 = ScaleHeight - (CTRL_OFFSET * 2)
x1 = CTRL_OFFSET
width1 = ListLeft.Width
x2 = x1 + ListLeft.Width + SPLT_WDTH - 1
width2 = ScaleWidth - x2 - CTRL_OFFSET
ListLeft.Move x1% - 1, CTRL_OFFSET, width1, height1
TextRight.Move x2, CTRL_OFFSET, width2 + 1, height1
Splitter.Move x1 + ListLeft.Width - 1, CTRL_OFFSET, SPLT_WDTH, height1
End Sub
Private Sub Splitter_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbLeftButton Then
Splitter.BackColor = SPLT_COLOUR
currSplitPosX = CLng(X)
Else
If currSplitPosX <> &H7FFFFFFF Then Splitter_MouseUp Button, Shift, X, Y
currSplitPosX = &H7FFFFFFF
End If
End Sub
Private Sub Splitter_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If currSplitPosX& <> &H7FFFFFFF Then
If CLng(X) <> currSplitPosX Then
Splitter.Move Splitter.Left + X, CTRL_OFFSET, SPLT_WDTH, ScaleHeight - (CTRL_OFFSET * 2)
currSplitPosX = CLng(X)
End If
End If
End Sub
Private Sub Splitter_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If currSplitPosX <> &H7FFFFFFF Then
If CLng(X) <> currSplitPosX Then
Splitter.Move Splitter.Left + X, CTRL_OFFSET, SPLT_WDTH, ScaleHeight - (CTRL_OFFSET * 2)
End If
currSplitPosX = &H7FFFFFFF
Splitter.BackColor = &H8000000F
If Splitter.Left > 60 And Splitter.Left < (ScaleWidth - 60) Then
ListLeft.Width = Splitter.Left - ListLeft.Left
ElseIf Splitter.Left < 60 Then
ListLeft.Width = 60
Else
ListLeft.Width = ScaleWidth - 60
End If
Form_Resize
End If

End Sub


44.托盘程序
module:
Option Explicit
Public preWinProc As Long
Public NewForm As Form
Public NewMenu As Menu
Public Const WM_USER = &H400
Public Const WM_LBUTTONUP = &H202
Public Const WM_MBUTTONUP = &H208
Public Const WM_RBUTTONUP = &H205
Public Const TRAY_CALLBACK = (WM_USER + 1001&)
Public Const GWL_WNDPROC = (-4)
Public Const GWL_USERDATA = (-21)
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const NIM_ADD = &H0
Public Const NIF_MESSAGE = &H1
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &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 SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Public Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
szTip As String * 64
End Type
Private NOTI As NOTIFYICONDATA
Public Function NewWindone(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If Msg = TRAY_CALLBACK Then
  
If lParam = WM_LBUTTONUP Then
' 单击左键，弹出窗口
If NewForm.WindowState = vbMinimized Then _
NewForm.WindowState = NewForm.LastState
NewForm.SetFocus
Exit Function
End If
If lParam = WM_RBUTTONUP Then
' 单击右键，弹出菜单
NewForm.PopupMenu NewMenu
Exit Function
End If
End If
NewWindone = CallWindowProc(preWinProc, hwnd, Msg, wParam, lParam)
End Function
Public Sub AddToTray(frm As Form, mnu As Menu)
Set NewForm = frm
Set NewMenu = mnu
preWinProc = SetWindowLong(frm.hwnd, GWL_WNDPROC, AddressOf NewWindone)
With NOTI
.uID = 0
.hwnd = frm.hwnd
.cbSize = Len(NOTI)
.hIcon = frm.Icon.Handle
.uFlags = NIF_ICON
.uCallbackMessage = TRAY_CALLBACK
.uFlags = .uFlags Or NIF_MESSAGE
.cbSize = Len(NOTI)
End With
Shell_NotifyIcon NIM_ADD, NOTI
End Sub
'屏蔽托盘
Public Sub RemoveFromTray()
With NOTI
.uFlags = 0
End With
Shell_NotifyIcon NIM_DELETE, NOTI
SetWindowLong NewForm.hwnd, GWL_WNDPROC, preWinProc
End Sub

Public Sub SetTrayTip(tip As String)
With NOTI
.szTip = tip & vbNullChar
.uFlags = NIF_TIP
End With
Shell_NotifyIcon NIM_MODIFY, NOTI
End Sub

Public Sub SetTrayIcon(pic As Picture)
If pic.Type <> vbPicTypeIcon Then Exit Sub
With NOTI
.hIcon = pic.Handle
.uFlags = NIF_ICON
End With
Shell_NotifyIcon NIM_MODIFY, NOTI
End Sub
窗体中

Private Sub Form_Load()
AddToTray Me, Tray
SetTrayTip "托盘演示"
End Sub
Private Sub Form_Unload(Cancel As Integer)
RemoveFromTray
End Sub

最美我中文

45.led数值显示
添加类模块：（name属性为mcLCD）
Option Explicit
Private Type Coordinate
X As Integer
Y As Integer
End Type
Dim BasePoint As Coordinate
Dim SegWidth As Integer
Dim SegHeight As Integer
Dim p As PictureBox
Property Let BackColor(Color As Long)
p.BackColor = Color
End Property
Private Sub DrawNumber(Number As Integer)
Select Case Number
Case 0
DrawSegment (1): DrawSegment (2): DrawSegment (3): DrawSegment (4)
DrawSegment (5): DrawSegment (6)
Case 1
DrawSegment (2): DrawSegment (3)
Case 2
DrawSegment (1): DrawSegment (2): DrawSegment (7): DrawSegment (5)
DrawSegment (4)
Case 3
DrawSegment (1): DrawSegment (2): DrawSegment (7): DrawSegment (3)
DrawSegment (4)
Case 4
DrawSegment (2): DrawSegment (3): DrawSegment (7): DrawSegment (6)
Case 5
DrawSegment (1): DrawSegment (6): DrawSegment (7): DrawSegment (3)
DrawSegment (4)
Case 6
DrawSegment (1): DrawSegment (6): DrawSegment (7): DrawSegment (3)
DrawSegment (4): DrawSegment (5)
Case 7
DrawSegment (1): DrawSegment (2)
DrawSegment (3)
Case 8
DrawSegment (1): DrawSegment (2): DrawSegment (3): DrawSegment (4)
DrawSegment (5): DrawSegment (6): DrawSegment (7)
Case 9
DrawSegment (1): DrawSegment (2): DrawSegment (3): DrawSegment (4)
DrawSegment (6): DrawSegment (7)
End Select
End Sub
Private Sub DrawSegment(SegNum As Integer)
' 1
' ___
' | |
' 6 | | 2
' |-7-|
' 5 | | 3
' |___|
'
' 4
'画出七段数码管的七个组成部分
Select Case SegNum
Case 1
p.Line (BasePoint.X + 1, BasePoint.Y)-(BasePoint.X + SegWidth - 1, BasePoint.Y)
p.Line (BasePoint.X + 2, BasePoint.Y + 1)-(BasePoint.X + SegWidth - 2, BasePoint.Y + 1)
p.Line (BasePoint.X + 3, BasePoint.Y + 2)-(BasePoint.X + SegWidth - 3, BasePoint.Y + 2)
Case 2
p.Line (BasePoint.X + SegWidth - 1, BasePoint.Y + 1)-(BasePoint.X + SegWidth - 1, BasePoint.Y + (SegHeight \ 2) - 1)
p.Line (BasePoint.X + SegWidth - 2, BasePoint.Y + 2)-(BasePoint.X + SegWidth - 2, BasePoint.Y + (SegHeight \ 2))
p.Line (BasePoint.X + SegWidth - 3, BasePoint.Y + 3)-(BasePoint.X + SegWidth - 3, BasePoint.Y + (SegHeight \ 2) - 1)
Case 3
p.Line (BasePoint.X + SegWidth - 1, BasePoint.Y + (SegHeight \ 2) + 2)-(BasePoint.X + SegWidth - 1, BasePoint.Y + SegHeight)
p.Line (BasePoint.X + SegWidth - 2, BasePoint.Y + (SegHeight \ 2) + 1)-(BasePoint.X + SegWidth - 2, BasePoint.Y + SegHeight - 1)
p.Line (BasePoint.X + SegWidth - 3, BasePoint.Y + (SegHeight \ 2) + 2)-(BasePoint.X + SegWidth - 3, BasePoint.Y + SegHeight - 2)
Case 4
p.Line (BasePoint.X + 3, BasePoint.Y + SegHeight - 2)-(BasePoint.X + SegWidth - 3, BasePoint.Y + SegHeight - 2)
p.Line (BasePoint.X + 2, BasePoint.Y + SegHeight - 1)-(BasePoint.X + SegWidth - 2, BasePoint.Y + SegHeight - 1)
p.Line (BasePoint.X + 1, BasePoint.Y + SegHeight)-(BasePoint.X + SegWidth - 1, BasePoint.Y + SegHeight)
Case 5
p.Line (BasePoint.X, BasePoint.Y + (SegHeight \ 2) + 2)-(BasePoint.X, BasePoint.Y + SegHeight)
p.Line (BasePoint.X + 1, BasePoint.Y + (SegHeight \ 2) + 1)-(BasePoint.X + 1, BasePoint.Y + SegHeight - 1)
p.Line (BasePoint.X + 2, BasePoint.Y + (SegHeight \ 2) + 2)-(BasePoint.X + 2, BasePoint.Y + SegHeight - 2)
Case 6
p.Line (BasePoint.X, BasePoint.Y + 1)-(BasePoint.X, BasePoint.Y + (SegHeight \ 2) - 1)
p.Line (BasePoint.X + 1, BasePoint.Y + 2)-(BasePoint.X + 1, BasePoint.Y + (SegHeight \ 2))
p.Line (BasePoint.X + 2, BasePoint.Y + 3)-(BasePoint.X + 2, BasePoint.Y + (SegHeight \ 2) - 1)
Case 7
p.Line (BasePoint.X + 3, BasePoint.Y + (SegHeight \ 2) - 1)-(BasePoint.X + SegWidth - 3, BasePoint.Y + (SegHeight \ 2) - 1)
p.Line (BasePoint.X + 2, BasePoint.Y + (SegHeight \ 2))-(BasePoint.X + SegWidth - 2, BasePoint.Y + (SegHeight \ 2))
p.Line (BasePoint.X + 3, BasePoint.Y + (SegHeight \ 2) + 1)-(BasePoint.X + SegWidth - 3, BasePoint.Y + (SegHeight \ 2) + 1)
End Select
End Sub
Public Property Let Caption(ByVal Value As String)
Dim OrigX As Integer
OrigX = BasePoint.X
p.Cls
While Value <> ""
If Left$(Value, 1) <> ":" And Left$(Value, 1) <> "." Then
DrawNumber (Val(Left$(Value, 1)))
BasePoint.X = BasePoint.X + SegWidth + 3
Else
If Left$(Value, 1) = "." Then
p.Line (BasePoint.X + (SegWidth \ 2) - 4, BasePoint.Y + (SegHeight \ 2) + 6)-(BasePoint.X + (SegWidth \ 2), BasePoint.Y + (SegHeight \ 2) + 9), , BF
BasePoint.X = BasePoint.X + SegWidth
Else
p.Line (BasePoint.X + (SegWidth \ 2) - 4, BasePoint.Y + (SegHeight \ 2) - 6)-(BasePoint.X + (SegWidth \ 2), BasePoint.Y + (SegHeight \ 2) - 3), , BF
p.Line (BasePoint.X + (SegWidth \ 2) - 4, BasePoint.Y + (SegHeight \ 2) + 4)-(BasePoint.X + (SegWidth \ 2), BasePoint.Y + (SegHeight \ 2) + 7), , BF
BasePoint.X = BasePoint.X + SegWidth
End If
End If
Value = Right$(Value, Len(Value) - 1)
Wend
BasePoint.X = OrigX
End Property
Property Let ForeColor(Color As Long)
p.ForeColor = Color
End Property

Public Sub NewLCD(PBox As PictureBox)
Set p = PBox
p.ScaleMode = 3 ' pixel
p.AutoRedraw = True
BasePoint.X = 2
BasePoint.Y = 2
SegHeight = p.ScaleHeight - 6
SegWidth = (SegHeight \ 2) + 2
End Sub
窗体中：
Option Explicit
Dim lcdTest1 As New mcLCD
Private Sub Form_Load()
lcdTest1.NewLCD picture1
End Sub
Private Sub Timer1_Timer()
lcdTest1.Caption = Time
End Sub


48.将部分菜单放置在窗体的最右段（如帮助等）
在菜单编辑器中在待放置于最右段的菜单前加一标题为空格的菜单，并去掉visable属性前钩号。
Private Type MENUITEMINFO
'.......请自己加上啊  
End Type
Private Const MFT_RIGHTJUSTIFY = &H4000
'API函数声明
Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal _ hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As _ MENUITEMINFO) As Long
Private Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal _ hMenu As Long, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
'在窗体载入过程（也可放在其他过程）中对菜单设置进行更改
Private Sub Form_Load()
Dim my_menuItemInfo As MENUITEMINFO
Dim return_value As Long
my_menuItemInfo.cbSize = 44
my_menuItemInfo.fMask = 16
my_menuItemInfo.cch = 128
my_menuItemInfo.dwTypeData = Space$(128)
return_value = GetMenuItemInfo(GetMenu(Me.hwnd), 2, 1, my_menuItemInfo)
'这里的2请根据自己的情况而定，为正常显示在左端的菜单数
my_menuItemInfo.fType = MFT_RIGHTJUSTIFY
return_value = SetMenuItemInfo(GetMenu(Me.hwnd), 2, 1, my_menuItemInfo)
End Sub


46.List每行以相应的内容为提示
'----------------------By 陈锐------------------------------
'如果你要在Internet或BBS上转贴文章,请通知我知道（没有通知，不知道犯不犯法，呵呵）
'这个程序演示如何给List Box的每个列表行加上不同的提示行
'运行该程序，当鼠标移动到任一行上后，弹出的ToolTip就会提示该行的完整内容
'Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long
Private Const LB_ITEMFROMPOINT = &H1A9
Private Sub Form_Load()
With List1
.AddItem "陈锐 ChenReee@Netaddress.com"
.AddItem "陈锐 Reee-Chen@Netaddress.com"
.AddItem "陈锐 Chenrui@hotmail.com"
End With
End Sub
Private Sub List1_MouseMove(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
' present related tip message
Dim lXPoint As Long
Dim lYPoint As Long
Dim lIndex As Long
If Button = 0 Then ' 如果没有按钮被按下
lXPoint = CLng(X / Screen.TwipsPerPixelX)
lYPoint = CLng(Y / Screen.TwipsPerPixelY)
With List1
' 获得当前的光标所在的的屏幕位置确定标题位置
lIndex = SendMessage(.hwnd, LB_ITEMFROMPOINT, 0, _
ByVal ((lYPoint * 65536) + lXPoint))
' 显示提示行或清除提示行
If (lIndex >= 0) And (lIndex <= .ListCount) Then
.ToolTipText = .List(lIndex)
Else
.ToolTipText = ""
End If
End With
End If
End Sub

47.将部分菜单放置在窗体的最右段（如帮助等）
在菜单编辑器中在待放置于最右段的菜单前加一标题为空格的菜单，并去掉visable属性前钩号。
Private Type MENUITEMINFO
'.......请自己加上啊  
End Type
Private Const MFT_RIGHTJUSTIFY = &H4000
'API函数声明
Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal _ hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As _ MENUITEMINFO) As Long
Private Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal _ hMenu As Long, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
'在窗体载入过程（也可放在其他过程）中对菜单设置进行更改
Private Sub Form_Load()
Dim my_menuItemInfo As MENUITEMINFO
Dim return_value As Long
my_menuItemInfo.cbSize = 44
my_menuItemInfo.fMask = 16
my_menuItemInfo.cch = 128
my_menuItemInfo.dwTypeData = Space$(128)
return_value = GetMenuItemInfo(GetMenu(Me.hwnd), 2, 1, my_menuItemInfo)
'这里的2请根据自己的情况而定，为正常显示在左端的菜单数
my_menuItemInfo.fType = MFT_RIGHTJUSTIFY
return_value = SetMenuItemInfo(GetMenu(Me.hwnd), 2, 1, my_menuItemInfo)
End Sub
48. 改变屏幕分辨率
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (lpString1 As Any, lpString2 As Any) As Long
Private Const CCHDEVICENAME = 32
Private Const CCHFORMNAME = 32
Private Const ENUM_CURRENT_SETTINGS = 1
Private Type DEVMODE
.........(请自己添加上）  
End Type
Private Declare Function ChangeDisplaySettings Lib "user32" _ Alias "ChangeDisplaySettingsA" (ByVal lpDevMode As Long, ByVal dwflags As Long) As Long
Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" _ (ByVal lpszDeviceName As String, ByVal iModeNum As Long, lpDevMode As Any) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Dim pNewMode As DEVMODE
Dim pOldMode As Long
Dim nOrgWidth As Integer, nOrgHeight As Integer
'设置显示器分辨率的执行函数
Private Function SetDisplayMode(Width As Integer, Height As Integer, Color As Integer) _ As Long ', Freq As Long) As Long
On Error GoTo ErrorHandler
Const DM_PELSWIDTH = &H80000
Const DM_PELSHEIGHT = &H100000
Const DM_BITSPERPEL = &H40000
Const DM_DISPLAYFLAGS = &H200000
Const DM_DISPLAYFREQUENCY = &H400000
With pNewMode
.dmSize = Len(pNewMode)
If Color = 0 Then 'Color = 0 时不更改屏幕颜色
.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
Else
.dmFields = DM_BITSPERPEL Or DM_PELSWIDTH Or DM_PELSHEIGHT
End If
.dmPelsWidth = Width
.dmPelsHeight = Height
If Color <> 0 Then
.dmBitsPerPel = Color
End If
End With
pOldMode = lstrcpy(pNewMode, pNewMode)
SetDisplayMode = ChangeDisplaySettings(pOldMode, 1)
Exit Function
ErrorHandler:
MsgBox Err.Description
End Function
Private Sub Command1_Click()
Dim nWidth As Integer, nHeight As Integer, nColor As Integer
Select Case Combo1.ListIndex
Case 0
nWidth = 640: nHeight = 480: nColor = 16 '640*480*16位真彩色,256色nColor _
= 8,16色nColor = 4,nColor = 0 表示不改变颜色
Case 1
nWidth = 640: nHeight = 480: nColor = 24
Case 2
nWidth = 640: nHeight = 480: nColor = 32
Case 3
nWidth = 800: nHeight = 600: nColor = 16
Case 4
nWidth = 800: nHeight = 600: nColor = 24
Case 5
nWidth = 800: nHeight = 600: nColor = 32
Case 6
nWidth = 1024: nHeight = 768: nColor = 16
Case 7
nWidth = 1024: nHeight = 768: nColor = 24
Case 8
nWidth = 1024: nHeight = 768: nColor = 32
Case other
nWidth = 800: nHeight = 600: nColor = 16
End Select
Call SetDisplayMode(nWidth, nHeight, nColor) '注意,系统不支持的显示模式不
'能选，否则准备用安全模式重启动吧.
End Sub
Private Sub Form_Load()
Combo1.AddItem "640*480*16位真彩色"
Combo1.AddItem "640*480*24位真彩色"
Combo1.AddItem "640*480*32位真彩色"
Combo1.AddItem "800*600*16位真彩色"
Combo1.AddItem "800*600*24位真彩色"
Combo1.AddItem "800*600*32位真彩色"
Combo1.AddItem "1024*768*16位真彩色"
Combo1.AddItem "1024*768*24位真彩色"
Combo1.AddItem "1024*768*32位真彩色"
Combo1.Text = Combo1.List(0)
nOrgWidth = GetDisplayWidth
nOrgHeight = GetDisplayHeight
'nOrgWidth = GetSystemMetrics(SM_CXSCREEN)'两种获取初始屏幕大小的方法均可
'nOrgHeight = GetSystemMetrics(SM_CYSCREEN)
End Sub
Private Function GetDisplayWidth() As Integer
GetDisplayWidth = Screen.Width \ Screen.TwipsPerPixelX
End Function
Private Function GetDisplayHeight() As Integer
GetDisplayHeight = Screen.Height \ Screen.TwipsPerPixelY
End Function
Private Sub RestoreDisplayMode()
Call SetDisplayMode(nOrgWidth, nOrgHeight, 0)
End Sub
Private Sub Form_Unload(Cancel As Integer)
RestoreDisplayMode
End Sub

最美我中文

49 各种进制转换
Function Bin2Dec(InputData As String) As Double '二进制转变成十进制
Dim DecOut As Double:Dim I As Integer:Dim LenBin As Double:Dim JOne As String
LenBin = Len(InputData) '确认是否为二进制数
For I = 1 To LenBin
JOne = Mid(InputData, I, 1)
If JOne <> "0" And JOne <> "1" Then
MsgBox "NOT A BINARY NUMBER", vbCritical
Exit Function
End If
Next I
DecOut = 0
For I = Len(InputData) To 1 Step -1
If Mid(InputData, I, 1) = "1" Then
DecOut = DecOut + 2 ^ (Len(InputData) - I)
End If
Next I
Bin2Dec = DecOut
End Function

Function Dec2Bin(InputData As Double) As String '十进制转变为二进制
Dim Quot As Double:Dim Remainder As Double:Dim BinOut As String:Dim I As Integer
Dim NewVal As Double:Dim TempString As String:Dim TempVal As Double
Dim BinTemp As String:Dim BinTemp1 As String:Dim PosDot As Integer
Dim Temp2 As String  
'检查是否为十进制的小数点
If InStr(1, CStr(InputData), ".") Then
MsgBox "Only Whole Numbers can be converted", vbCritical
GoTo eds
End If
BinOut = ""
NewVal = InputData
DoAgain: '开始计算
NewVal = (NewVal / 2) '如果有余数
If InStr(1, CStr(NewVal), ".") Then
BinOut = BinOut + "1" '得到余数
NewVal = Format(NewVal, "#0")
NewVal = (NewVal - 1)
If NewVal < 1 Then
GoTo DoneIt
End If
Else
BinOut = BinOut + "0"
If NewVal < 1 Then
GoTo DoneIt
End If
End If
GoTo DoAgain
DoneIt:
BinTemp = "" '颠倒结果
For I = Len(BinOut) To 1 Step -1
BinTemp1 = Mid(BinOut, I, 1)
BinTemp = BinTemp + BinTemp1
Next I
BinOut = BinTemp '输出结果
Dec2Bin = BinOut
eds:
End Function

Function Bin2Hex(InputData As String) As String '二进制转变成十六进制
Dim I As Integer:Dim LenBin As Integer:Dim JOne As String:Dim NumBlocks As Integer
Dim FullBin As String:Dim HexOut As String:Dim TempBinBlock As String
Dim TempHex As String
LenBin = Len(InputData)'确认是否为二进制数
For I = 1 To LenBin
JOne = Mid(InputData, I, 1)
If JOne <> "0" And JOne <> "1" Then
MsgBox "NOT A BINARY NUMBER", vbCritical
Exit Function
End If
Next I '设置二进制变量
FullBin = InputData ' 如果这个值的长度小于4,则补0
If LenBin < 4 Then
If LenBin = 3 Then
FullBin = "0" + FullBin
ElseIf LenBin = 2 Then
FullBin = "00" + FullBin
ElseIf LenBin = 1 Then
FullBin = "000" + FullBin
ElseIf LenBin = 0 Then
MsgBox "Nothing Given..", vbCritical
Exit Function
End If
NumBlocks = 1
GoTo DoBlocks
End If
If LenBin = 4 Then
NumBlocks = 1
GoTo DoBlocks
End If
If LenBin > 4 Then
Dim TempHold As Currency
Dim TempDiv As Currency
Dim AfterDot As Integer
Dim Pos As Integer
TempHold = Len(InputData)
TempDiv = (TempHold / 4)
Pos = InStr(1, CStr(TempDiv), ".")
If Pos = 0 Then
NumBlocks = TempDiv
GoTo DoBlocks
End If
AfterDot = Mid(CStr(TempDiv), (Pos + 1))
If AfterDot = 25 Then
FullBin = "000" + FullBin
NumBlocks = (Len(FullBin) / 4)
ElseIf AfterDot = 5 Then
FullBin = "00" + FullBin
NumBlocks = (Len(FullBin) / 4)
ElseIf AfterDot = 75 Then
FullBin = "0" + FullBin
NumBlocks = (Len(FullBin) / 4)
Else
MsgBox "Big Time Screw up happened, WAHHHHHHHHHHH", vbInformation
Exit Function
End If
GoTo DoBlocks
End If
DoBlocks:
HexOut = ""
For I = 1 To Len(FullBin) Step 4
TempBinBlock = Mid(FullBin, I, 4)
If TempBinBlock = "0000" Then
HexOut = HexOut + "0"
ElseIf TempBinBlock = "0001" Then
HexOut = HexOut + "1"
ElseIf TempBinBlock = "0010" Then
HexOut = HexOut + "2"
ElseIf TempBinBlock = "0011" Then
HexOut = HexOut + "3"
ElseIf TempBinBlock = "0100" Then
HexOut = HexOut + "4"
ElseIf TempBinBlock = "0101" Then
HexOut = HexOut + "5"
ElseIf TempBinBlock = "0110" Then
HexOut = HexOut + "6"
ElseIf TempBinBlock = "0111" Then
HexOut = HexOut + "7"
ElseIf TempBinBlock = "1000" Then
HexOut = HexOut + "8"
ElseIf TempBinBlock = "1001" Then
HexOut = HexOut + "9"
ElseIf TempBinBlock = "1010" Then
HexOut = HexOut + "A"
ElseIf TempBinBlock = "1011" Then
HexOut = HexOut + "B"
ElseIf TempBinBlock = "1100" Then
HexOut = HexOut + "C"
ElseIf TempBinBlock = "1101" Then
HexOut = HexOut + "D"
ElseIf TempBinBlock = "1110" Then
HexOut = HexOut + "E"
ElseIf TempBinBlock = "1111" Then
HexOut = HexOut + "F"
End If
Next I
Bin2Hex = HexOut
eds:
End Function

Function Hex2Bin(InputData As String) As String
Dim I As Integer:Dim BinOut As String:Dim Lenhex As Integer
InputData = UCase(InputData)
Lenhex = Len(InputData)
For I = 1 To Lenhex
If IsNumeric(Mid(InputData, I, 1)) Then
GoTo NumOk
ElseIf Mid(InputData, I, 1) = "A" Then
GoTo NumOk
ElseIf Mid(InputData, I, 1) = "B" Then
GoTo NumOk
ElseIf Mid(InputData, I, 1) = "C" Then
GoTo NumOk
ElseIf Mid(InputData, I, 1) = "D" Then
GoTo NumOk
ElseIf Mid(InputData, I, 1) = "E" Then
GoTo NumOk
ElseIf Mid(InputData, I, 1) = "F" Then
GoTo NumOk
Else
MsgBox "Number given is not in Hex format", vbCritical
Exit Function
End If
NumOk:
Next I
BinOut = ""
For I = 1 To Lenhex
If Mid(InputData, I, 1) = "0" Then
BinOut = BinOut + "0000"
ElseIf Mid(InputData, I, 1) = "1" Then
BinOut = BinOut + "0001"
ElseIf Mid(InputData, I, 1) = "2" Then
BinOut = BinOut + "0010"
ElseIf Mid(InputData, I, 1) = "3" Then
BinOut = BinOut + "0011"
ElseIf Mid(InputData, I, 1) = "4" Then
BinOut = BinOut + "0100"
ElseIf Mid(InputData, I, 1) = "5" Then
BinOut = BinOut + "0101"
ElseIf Mid(InputData, I, 1) = "6" Then
BinOut = BinOut + "0110"
ElseIf Mid(InputData, I, 1) = "7" Then
BinOut = BinOut + "0111"
ElseIf Mid(InputData, I, 1) = "8" Then
BinOut = BinOut + "1000"
ElseIf Mid(InputData, I, 1) = "9" Then
BinOut = BinOut + "1001"
ElseIf Mid(InputData, I, 1) = "A" Then
BinOut = BinOut + "1010"
ElseIf Mid(InputData, I, 1) = "B" Then
BinOut = BinOut + "1011"
ElseIf Mid(InputData, I, 1) = "C" Then
BinOut = BinOut + "1100"
ElseIf Mid(InputData, I, 1) = "D" Then
BinOut = BinOut + "1101"
ElseIf Mid(InputData, I, 1) = "E" Then
BinOut = BinOut + "1110"
ElseIf Mid(InputData, I, 1) = "F" Then
BinOut = BinOut + "1111"
Else
MsgBox "Something is Screwed up, Wahhhhhhhhhhh", vbCritical
End If
Next I
Hex2Bin = BinOut
eds:
End Function

Function Hex2Dec(InputData As String) As Double
Dim I As Integer:Dim DecOut As Double:Dim Lenhex As Integer:Dim HexStep As Double
DecOut = 0
InputData = UCase(InputData)
Lenhex = Len(InputData)
For I = 1 To Lenhex
If IsNumeric(Mid(InputData, I, 1)) Then
GoTo NumOk
ElseIf Mid(InputData, I, 1) = "A" Then
GoTo NumOk
ElseIf Mid(InputData, I, 1) = "B" Then
GoTo NumOk
ElseIf Mid(InputData, I, 1) = "C" Then
GoTo NumOk
ElseIf Mid(InputData, I, 1) = "D" Then
GoTo NumOk
ElseIf Mid(InputData, I, 1) = "E" Then
GoTo NumOk
ElseIf Mid(InputData, I, 1) = "F" Then
GoTo NumOk
Else
MsgBox "Number given is not in Hex format", vbCritical
Exit Function
End If
NumOk:
Next I
HexStep = 0
For I = Lenhex To 1 Step -1
HexStep = HexStep * 16
If HexStep = 0 Then
HexStep = 1
End If
If Mid(InputData, I, 1) = "0" Then  
DecOut = DecOut + (0 * HexStep)  
ElseIf Mid(InputData, I, 1) = "1" Then
DecOut = DecOut + (1 * HexStep)
ElseIf Mid(InputData, I, 1) = "2" Then
DecOut = DecOut + (2 * HexStep)
ElseIf Mid(InputData, I, 1) = "3" Then
DecOut = DecOut + (3 * HexStep)
ElseIf Mid(InputData, I, 1) = "4" Then
DecOut = DecOut + (4 * HexStep)
ElseIf Mid(InputData, I, 1) = "5" Then
DecOut = DecOut + (5 * HexStep)
ElseIf Mid(InputData, I, 1) = "6" Then
DecOut = DecOut + (6 * HexStep)
ElseIf Mid(InputData, I, 1) = "7" Then
DecOut = DecOut + (7 * HexStep)
ElseIf Mid(InputData, I, 1) = "8" Then
DecOut = DecOut + (8 * HexStep)
ElseIf Mid(InputData, I, 1) = "9" Then
DecOut = DecOut + (9 * HexStep)
ElseIf Mid(InputData, I, 1) = "A" Then
DecOut = DecOut + (10 * HexStep)
ElseIf Mid(InputData, I, 1) = "B" Then
DecOut = DecOut + (11 * HexStep)
ElseIf Mid(InputData, I, 1) = "C" Then
DecOut = DecOut + (12 * HexStep)
ElseIf Mid(InputData, I, 1) = "D" Then
DecOut = DecOut + (13 * HexStep)
ElseIf Mid(InputData, I, 1) = "E" Then
DecOut = DecOut + (14 * HexStep)
ElseIf Mid(InputData, I, 1) = "F" Then
DecOut = DecOut + (15 * HexStep)
Else
MsgBox "Something is Screwed up, Wahhhhhhhhhhh", vbCritical
End If
Next I
Hex2Dec = DecOut
eds:
End Function
调用方式：
Private Sub cmdbin2hex_Click()
txthex.Text = Bin2Hex(txtbinary.Text)
End Sub
Private Sub cmddec2bin_Click()
If IsNumeric(txtdec2bin.Text) Then
txtdec2bin2.Text = Dec2Bin(txtdec2bin.Text)
End If
End Sub
Private Sub cmdDecHex_Click()
If IsNumeric(txtDecimal.Text) Then
txtdechex.Text = Hex(CDbl(txtDecimal.Text))
Else
MsgBox "Not a Number.", vbCritical
End If
End Sub
Private Sub cmdhex2bin_Click()
txtbinary2.Text = Hex2Bin(txthex2.Text)
End Sub
Private Sub cmdhexdec_Click()
txtdec2.Text = CStr(Hex2Dec(txthexdec.Text))
End Sub

50. 控制左右声道
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal _ lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As _
Long, ByVal hwndCallback As Long) As Long
Private Sub Command1_Click()
PlaySound "F:\music\incubus\水木年华-再见了最爱的人.mp3"
End Sub
Function PlaySound(ByVal FileName As String) As Boolean
Dim cmd As String, exName As String
exName = Right(FileName, 3)
mciSendString "close " & exName, 0, 0, 0
cmd = "open " & FileName & " alias " & exName
mciSendString cmd, 0, 0, 0
PlaySound = mciSendString("play " & exName, 0, 0, 0)
End Function
Private Sub Command2_Click()
Static flag As Boolean ' 设置左声道开关
mciSendString "set all audio all " & IIf(flag, "on", "off"), 0, 0, 0
If flag = False Then
Command2.Caption = "左声道(关)"
Else
Command2.Caption = "左声道(开)"
End If
flag = Not flag
End Sub
Private Sub Command3_Click()
Static flag As Boolean ' 设置右声道开关
mciSendString "set all audio all " & IIf(flag, "on", "off"), 0, 0, 0
If flag = False Then
Command3.Caption = "右声道(关)"
Else
Command3.Caption = "右声道(开)"
End If
flag = Not flag
End Sub
Private Sub Command4_Click() '' 设置mp3设备音量:0--1000,500表示音量适中
mciSendString "set mp3 audio volume to 500", 0, 0, 0  
End Sub