VB入门技巧50例(一)

作者：佚名来源：不详整理日期：2007-4-14

希望大家好好看看，好多吧里的问题这里都能找到答案，资料是我从网络中搜集来的，今天先发上来一些，希望大家能够从中学到些东西

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 Forms 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

【相关文章】