access能否实现截图功能?1

xingzhihao

有一段VB 的源码,多次尝试也没能移植到ACCESS.
哪位大侠可以改写为VBA代码,用access实现截图?
VB 源码:
Private bIsSnap     As Boolean       '   如果正在抓取则为真

Private Sub Form_Load()
        ScaleMode = vbPixels
        AutoRedraw = True
        Me.Picture1.Left = 0
        Me.Picture1.Top = 0
        Me.Picture1.Width = Me.ScaleWidth
        Me.Picture1.Height = Me.ScaleHeight
End Sub

'   释放捕捉
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
        Unload Me
End Sub

'   释放内存空间
Private Sub Form_Unload(Cancel As Integer)
        Set Form1 = Nothing
End Sub

'   这里开始抓取
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, _
                                x As Single, y As Single)
                                
        Dim spLeft     As Long
        Dim spTop     As Long
        Dim spRight     As Long
        Dim spBottom     As Long
        If (Button And vbLeftButton) Then
                '   如果bIsSnap为真
                If bIsSnap And Screen.MousePointer = vbCrosshair Then
                        Dim r     As RECT
                        Dim pt     As POINTAPI
                        
                        '   恢复抓取标志
                        bIsSnap = False
                        '   设置抓取开始点
                        pt.x = x
                        pt.y = y
                        
                        '调用CaptureRect函数开始区域抓取
                        r = CaptureRect(Me.hwnd, pt)
                                                                              
                        '   获取抓取区域范围
                        spLeft = r.Left
                        spTop = r.Top
                        spRight = r.Right
                        spBottom = r.Bottom
                        ScrnCap spLeft, spTop, spRight, spBottom
                        Me.WindowState = 0
                        Me.Picture1.Picture = Clipboard.GetData
                        Me.mnuFileSave.Enabled = True
                End If
        End If
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, _
                x As Single, y As Single)
               
        '恢复光标
        If (Button And vbLeftButton) Then
                Screen.MousePointer = vbNormal
        End If
End Sub

Private Sub mnuFileExit_Click()
        End
End Sub

Private Sub mnuFileSnap_Click()
        If Not bIsSnap Then
                bIsSnap = True
                '   将光标改为十字型
                Screen.MousePointer = vbCrosshair
                '   设置抓取，使得本窗体可以接收所有窗体的鼠标事件
                SetCapture Me.hwnd
                '   最小化本窗体
          '       Me.WindowState   =   1
        End If
End Sub

Private Sub mnuFileSave_click()
        Dim FileName     As String
        On Error Resume Next
        CommonDialog1.DialogTitle = "保存 "
        '   cdlOFNHideReadOnly隐藏只读选择框
        '   cdlOFNOverwritePrompt当保存的文件存在时给于是否替换的提示
        CommonDialog1.Flags = cdlOFNHideReadOnly Or cdlOFNOverwritePrompt
        CommonDialog1.Filter = "位图文件(*.bmp)|*.bmp "
        CommonDialog1.ShowSave
        If Err = 32755 Then Exit Sub                     '   用户选择了Cancel
        FileName = CommonDialog1.FileName
        If FileName <> " " Then
                SavePicture Picture1.Picture, FileName
        End If
End Sub

模块1
'   PeekMessage
Public Const PM_REMOVE = &H1

'   鼠标相关消息
Public Const WM_MOUSEFIRST = &H200
Public Const WM_MOUSELAST = &H209
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_RBUTTONUP = &H205
Public Const WM_LBUTTONUP = &H202
Public Const WM_MOUSEMOVE = &H200

'   BitBlt   函数常量
Public Const SRCCOPY = &HCC0020
Public Const SRCINVERT = &H660046

' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
'   PatBlt   函数常量
Public Const DINV = 3
Public Const DSTINVERT = &H550009

Type RECT
                Left   As Long
                Top   As Long
                Right   As Long
                Bottom   As Long
End Type

Type POINTAPI
                x   As Long
                y   As Long
End Type

Type Size
                cx   As Long
                cy   As Long
End Type

Type msg
        hwnd   As Long
        message   As Long
        wParam   As Long
        lParam   As Long
        time   As Long
        pt   As POINTAPI
End Type

'Windows   关于消息的函数
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
Declare Function WaitMessage Lib "user32 " () As Long
Declare Function TranslateMessage Lib "user32 " (lpMsg As msg) As Long
Declare Function DispatchMessage Lib "user32 " Alias "DispatchMessageA " _
        (lpMsg As msg) As Long
Declare Function PostMessage Lib "user32 " Alias "PostMessageA " _
        (ByVal hwnd As Long, _
        ByVal wMsg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long _
        ) As Long

'鼠标捕捉函数
Declare Function SetCapture Lib "user32 " (ByVal hwnd As Long) As Long
Declare Function ReleaseCapture Lib "user32 " () As Long
Declare Function GetCapture Lib "user32 " () As Long

Declare Function DeleteDC Lib "gdi32 " (ByVal hdc As Long) As Long
Declare Function DeleteObject Lib "gdi32 " _
        (ByVal hObject As Long) As Long

Declare Function GetTextExtentPoint32 Lib "gdi32 " Alias "GetTextExtentPoint32A " _
        (ByVal hdc As Long, _
        ByVal lpszString As String, _
        ByVal cbString As Long, _
        lpSize As Size _
        ) As Long
Declare Function IsRectEmpty Lib "user32 " (lpRect As RECT) As Long
Declare Function PatBlt Lib "gdi32 " _
        (ByVal hdc As Long, _
        ByVal x As Long, ByVal y As Long, _
        ByVal nWidth As Long, _
        ByVal nHeight As Long, _
        ByVal dwRop As Long _
        ) As Long
Declare Function Rectangle Lib "gdi32 " _
        (ByVal hdc As Long, _
        ByVal X1 As Long, ByVal Y1 As Long, _
        ByVal X2 As Long, ByVal Y2 As Long _
        ) As Long
Declare Function ScreenToClient Lib "user32 " _
        (ByVal hwnd As Long, _
        lpPoint As POINTAPI _
        ) As Long
Declare Function SelectObject Lib "gdi32 " _
        (ByVal hdc As Long, _
        ByVal hObject As Long _
        ) As Long
Declare Function TextOut Lib "gdi32 " Alias "TextOutA " _
        (ByVal hdc As Long, _
        ByVal x As Long, ByVal y As Long, _
        ByVal lpString As String, _
        ByVal nCount As Long _
        ) As Long
Declare Function SetTextColor Lib "gdi32 " _
        (ByVal hdc As Long, _
        ByVal crColor As Long _
        ) As Long
Declare Function SetBkColor Lib "gdi32 " _
        (ByVal hdc As Long, _
        ByVal crColor As Long _
        ) As Long
Declare Function SetForegroundWindow Lib "user32 " _
        (ByVal hwnd As Long) As Long
Declare Function UpdateWindow Lib "user32 " (ByVal hwnd As Long) As Long
Declare Function WindowFromPoint Lib "user32 " _
        (ByVal xPoint As Long, _
        ByVal yPoint As Long _
        ) As Long
Declare Function BitBlt Lib "gdi32 " _
        (ByVal hDestDC As Long, _
        ByVal x As Long, _
        ByVal y As Long, _
        ByVal nWidth As Long, _
        ByVal nHeight As Long, _
        ByVal hSrcDC As Long, _
        ByVal xSrc As Long, _
        ByVal ySrc As Long, _
        ByVal dwRop As Long _
        ) As Long
Declare Function CreateDCNull Lib "gdi32 " Alias "CreateDCA " _
        (ByVal lpDriverName As String, _
        ByVal lpDeviceName As String, _
        ByVal lpOutput As String, _
        ByVal lpInitData As Long _
        ) As Long
Declare Function ReleaseDC Lib "user32 " _
        (ByVal hwnd As Long, _
        ByVal hdc As Long _
        ) As Long
Declare Function GetDeviceCaps Lib "gdi32 " _
        (ByVal hdc As Long, _
        ByVal nIndex As Long _
        ) As Long
Declare Function CreateBitmap Lib "gdi32 " _
        (ByVal nWidth As Long, _
        ByVal nHeight As Long, _
        ByVal nPlanes As Long, _
        ByVal nBitCount As Long, _
        lpBits As Any _
        ) As Long
Declare Function ClientToScreen Lib "user32 " _
        (ByVal hwnd As Long, _
        lpPoint As POINTAPI _
        ) As Long
Declare Function CreateCompatibleDC Lib "gdi32 " _
        (ByVal hdc As Long) As Long
Declare Function OpenClipboard Lib "user32 " _
        (ByVal hwnd As Long) As Long
  Declare Function EmptyClipboard Lib "user32 " () As Long
  Declare Function SetClipboardData Lib "user32 " _
        (ByVal wFormat As Long, _
        ByVal hMem As Long _
        ) As Long
  Declare Function CreateDC Lib "gdi32 " Alias "CreateDCA " _
        (ByVal lpDriverName As String, _
        ByVal lpDeviceName As String, _
        ByVal lpOutput As String, _
        lpInitData As Long _
        ) As Long
  Declare Function CreateCompatibleBitmap Lib "gdi32 " _
        (ByVal hdc As Long, _
        ByVal nWidth As Long, _
        ByVal nHeight As Long _
        ) As Long
  Declare Function CloseClipboard Lib "user32 " () As Long

xingzhihao

模块2
Public Function CaptureRect(ByVal hwnd As Long, ptOrigin As POINTAPI) As RECT
        Dim hdc     As Long
        Dim msg     As msg
        Dim hPal, hBitmap       As Long
        Dim rcClip     As RECT
        Dim rcClient     As RECT
        
        '   获得屏幕设备句柄
        hdc = CreateDCNull("DISPLAY ", 0, 0, 0&)
      
        '   转换屏幕坐标
        ClientToScreen hwnd, ptOrigin

        '   rcClip   是用户当前选择的方框
        '   单用户刚刚按下左键时,将该方框初始化最小
        rcClip.Left = ptOrigin.x
        rcClip.Right = ptOrigin.x
        rcClip.Top = ptOrigin.y
        rcClip.Bottom = ptOrigin.y
        
        '   确保该方框为一个正常的方框
        NormalizeRect rcClip
        '   开始画抓取方框
        DrawSelect hdc, rcClip
        
        Do
                '   等待鼠标消息
                WaitMessage
                If (PeekMessage(msg, 0, WM_MOUSEFIRST, WM_MOUSELAST, PM_REMOVE)) Then
                        '   擦除前一个方框
                        DrawSelect hdc, rcClip
                        '   获得新坐标
                        rcClip.Left = ptOrigin.x
                        rcClip.Top = ptOrigin.y
                        rcClip.Right = msg.pt.x
                        rcClip.Bottom = msg.pt.y
                        '   正常化方框
                        NormalizeRect rcClip
                        '   画新的方框
                        DrawSelect hdc, rcClip
                        '如果是左键弹起消息则退出循环
                        If (msg.message = WM_LBUTTONUP) Then Exit Do
                End If
        '   下一个消息
        Loop
        '   清除最后一个方框
        DrawSelect hdc, rcClip
        '   清除设备
        DeleteDC hdc
        '   释放捕捉
        ReleaseCapture
        '   设置方框
        CaptureRect = rcClip
        '   向源窗体发送ButtonUp消息,以便让程序知道处理已经完成
        PostMessage hwnd, WM_LBUTTONUP, msg.wParam, msg.lParam
End Function

'   DrawSelect
'   按照剪切方框的尺寸绘制剪切方框
Public Function DrawSelect(hdc As Long, rcClip As RECT)
        Dim hdcBits     As Long             '   DWORD
        Dim x, y       As Long
        Dim dx, dy       As Long
        Dim hbm     As Long                     '   HBITMAP
        Dim sExtent     As Size             '   SIZE
        Dim sz     As String
        Dim psz     As Long                     '   Size   sz
        
        '   如果一个剪切方框已经被选择则绘制它
        If Not IsRectEmpty(rcClip) Then
                '   PatBlt   函数用选择的画笔向指定设备绘制给定的方框
                '   画笔的颜色和表面颜色由给定的光栅操作决定
                '   BOOL   PatBlt(hdc,nXLeft,nYLeft,nWidth,nHeight,dwRop)
                PatBlt hdc, rcClip.Left, rcClip.Top, _
                        rcClip.Right - rcClip.Left, 1, DSTINVERT
                PatBlt hdc, rcClip.Left, rcClip.Bottom, _
                        1, -(rcClip.Bottom - rcClip.Top), DSTINVERT
                PatBlt hdc, rcClip.Right - 1, rcClip.Top, _
                        1, rcClip.Bottom - rcClip.Top, DSTINVERT
                PatBlt hdc, rcClip.Right, rcClip.Bottom - 1, _
                        -(rcClip.Right - rcClip.Left), 1, DSTINVERT
               
                sz = CStr(rcClip.Right - rcClip.Left) & "x " & _
                                      CStr(rcClip.Bottom - rcClip.Top)
                GetTextExtentPoint32 hdc, sz, Len(sz), sExtent
                dx = sExtent.cx
                dy = sExtent.cy
                x = (rcClip.Right + rcClip.Left - dx) / 2
                y = (rcClip.Bottom + rcClip.Top - dy) / 2
                hdcBits = CreateCompatibleDC(hdc)
                SetTextColor hdcBits, &HFFFFFF
                SetBkColor hdcBits, &H0

                '   向设备输出文本
                hbm = CreateBitmap(dx, dy, 1, 1, 0&)
                If (hbm) Then
                        hbm = SelectObject(hdcBits, hbm)
                        TextOut hdcBits, 0, 0, sz, Len(sz)
                        BitBlt hdc, x, y, dx, dy, hdcBits, 0, 0, SRCINVERT
                        '   恢复原有句柄
                        hbm = SelectObject(hdcBits, hbm)
                        DeleteObject hbm
                End If
                DeleteDC hdcBits
        End If
End Function

'   确保该方框为一个正常的方框
'   目的:   如果方框坐标被颠倒了就交换它们
'   这样作的目的是保证第一点为方框的左上角点
'   第二点为方框的右下角点
Public Sub NormalizeRect(ByRef Rct As RECT)
        If (Rct.Right < Rct.Left) Then Swap Rct.Right, Rct.Left
        If (Rct.Bottom < Rct.Top) Then Swap Rct.Bottom, Rct.Top
End Sub

'   交换
Public Sub Swap(ByRef x As Long, ByRef y As Long)
        x = x Xor y
        y = x Xor y
        x = x Xor y
End Sub

'   拷贝选定方框区域的屏幕图像到剪贴板
Public Sub ScrnCap(Left As Long, Top As Long, Right As Long, Bottom As Long)
        Dim rWidth     As Long
        Dim rHeight     As Long
        Dim SourceDC     As Long
        Dim DestDC     As Long
        Dim BHandle     As Long
        Dim Wnd     As Long
        Dim DHandle     As Long
        rWidth = Right - Left
        rHeight = Bottom - Top
        SourceDC = CreateDC("DISPLAY ", 0, 0, 0)
        DestDC = CreateCompatibleDC(SourceDC)
        BHandle = CreateCompatibleBitmap(SourceDC, rWidth, rHeight)
        SelectObject DestDC, BHandle
        BitBlt DestDC, 0, 0, rWidth, rHeight, SourceDC, Left, Top, &HCC0020
        Wnd = Screen.ActiveForm.hwnd
        OpenClipboard Wnd
        EmptyClipboard
        SetClipboardData 2, BHandle
        CloseClipboard
        DeleteDC DestDC
        ReleaseDC DHandle, SourceDC
End Sub

dashllh

代码太长了。说说提示什么错误。

xingzhihao

access没有Picture控件,另外不支持一些属性和方法

lirong

以前做了一个，不知道还能不能找到

xingzhihao

lirong 兄:
您好!
看遍了你的帖子,也没有找到相关的内容,还请您不惜赐教呀,能否传一个例子给我,先谢了!!!