23.01.10

Приклади коду на Visual Basic. Стандартні елементи керування

Відстеження позиції курсору в елементі PictureBox

Вам знадобиться елемент PictureBox, елемент Line1, розташований вертикально, і елемент Line2, розташований горизонтально. Властивості елементів Line в подію Private Sub Form_Load () краще змінити у процесі розробки програми.
Private Sub Form_Load()
Line1.BorderStyle = 3
Line1.DrawMode = 1
Line2.BorderStyle = 3
Line2.DrawMode = 1
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Line1.Visible = False
Line2.Visible = False
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
With Line1
.X1 = X
.X2 = X
.Y1 = 0
.Y2 = Picture1.Height
.Visible = True
End With
With Line2
.Y1 = Y
.Y2 = Y
.X1 = 0
.X2 = Picture1.Width
.Visible = True
End With
End Sub


Заміна одних кольорів іншими

Даний приклад покаже, як можна замінити один колір іншим в картинці.

Private Type RECT
left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private 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
Private Const SRCCOPY = &HCC0020
Private Const SRCAND = &H8800C6
Private Const SRCPAINT = &HEE0086
Private Const SRCINVERT = &H660046
Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long

Public Sub ReplaceColor(ByRef picThis As PictureBox, ByVal lFromColour As Long, ByVal lToColor As Long)
Dim lW As Long
Dim lH As Long
Dim lMaskDC As Long, lMaskBMP As Long, lMaskBMPOLd As Long
Dim lCopyDC As Long, lCopyBMP As Long, lCopyBMPOLd As Long
Dim tR As RECT
Dim hBr As Long
' Cache the width & height of the picture:
lW = picThis.ScaleWidth \ Screen.TwipsPerPixelX
lH = picThis.ScaleHeight \ Screen.TwipsPerPixelY
' Create a Mono DC & Bitmap
If (CreateDC(picThis, lW, lH, lMaskDC, lMaskBMP, lMaskBMPOLd, True)) Then
' Create a DC & Bitmap with the same colour depth as the picture:
If (CreateDC(picThis, lW, lH, lCopyDC, lCopyBMP, lCopyBMPOLd)) Then
' Make a mask from the picture which is white in the replace colour area:
SetBkColor picThis.hDC, lFromColour
BitBlt lMaskDC, 0, 0, lW, lH, picThis.hDC, 0, 0, SRCCOPY
' Fill the colour DC with the colour we want to replace with
tR.Right = lW: tR.Bottom = lH
hBr = CreateSolidBrush(lToColor)
FillRect lCopyDC, tR, hBr
DeleteObject hBr
' Turn the colour DC black except where the mask is white:
BitBlt lCopyDC, 0, 0, lW, lH, lMaskDC, 0, 0, SRCAND
' Create an inverted mask, so it is black where the colour is to be replaced but white otherwise:
hBr = CreateSolidBrush(&HFFFFFF)
FillRect lMaskDC, tR, hBr
DeleteObject hBr
BitBlt lMaskDC, 0, 0, lW, lH, picThis.hDC, 0, 0, SRCINVERT
' AND the inverted mask with the picture. The picture
' goes black where the colour is to be replaced, but is
' unaffected otherwise.
SetBkColor picThis.hDC, &HFFFFFF
BitBlt picThis.hDC, 0, 0, lW, lH, lMaskDC, 0, 0, SRCAND
' Finally, OR the coloured item with the picture. Where
' the picture is black and the coloured DC isn't,
' the colour will be transferred:
BitBlt picThis.hDC, 0, 0, lW, lH, lCopyDC, 0, 0, SRCPAINT
picThis.Refresh
' Clear up the colour DC:
SelectObject lCopyDC, lCopyBMPOLd
DeleteObject lCopyBMP
DeleteObject lCopyDC
End If
' Clear up the mask DC:
SelectObject lMaskDC, lMaskBMPOLd
DeleteObject lMaskBMP
DeleteObject lMaskDC
End If
End Sub

Public Function CreateDC(ByRef picThis As PictureBox, ByVal lW As Long, ByVal lH As Long, ByRef lhDC As Long, ByRef lhBmp As Long, ByRef lhBmpOld As Long, Optional ByVal bMono As Boolean = False) As Boolean
If (bMono) Then
lhDC = CreateCompatibleDC(0)
Else
lhDC = CreateCompatibleDC(picThis.hDC)
End If
If (lhDC <> 0) Then
If (bMono) Then
lhBmp = CreateCompatibleBitmap(lhDC, lW, lH)
Else
lhBmp = CreateCompatibleBitmap(picThis.hDC, lW, lH)
End If
If (lhBmp <> 0) Then
lhBmpOld = SelectObject(lhDC, lhBmp)
CreateDC = True
Else
DeleteObject lhDC
lhDC = 0
End If
End If
End Function

Private Sub Command1_Click()
Static i As Integer
ReplaceColor Picture1, QBColor(i), &HFFFF&
i = i + 1
If (i > 15) Then
MsgBox "All colours replaced."
End If
End Sub

Private Sub Form_Load()
Dim i As Long
Dim x As Long, y As Long, w As Long, h As Long
Picture1.BackColor = &HFFFF00
For i = 1 To 200
x = Rnd * Picture1.ScaleWidth: y = Rnd * Picture1.ScaleHeight
w = Rnd * Picture1.ScaleWidth: h = Rnd * Picture1.ScaleHeight
Picture1.Line (x, y)-(x + w, y + h), QBColor(Rnd * 15), BF
Picture1.CurrentX = x: Picture1.CurrentY = y
Picture1.Print "vbAccelerator Mask Demo"
Next i
End Sub


Створення образу картинки
Даний приклад покаже, як можна створити образ (mask image) картинки. Образи маски корисні для емуляції прозорості, і для заміни квітів у зображеннях.

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private 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
Private Const SRCCOPY = &HCC0020
Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long

Public Function CreateMaskImage(ByRef picFrom As PictureBox, ByRef picTo As PictureBox, Optional ByVal lTransparentColor As Long = -1) As Boolean
Dim lhDC As Long
Dim lhBmp As Long
Dim lhBmpOld As Long
' Make picTo the same size as picFrom and clear it:
With picTo
.Width = picFrom.Width
.Height = picFrom.Height
.Cls
End With
' Create a monochrome DC & Bitmap of the same size as the source picture:
lhDC = CreateCompatibleDC(0)
If (lhDC <> 0) Then
lhBmp = CreateCompatibleBitmap(lhDC, picFrom.ScaleWidth \ Screen.TwipsPerPixelX, picFrom.ScaleHeight \ Screen.TwipsPerPixelY)
If (lhBmp <> 0) Then
lhBmpOld = SelectObject(lhDC, lhBmp)
' Set the back 'colour' of the monochrome DC to the colour we wish to be transparent:
If (lTransparentColor = -1) Then lTransparentColor = picFrom.BackColor
SetBkColor lhDC, lTransparentColor
' Copy from the from picture to the monochrome DC to create the mask:
BitBlt lhDC, 0, 0, picFrom.ScaleWidth \ Screen.TwipsPerPixelX, picFrom.ScaleHeight \ Screen.TwipsPerPixelY, picFrom.hDC, 0, 0, SRCCOPY
' Now put the mask into picTo:
BitBlt picTo.hDC, 0, 0, picFrom.ScaleWidth \ Screen.TwipsPerPixelX, picFrom.ScaleHeight \ Screen.TwipsPerPixelY, lhDC, 0, 0, SRCCOPY
picTo.Refresh
' Clear up the bitmap we used to create the mask:
SelectObject lhDC, lhBmpOld
DeleteObject lhBmp
End If
' Clear up the monochrome DC:
DeleteObject lhDC
End If
End Function

Private Sub Command1_Click()
CreateMaskImage Picture1, Picture2
End Sub

Private Sub Form_Load()
Dim i As Long
Picture1.BackColor = &HFFFF00
With Picture1.Font
.Name = "Arial"
.Bold = True
.Italic = True
.Size = 12
End With
For i = 1 To 20
Picture1.ForeColor = QBColor(i Mod 15)
Picture1.Print "vbAccelerator Mask Demo"
Next i
End Sub

Скопіювати рисунок з PictureBox в буфер обміна

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

Private 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
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function OpenClipboard Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "USER32" () As Long
Private Declare Function SetClipboardData Lib "USER32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib "USER32" () As Long
Private Const CF_BITMAP = 2

Public Function CopyEntirePicture(ByRef objFrom As Object) As Boolean
Dim lhDC As Long
Dim lhBMP As Long
Dim lhBMPOld As Long
Dim lWidthPixels As Long
Dim lHeightPixels As Long
' Create a DC compatible with the object we're copying from:
lhDC = CreateCompatibleDC(objFrom.hDC)
If (lhDC <> 0) Then
' Create a bitmap compatible with the object we're copying from:
lWidthPixels = objFrom.ScaleX(objFrom.ScaleWidth, objFrom.ScaleMode, vbPixels)
lHeightPixels = objFrom.ScaleY(objFrom.ScaleHeight, objFrom.ScaleMode, vbPixels)
lhBMP = CreateCompatibleBitmap(objFrom.hDC, lWidthPixels, lHeightPixels)
If (lhBMP <> 0) Then
' Select the bitmap into the DC we have created, and store the old bitmap that was there:
lhBMPOld = SelectObject(lhDC, lhBMP)
' Copy the contents of objFrom to the bitmap:
BitBlt lhDC, 0, 0, lWidthPixels, lHeightPixels, objFrom.hDC, 0, 0, SRCCOPY
' Remove the bitmap from the DC:
SelectObject lhDC, lhBMPOld
' Now set the clipboard to the bitmap:
OpenClipboard 0
EmptyClipboard
SetClipboardData CF_BITMAP, lhBMP
CloseClipboard
' We don't delete the Bitmap here - it is now owned
' by the clipboard and Windows will delete it for us
' when the clipboard changes or the program exits.
End If
' Clear up the device context we created:
DeleteObject lhDC
End If
End Function

Private Sub Command1_Click()
CopyEntirePicture Picture1
End Sub

Private Sub Form_Load()
Dim i As Long
' Draw something in the Picture box:
With Picture1.Font
.Name = "Arial"
.Bold = True
.Size = 24
End With
For i = 1 To 20
Picture1.ForeColor = QBColor(i Mod 15)
Picture1.Print "vbAccelerator"
Next i
End Sub

Отримати колір пікселя поза формою
Картинка буде мати колір пікселя під курсором мишки. Не важливо, де знаходиться курсор (на вашій формі чи ні) TextBox покаже Hex-значення кольору. Додайте елементи Timer, PictureBox і Text Box на форму

Private Declare Function CreateDC& Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Any)
Private Declare Function DeleteDC& Lib "gdi32" (ByVal hdc As Long)
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Dim z As POINTAPI

Private Sub Form_Load()
Timer1.Interval = 10
End Sub
Private Sub Timer1_Timer()
GetCursorPos z
screendc = CreateDC("DISPLAY", "", "", 0&)
'замените текст Text1 = Hex(GetPixel(screendc, z.x, z.y))
'если вы хотите увидеть Hex-значение цвета
Text1 = GetPixel(screendc, z.x, z.y)
Picture1.BackColor = GetPixel(screendc, z.x, z.y)
DeleteDC (screendc)
End Sub


Cкріншот екрана, форми або контроль

Даний приклад покаже, як можна зробити скріншот всього екрану, форми, 2 різних контроль і зберегти їх зображення у файл.
Розташуйте на формі 4 елементи CommandButton і елемент DirListBox (або будь-який інший контрол).

Не забудьте перевірити, щоб папка "C: \ 1 \" існувала.

Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private 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
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As DEVMODE) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long

Private Const CCHDEVICENAME = 32
Private Const CCHFORMNAME = 32
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type DEVMODE
dmDeviceName As String * CCHDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCHFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type

Public Sub Capture(control_hWnd As Long, fNAME As String, Optional OnlyToClipBoard As Boolean = False)
On Error GoTo ErrorCapture
Dim sp As RECT, x As Long
If fNAME <> "" Then
x = GetWindowRect(control_hWnd, sp)
ScrnCap sp.Left, sp.Top, sp.Right, sp.Bottom
If OnlyToClipBoard = False Then
SavePicture Clipboard.GetData, fNAME
End If
End If
Exit Sub
ErrorCapture:
MsgBox Err & ":Error in Caputre(). Error Message:" & Err.Description, vbCritical, "Warning"
Exit Sub
End Sub

Private Sub ScrnCap(Lt, Top, Rt, Bot)
On Error GoTo ErrorScrnCap
Dim rWIDTH As Long, rHEIGHT As Long
Dim SourceDC As Long, DestDC As Long, bHANDLE As Long, Wnd As Long
Dim dHANDLE As Long, dm As DEVMODE
rWIDTH = Rt - Lt
rHEIGHT = Bot - Top
SourceDC = CreateDC("DISPLAY", 0&, 0&, dm)
DestDC = CreateCompatibleDC(SourceDC)
bHANDLE = CreateCompatibleBitmap(SourceDC, rWIDTH, rHEIGHT)
SelectObject DestDC, bHANDLE
BitBlt DestDC, 0, 0, rWIDTH, rHEIGHT, SourceDC, Lt, Top, &HCC0020
Wnd = 0
OpenClipboard Wnd
EmptyClipboard
SetClipboardData 2, bHANDLE
CloseClipboard
DeleteDC DestDC
ReleaseDC dHANDLE, SourceDC
Exit Sub
ErrorScrnCap:
MsgBox Err & ":Error in ScrnCap(). Error Message:" & Err.Description, vbCritical, "Warning"
Exit Sub
End Sub

Public Sub CaptureDesktop()
On Error GoTo ErrorCaptureDesktop
Dim dhWND As Long, sp As RECT, x As Long
dhWND = GetDesktopWindow
If dhWND <> 0 Then
x = GetWindowRect(dhWND, sp)
ScrnCap sp.Left, sp.Top, sp.Right, sp.Bottom
End If
Exit Sub
ErrorCaptureDesktop:
MsgBox Err & ":Error in CaptureDesktop. Error Message: " & Err.Description, vbCritical, "Warning"
Exit Sub
End Sub

Private Sub Form_Load()
Command1.Caption = "Экран"
Command2.Caption = "Форма"
Command3.Caption = "Кнопка"
Command4.Caption = "Текстовое окно"
End Sub
Private Sub Command1_Click()
On Error Resume Next
Call CaptureDesktop
SavePicture Clipboard.GetData, "C:\1\desktop.bmp"
MsgBox "Картинка экрана сохранена в C:\1\desktop.bmp"
End Sub

Private Sub Command2_Click()
On Error Resume Next
Call Capture(Me.hwnd, "C:\1\form.bmp")
MsgBox "Картинка формы сохранена в C:\1\form.bmp"
End Sub

Private Sub Command3_Click()
On Error Resume Next
Call Capture(Me.Command1.hwnd, "C:\1\button.bmp")
MsgBox "Картинка кнопки сохранена в C:\1\button.bmp"
End Sub

Private Sub Command4_Click()
On Error Resume Next
Call Capture(Me.Dir1.hwnd, "C:\1\drv.bmp")
MsgBox "Картинка DriveListBox сохранена в C:\1\drv.bmp"
End Sub


Cкріншот екрану, активного вікна, друк і збереження у файл

Даний приклад покаже, як можна зробити скріншот всього екрану, поточного вікна (з заголовком і без), поточного вікна по таймеру. А також приклад друку скріншота і збереження у файл.

Розташуйте на формі 7 елементів CommandButton, елемент PictureBox (розтягніть зображення PictureBox якомога більше). А також розташуйте на формі елемент Microsoft Common Dialog Control 6.0 через меню Project | Components.

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type
Private Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As PALETTEENTRY ' Enough for 256 colors.
End Type
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Declare Function BitBlt Lib "GDI32" (ByVal hDCDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "GDI32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreatePalette Lib "GDI32" (lpLogPalette As LOGPALETTE) As Long
Private Declare Function DeleteDC Lib "GDI32" (ByVal hDC As Long) As Long
Private Declare Function GetDesktopWindow Lib "USER32" () As Long
Private Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "GDI32" (ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetForegroundWindow Lib "USER32" () As Long
Private Declare Function GetSystemPaletteEntries Lib "GDI32" (ByVal hDC As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function GetWindowDC Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowRect Lib "USER32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function RealizePalette Lib "GDI32" (ByVal hDC As Long) As Long
Private Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function SelectObject Lib "GDI32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function SelectPalette Lib "GDI32" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long

Public Function CaptureWindow(ByVal hWndSrc As Long, ByVal Client As Boolean, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
Dim hDCMemory As Long
Dim hBmp As Long
Dim hBmpPrev As Long
Dim r As Long
Dim hDCSrc As Long
Dim hPal As Long
Dim hPalPrev As Long
Dim RasterCapsScrn As Long
Dim HasPaletteScrn As Long
Dim PaletteSizeScrn As Long
Dim LogPal As LOGPALETTE
If Client Then
hDCSrc = GetDC(hWndSrc)
Else
hDCSrc = GetWindowDC(hWndSrc)
End If
hDCMemory = CreateCompatibleDC(hDCSrc)
hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
hBmpPrev = SelectObject(hDCMemory, hBmp)
RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)
HasPaletteScrn = RasterCapsScrn And RC_PALETTE
PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
LogPal.palVersion = &H300
LogPal.palNumEntries = 256
r = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
hPal = CreatePalette(LogPal)
hPalPrev = SelectPalette(hDCMemory, hPal, 0)
r = RealizePalette(hDCMemory)
End If
r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)
hBmp = SelectObject(hDCMemory, hBmpPrev)
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
hPal = SelectPalette(hDCMemory, hPalPrev, 0)
End If
r = DeleteDC(hDCMemory)
r = ReleaseDC(hWndSrc, hDCSrc)
Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)
End Function

Public Function CaptureActiveWindow() As Picture
Dim hWndActive As Long
Dim r As Long
Dim RectActive As RECT
hWndActive = GetForegroundWindow()
r = GetWindowRect(hWndActive, RectActive)
Set CaptureActiveWindow = CaptureWindow(hWndActive, False, 0, 0, RectActive.Right - RectActive.Left, RectActive.Bottom - RectActive.Top)
End Function

Public Function CaptureClient(frmSrc As Form) As Picture
Set CaptureClient = CaptureWindow(frmSrc.hWnd, True, 0, 0, frmSrc.ScaleX(frmSrc.ScaleWidth, frmSrc.ScaleMode, vbPixels), frmSrc.ScaleY(frmSrc.ScaleHeight, frmSrc.ScaleMode, vbPixels))
End Function

Public Function CaptureScreen() As Picture
Dim hWndScreen As Long
hWndScreen = GetDesktopWindow()
Set CaptureScreen = CaptureWindow(hWndScreen, False, 0, 0, Screen.Width \ Screen.TwipsPerPixelX, Screen.Height \ Screen.TwipsPerPixelY)
End Function

Public Function CaptureForm(frmSrc As Form) As Picture
Set CaptureForm = CaptureWindow(frmSrc.hWnd, False, 0, 0, frmSrc.ScaleX(frmSrc.Width, vbTwips, vbPixels), frmSrc.ScaleY(frmSrc.Height, vbTwips, vbPixels))
End Function

Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
Dim r As Long
Dim Pic As PicBmp
Dim IPic As IPicture
Dim IID_IDispatch As GUID
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With Pic
.Size = Len(Pic)
.Type = vbPicTypeBitmap
.hBmp = hBmp
.hPal = hPal
End With
r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
Set CreateBitmapPicture = IPic
End Function

Public Sub PrintPictureToFitPage(Prn As Printer, Pic As Picture)
Const vbHiMetric As Integer = 8
Dim PicRatio As Double
Dim PrnWidth As Double
Dim PrnHeight As Double
Dim PrnRatio As Double
Dim PrnPicWidth As Double
Dim PrnPicHeight As Double
If Pic.Height >= Pic.Width Then
Prn.Orientation = vbPRORPortrait
Else
Prn.Orientation = vbPRORLandscape
End If
PicRatio = Pic.Width / Pic.Height
PrnWidth = Prn.ScaleX(Prn.ScaleWidth, Prn.ScaleMode, vbHiMetric)
PrnHeight = Prn.ScaleY(Prn.ScaleHeight, Prn.ScaleMode, vbHiMetric)
PrnRatio = PrnWidth / PrnHeight
If PicRatio >= PrnRatio Then
PrnPicWidth = Prn.ScaleX(PrnWidth, vbHiMetric, Prn.ScaleMode)
PrnPicHeight = Prn.ScaleY(PrnWidth / PicRatio, vbHiMetric, Prn.ScaleMode)
Else
PrnPicHeight = Prn.ScaleY(PrnHeight, vbHiMetric, Prn.ScaleMode)
PrnPicWidth = Prn.ScaleX(PrnHeight * PicRatio, vbHiMetric, Prn.ScaleMode)
End If
Prn.PaintPicture Pic, 0, 0, PrnPicWidth, PrnPicHeight
End Sub

Private Sub Command1_Click()
Set Picture1.Picture = CaptureScreen()
End Sub
Private Sub Command2_Click()
Set Picture1.Picture = CaptureForm(Me)
End Sub
Private Sub Command3_Click()
MsgBox "Через 3 секунды после закрытия окна вы получите изображение окна"
Dim EndTime As Date
EndTime = DateAdd("s", 3, Now)
Do Until Now > EndTime
DoEvents
Loop
Set Picture1.Picture = CaptureActiveWindow()
Me.SetFocus
End Sub
Private Sub Command4_Click()
Set Picture1.Picture = CaptureClient(Me)
End Sub
Private Sub Command5_Click()
PrintPictureToFitPage Printer, Picture1.Picture
Printer.EndDoc
End Sub
Private Sub Command6_Click()
CommonDialog1.DefaultExt = ".BMP"
CommonDialog1.Filter = "Bitmap Image (*.bmp)|*.bmp"
CommonDialog1.ShowSave
If CommonDialog1.FileName <> "" Then
SavePicture Picture1.Picture, CommonDialog1.FileName
End If
End Sub
Private Sub Command7_Click()
Set Picture1.Picture = Nothing
End Sub
Private Sub Form_Load()
Command1.Caption = "Весь экран"
Command2.Caption = "Активное окно"
Command3.Caption = "Активное окно (3 сек)"
Command4.Caption = "Акт. окно бе загол."
Command5.Caption = "Напечатать картинку"
Command6.Caption = "Сохранить картинку"
Command7.Caption = "Очистить"
End Sub


Визначення типу малюнка та його розмірів
Даний приклад дозволяє дізнатися такі параметри файлу малюнка у форматі GIF або JPG як: тип картинки, розмір по ширині і розмір по висоті

Private Type ThePicInfo
Type As String
Width As Long
Height As Long
End Type

Private Function CheckPicSpecs(TheFile) As ThePicInfo
Dim TheContent, TheImageInfo As ThePicInfo, TheVar, TheFreeFile
TheFreeFile = FreeFile
Open TheFile For Binary As TheFreeFile
TheContent = Input(10, TheFreeFile)
Close TheFreeFile
If Mid(TheContent, 7, 4) = "JFIF" Then
TheImageInfo.Type = "JPG"
Open TheFile For Binary As TheFreeFile
TheContent = Input(167, TheFreeFile)
Close TheFreeFile
TheImageInfo.Height = Asc(Mid(TheContent, 165, 1)) + 256 * Asc(Mid(TheContent, 164, 1))
TheImageInfo.Width = Asc(Mid(TheContent, 167, 1)) + 256 * Asc(Mid(TheContent, 166, 1))
End If
If Mid(TheContent, 1, 3) = "GIF" Then
TheImageInfo.Type = "GIF"
TheImageInfo.Width = Asc(Mid(TheContent, 7, 1)) + 256 * Asc(Mid(TheContent, 8, 1))
TheImageInfo.Height = Asc(Mid(TheContent, 9, 1)) + 256 * Asc(Mid(TheContent, 10, 1))
End If
CheckPicSpecs = TheImageInfo
End Function

Private Sub Command1_Click()
Dim a As ThePicInfo
'в качестве параметра функции CheckPicSpecs установите путь к вашей картинке
a = CheckPicSpecs("D:\garbage\way2house.gif")
MsgBox a.Type
MsgBox a.Width
MsgBox a.Height
End Sub


Копіювати вміст PictureBox в буфер обміну
Розташуйте на формі елемент PictureBox і елемент CommandButton. Запустіть проект, натисніть на кнопку. Потім відкрийте програму Paint і натисніть сполучення клавіш Ctrl + V.

Option Explicit
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private 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
Private Const SRCCOPY = &HCC0020
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CountClipboardFormats Lib "user32" () As Long
Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Public Enum EPredefinedClipboardFormatConstants
[_First] = 1
CF_TEXT = 1
CF_BITMAP = 2
CF_METAFILEPICT = 3
CF_SYLK = 4
CF_DIF = 5
CF_TIFF = 6
CF_OEMTEXT = 7
CF_DIB = 8
CF_PALETTE = 9
CF_PENDATA = 10
CF_RIFF = 11
CF_WAVE = 12
CF_UNICODETEXT = 13
CF_ENHMETAFILE = 14
CF_HDROP = 15
CF_LOCALE = 16
CF_MAX = 17
[_Last] = 17
End Enum

Public Function CopyEntirePictureToClipboard(ByRef objFrom As Object) As Boolean
Dim lhDC As Long
Dim lhBmp As Long
Dim lhBmpOld As Long
lhDC = CreateCompatibleDC(objFrom.hdc)
If (lhDC <> 0) Then
lhBmp = CreateCompatibleBitmap(objFrom.hdc, objFrom.ScaleWidth \ Screen.TwipsPerPixelX, objFrom.ScaleHeight \ Screen.TwipsPerPixelY)
If (lhBmp <> 0) Then
lhBmpOld = SelectObject(lhDC, lhBmp)
BitBlt lhDC, 0, 0, objFrom.ScaleWidth \ Screen.TwipsPerPixelX, objFrom.ScaleHeight \ Screen.TwipsPerPixelY, objFrom.hdc, 0, 0, SRCCOPY
SelectObject lhDC, lhBmpOld
EmptyClipboard
OpenClipboard 0
SetClipboardData CF_BITMAP, lhBmp
CloseClipboard
End If
DeleteObject lhDC
CopyEntirePictureToClipboard = True
Else
CopyEntirePictureToClipboard = False
End If
End Function

Private Sub Command1_Click()
Call CopyEntirePictureToClipboard(Picture1)
End Sub


Функція для зміни розмірів картинки
Додайте на форму 2 PictureBox і 1 CommandButton.

Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Const SRCCOPY = &HCC0020

Private Sub ImgResize(src As PictureBox, TmpPic As PictureBox, mWidth As Long, mHeight As Long)
src.AutoRedraw = False
TmpPic.AutoRedraw = True
TmpPic.Height = mHeight 'установка размеров невидимого picturebox
TmpPic.Width = mWidth
StretchBlt TmpPic.hdc, 0, 0, mWidth, mHeight, src.hdc, 0, 0, src.Width, src.Height, SRCCOPY
'сохранить временной файл на диске
SavePicture TmpPic.Image, App.Path + "\tempimg.bmp"
'перезагрузить оригинальный picturebox
src.AutoSize = True
src.Picture = LoadPicture(App.Path + "\tempimg.bmp")
'удалить временной файл
Kill App.Path + "\tempimg.bmp"
'очистить невидимый picturebox
TmpPic.Picture = LoadPicture()
'пример для вызова функции
'ImgResize Picture1, Picture2, Picture1.Width / 2, Picture1.Height / 2
End Sub
Private Sub Command1_Click()
ImgResize Picture1, Picture2, Picture1.Width / 2, Picture1.Height / 2
End Sub
Private Sub Form_Load()
Picture2.Visible = False
End Sub

Зміна кольору окремого пікселя в елементі PictureBox
Додайте елемент PictureBox. Встановіть властивість AutoRedraw як True.
У даному прикладі при натисканні лівої клавіші миші в PictureBox ви змінюєте колір пікселя (у нашому прикладі - на червоний колір).
Колір фону для пікселя ви опеределяете функцією RGB

Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Dim s As Long, d As Long
Private Sub Form_Load()
d = RGB(255, 255, 0) 'замените переменную d на любой нужный вам цвет
End Sub
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
s = SetPixel(Picture1.hdc, X / 15, Y / 15, d)
Picture1.Refresh
End Sub
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then 'цвет пикселя меняется только при нажатой левой клавиши мыши
s = SetPixel(Picture1.hdc, X / 15, Y / 15, d)
Picture1.Refresh
End If
End Sub


Як здійснити скролінг картинки
Даний приклад покаже, як можна здійснити скролінг великої картинки в маленькому вікні. Вам необхідно додати 2 PictureBox, а також VScrollBar і HScrollBar (вертикальну та горизонтальну смугу прокручування).

Private Sub Form_Load()
HScroll1.Min = 0
HScroll1.Max = ScaleX(Picture1.Picture.Width, 8, vbTwips) - Picture2.Width
HScroll1.LargeChange = 10 * Screen.TwipsPerPixelX
HScroll1.SmallChange = Screen.TwipsPerPixelX
VScroll1.Min = 0
VScroll1.Max = ScaleX(Picture1.Picture.Height, 8, vbTwips) - Picture2.Height
VScroll1.LargeChange = 10 * Screen.TwipsPerPixelY
VScroll1.SmallChange = Screen.TwipsPerPixelY
HScroll1_Change
End Sub
Private Sub HScroll1_Change()
Picture2.PaintPicture Picture1.Picture, 0, 0, _
Picture2.Width, Picture2.Height, _
HScroll1.Value, VScroll1.Value, _
Picture2.Width, Picture2.Height
End Sub
Private Sub HScroll1_Scroll()
Picture2.PaintPicture Picture1.Picture, 0, 0, _
Picture2.Width, Picture2.Height, _
HScroll1.Value, VScroll1.Value, _
Picture2.Width, Picture2.Height
End Sub
Private Sub VScroll1_Change()
HScroll1_Change
End Sub
Private Sub VScroll1_Scroll()
HScroll1_Scroll
End Sub


Отримати розміри картинки
Отримати розміри будь-якого зображення, якщо воно може бути додано в Image box. Додайте 1 Image Box на форму. Встановіть властивості ImageBox Stretch і Visible в False.

Private Sub Form_Load()
'замените путь c:\mypic.gif на ваш путь к картинке
Image1.Picture = LoadPicture("c:\mypic.gif")
'Вы получите размеры в пикселях. (если вы хотите получить размеры в твипах,
удалите текст "/ Screen.TwipsPerPixelY" и "/ Screen.TwipsPerPixelX".)
MsgBox "Image Height: " & Image1.Height / Screen.TwipsPerPixelY & _
" Image width: " & Image1.Width / Screen.TwipsPerPixelX
End Sub

Виділити шматок картинки
Додайте PictureBox на форму

Dim X1 As Integer, X2 As Integer, Y1 As Integer, Y2 As Integer
Dim SelectBox As Boolean

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Picture1.DrawMode = 6
'Draw style to dots
Picture1.DrawStyle = 2
'Check if a Select Box is already drawn
If X2 > 0 Then Picture1.Line (X1, Y1)-(X2, Y2), , B
'Reset all the values to the current point
X1 = X
Y1 = Y
X2 = X
Y2 = Y
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'Перевірити, чи натиснута ліва кнопка миші
If Button = 1 Then
Picture1.Line (X1, Y1)-(X2, Y2), , B
X2 = X
Y2 = Y
Picture1.Line (X1, Y1)-(X, Y), , B
End If
End Sub


Реалізація функції «очікування» у VB

Цей приклад покаже, як можна реалізувати функцію очікування в VB. Спочатку помістіть на форму таймер (Timer1) і встановіть його властивість Enabled = False. Для тестування процедури додайте дві мітки (Label1 і Label2) і командну кнопку (Command1) до форми. Напишіть наступну підпрограму і код події Timer для таймера

Public Sub Wait(seconds)
Timer1.Enabled = True 'включення таймера
Timer1.Interval = 1000 * seconds 'установка інтервала для таймера
While Timer1.Interval > 0
DoEvents
Wend
Timer1.Enabled = False ' виключення таймера
End Sub
Private Sub Timer1_Timer()
Timer1.Interval = 0
End Sub

Тепер можете використовувати функцію Wait скрізь, де потрібна будь-яка затримка, наприклад:

Private Sub Command1_Click()
Label1.Caption = Now
Wait (5)
Label2.Caption = Now
End Sub

Наприклад, необхідно щоб кожні дві хвилини відбувалося яка-небудь подія

Недоліком цього методу є додавання в вашу програму додаткових змінних. До того ж ця програма випробовувалася в режимі тестування, коли навантаження на комп'ютер не було. І незрозуміло, як поведе себе ця програма в реальному режимі роботи.

Dim n As Long, s As Long
Private Sub Form_Load()
n = 1
End Sub
Private Sub Timer1_Timer()
s = s + 1
Select Case s
Case 120 * n '120 - число у хвилинах
Form2.Show 'подія: показати форму
n = n + 1
End Select
End Sub


Джерело: http://www.rusedu.info

Немає коментарів:

Дописати коментар

Related Posts Plugin for WordPress, Blogger...