例如要将两幅图片进行合并，如果通过在PICTUREBOX中进行处理速度很慢，是否可以先载如内存处理完后再在PICTUREBOX中显示呢？ 回复贴子： 回复人： charset(神奈川) (2001-8-19 21:38:46) 得0分 50分呢！用BITBLT。 给我5分我再向下说。 我在CSDN里回答了好多可是没有分 这次要留个心眼…… 用BitBlt进行对DC的操作。 回复人： charset(神奈川) (2001-8-19 21:44:47) 得0分 我前几天才知道的一种很快的办法！ LoadImage 和CreateCompatibleDC CreateCompatibleBitmap SelectObject DeleteDC DeleteObject 的确很快、很稳定！ 回复人： sssa2000() (2001-8-19 22:28:45) 得0分 loadimage createcompatibleDC ........ 能说一下详细用法吗？ 我觉得还是用 bitblt,还有 rea*(我记不太清了） 是用来释放内存的，这两个函数要配合使用，明天再告书你吧，记得给我加分呀。 回复人： wxj_lake(蔚蓝的风) (2001-8-19 23:05:44) 得0分 图片进行合并？拿去看一下 Public Declare Function AlphaBlend Lib "msimg32" (ByVal hdcDest As Long, _ ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, _ ByVal nWidthDest As Long, ByVal hHeightDest As Long, _ ByVal hdcSrc As Long, ByVal nXOriginSrc As Long, _ ByVal nYOriginSrc As Long, ByVal nWidthSrc As Long, _ ByVal nHeightSrc As Long, ByVal blendFunc As Long) As Boolean '以上是module中的声明'在Pic(1)中画渐变色 Private Sub Command1_Click() Dim i As Long, j As Long Pic(1).Cls For i = 0 To Pic(1).ScaleWidth - 1 For j = 0 To Pic(1).ScaleHeight - 1 Pic(1).PSet (i, j), RGB(Fix(i * 255 / Pic(1).ScaleWidth), _ 0, 255 - Fix(j * 255 / Pic(1).ScaleHeight)) Next Pic(1).Refresh Next End Sub'合并Pic(0)和Pic(1)的图像 Private Sub Command2_Click() Dim SourceConstantAlpha As Long, r As Byte, StrRes As String StrRes = InputBox("Give a number from 0 to 255 (the greater the " + _ "value the farest you get from the clouds):", _ "Alpha blend example...", 100)
If StrRes = "" Then Exit Sub
r = CLng(StrRes) Mod 256 SourceConstantAlpha = r * 65536 Pic(0).Cls Call AlphaBlend(Pic(0).hDC, 0, 0, Pic(0).ScaleWidth, Pic(0).ScaleHeight, _ Pic(1).hDC, 0, 0, Pic(1).ScaleWidth, Pic(1).ScaleHeight, _ SourceConstantAlpha) Pic(0).Refresh End Sub
回复人： wxj_lake(蔚蓝的风) (2001-8-19 23:15:58) 得0分 如果一定要VB代码作合并，会慢一些。看看这个是半透明的窗体，VB即时混合的'模块中的代码 Option ExplicitPublic Type BITMAPINFOHEADER biSize As Long biWidth As Long biHeight As Long biPlanes As Integer biBitCount As Integer biCompression As Long biSizeImage As Long biXPelsPerMeter As Long biYPelsPerMeter As Long biClrUsed As Long biClrImportant As Long End TypePublic Type RGBQUAD rgbBlue As Byte rgbGreen As Byte rgbRed As Byte rgbReserved As Byte End TypePublic Type BITMAPINFO bmiHeader As BITMAPINFOHEADER bmiColors As RGBQUAD End TypePublic 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 Public Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long Public Declare Function SetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long Public Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Public 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 Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As LongPublic Function ShadeColors(ByVal Dst As Long, ByVal Src As Long, ByVal Shade As Byte) Select Case Shade Case 0: ShadeColors = Dst Case 255: ShadeColors = Src Case Else: ShadeColors = (Src And &HFF) * Shade / 255 + (Dst And &HFF) * (255 - Shade) / 255 Or _ ((Src And &HFF00&) * Shade / 255 + (Dst And &HFF00&) * (255 - Shade) / 255) And &HFF00& Or _ ((Src And &HFF0000) * (Shade / 255) + (Dst And &HFF0000) * ((255 - Shade) / 255)) And &HFF0000 End Select End FunctionPublic Function AlphaBlend(ByVal DstDC As Long, ByVal DstX As Long, ByVal DstY As Long, ByVal DstW As Long, ByVal DstH As Long, ByVal SrcDC As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Alpha As Byte, ByVal TransColor As Long, ByVal Flags As Long) As Long If Alpha = 0 Or DstW = 0 Or DstH = 0 Then Exit Function Dim B As Long, H As Long, F As Long, I As Long Dim TmpDC As Long, TmpBmp As Long, TmpObj As Long Dim Sr2DC As Long, Sr2Bmp As Long, Sr2Obj As Long Dim Data1() As Long, Data2() As Long Dim Info As BITMAPINFO
For H = 0 To DstH - 1 F = H * DstW For B = 0 To DstW - 1 I = F + B If (Flags And &H1) And ((Data2(I) And &HFFFFFF) = TransColor) Then Else Data1(I) = ShadeColors(Data1(I), Data2(I), Alpha) End If Next B Next H SetDIBitsToDevice DstDC, DstX, DstY, DstW, DstH, 0, 0, 0, DstH, Data1(0), Info, 0 Erase Data1 Erase Data2 DeleteObject SelectObject(TmpDC, TmpObj) DeleteObject SelectObject(Sr2DC, Sr2Obj) DeleteDC TmpDC DeleteDC Sr2DC End Function '----------------------------------------'窗体中的代码 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 GetDesktopWindow Lib "user32" () As Long Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)Dim CurX As Single, CurY As Single Dim WH As Long, WD As LongDim TPPX As Integer Dim TPPY As IntegerPrivate Sub Form_Load() Picture3.Picture = LoadPicture("back.bmp") Width = Picture3.Width Height = Picture3.Height End SubPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) Picture1_MouseDown Button, Shift, x, y End SubPrivate Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) Picture1_MouseMove Button, Shift, x, y End SubPrivate Sub Image1_Click() Me.WindowState = vbMinimized End SubPrivate Sub Image2_Click() Unload Me End SubPrivate Sub Image3_Click() MsgBox "Test" End SubPrivate Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) If Button = vbLeftButton Then CurX = x CurY = y End If End SubPrivate Sub Picture1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) Dim DeltaX As Long, DeltaY As Long Dim WH As Long, WD As Long If Button = 1 Then WH = GetDesktopWindow WD = GetDC(WH) DeltaX = x - CurX DeltaY = y - CurY BitBlt Picture2.hdc, 0, 0, ScaleWidth \ TPPX, ScaleHeight \ TPPY, Picture2.hdc, DeltaX \ TPPX, DeltaY \ TPPY, vbSrcCopy If DeltaX > 0 Then BitBlt Picture2.hdc, (ScaleWidth - DeltaX) \ TPPX, 0, DeltaX \ TPPX, ScaleHeight \ TPPY, WD, (Left + Width) \ TPPX, (Top + DeltaY) \ TPPX, vbSrcCopy ElseIf DeltaX < 0 Then BitBlt Picture2.hdc, 0, 0, -DeltaX \ TPPX, ScaleHeight \ TPPY, WD, (Left + DeltaX) \ TPPX, (Top + DeltaY) \ TPPY, vbSrcCopy End If If DeltaY > 0 Then BitBlt Picture2.hdc, 0, (ScaleHeight - DeltaY) \ TPPY, ScaleWidth \ TPPX, DeltaY \ TPPY, WD, (Left + DeltaX) \ TPPX, (Top + Height) \ TPPY, vbSrcCopy ElseIf DeltaY < 0 Then BitBlt Picture2.hdc, 0, 0, ScaleWidth \ TPPX, -DeltaY \ TPPY, WD, (Left + DeltaX) \ TPPX, (Top + DeltaY) \ TPPY, vbSrcCopy End If 'Picture2.Refresh BitBlt Picture1.hdc, 0, 0, ScaleWidth \ TPPX, ScaleHeight \ TPPY, Picture2.hdc, 0, 0, vbSrcCopy AlphaBlend Picture1.hdc, 0, 0, ScaleWidth \ TPPX, ScaleHeight \ TPPY, Picture3.hdc, 0, 0, 128, &HFF00FF, 1 Move Left + DeltaX, Top + DeltaY Picture1.Refresh BitBlt Me.hdc, 0, 0, ScaleWidth \ TPPX, ScaleHeight \ TPPY, Picture1.hdc, 0, 0, vbSrcCopy ReleaseDC WH, WD End If End SubPrivate Sub Form_Resize() TPPX = Screen.TwipsPerPixelX TPPY = Screen.TwipsPerPixelY Picture1.Move 0, 0, Width, Height Picture2.Move 0, 0, Width, Height WH = GetDesktopWindow WD = GetDC(WH) BitBlt Picture2.hdc, 0, 0, ScaleWidth \ TPPX, ScaleHeight \ TPPY, WD, Left \ TPPX, Top \ TPPY, vbSrcCopy BitBlt Picture1.hdc, 0, 0, ScaleWidth \ TPPX, ScaleHeight \ TPPY, Picture2.hdc, 0, 0, vbSrcCopy AlphaBlend Picture1.hdc, 0, 0, ScaleWidth \ TPPX, ScaleHeight \ TPPY, Picture3.hdc, 0, 0, 128, &HFF00FF, 1 ReleaseDC WH, WD End Sub
回复人： jixian(极限) (2001-8-20 1:26:26) 得0分 .....@....... 回复人： textstar(小熊) (2001-8-20 22:12:13) 得0分 to charset(神奈川):你能告诉我你的方法吗？分数吗可以给啊，我很讲信誉的！ 另外谢谢 wxj_lake(蔚蓝的风) 你给我的代码我试一下，看看行不行，一定给分！ 回复人： charset(神奈川) (2001-8-21 9:28:28) 得0分 '不用PictureBox和其他控件的方法！一级棒！ Public Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPublic 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 LongPublic Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As LongPublic Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As LongPublic Declare Function LoadBitmap Lib "user32" Alias "LoadBitmapA" (ByVal hInstance As Long, ByVal lpBitmapName As String) As LongPublic Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As LongPublic Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As LongPublic Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As LongPublic Const SRCAND = &H8800C6 Public Const SRCCOPY = &HCC0020 Public Const SRCERASE = &H440328 Public Const SRCINVERT = &H660046 Public Const SRCPAINT = &HEE0086 Public Const BLACKNESS = &H42 Public Const WHITENESS = &HFF0062Public Const LR_LOADFROMFILE = &H10 Public Const IMAGE_BITMAP = 0 Const IMAGE_ICON = 1 Const IMAGE_CURSOR = 2 Const IMAGE_ENHMETAFILE = 3 Const CF_BITMAP = 2Public Function LoadBitmap2DC(hDC As Long, ByVal PicturePath As String, Optional ByVal nWidth As Long, Optional ByVal nHeight As Long) As Long Dim PicPath As String PicPath = PicturePath Dim hBitmap As Long hBitmap = LoadImage(0, PicPath, IMAGE_BITMAP, nWidth, nHeight, LR_LOADFROMFILE) If hBitmap = 0 Then LoadBitmap2DC = hBitmap Exit Function End If hDC = CreateCompatibleDC(0) SelectObject hDC, hBitmap DeleteObject hBitmap LoadBitmap2DC = -1 End FunctionPublic Sub CreateBlackness(hDC as long,ByVal nWidth as long,Byval nHeight as long) hDC = CreateCompatibleDC(0) Dim hBitmap As Long hBitmap = CreateCompatibleBitmap(hDC, 100, 100) SelectObject hDC, hBitmap BitBlt hDC, 0, 0, 100, 100, 0, 0, 0, BLACKNESS DeleteObject hBitmap End Sub'你用CREATEBLACKNESS造个可以容纳两个图片的大小的HDC '在这里是两个图片横放 CREATEBLACKNESS(hBlackness,p1Width+p2Width,p1Height) dim p1Path As String dim p2Path as string p1path=app.path &"p1.bmp" p2path=app.path &"p2.bmp" LoadBitmap2DC Hpic1DC,p1path loadbitmap2DC Hpic2DC,p2path '不可以LoadBitmap2DC hDC,app.path &"some.bmp" '这样会出错 bitblt MainDC,0,0,p1Width,p1Height,hpic1DC,0,0,srccopy bitblt Maindc,p1Width,0,p2Width,p2Height,hpic2dc,0,0,srccopy '在MainDC里就是两副图片的东西。 '最后不要忘了把DC们都DELETEDC '谢谢你的赏光，有空多联系：[email protected]
作 者：textstar
所属论坛：Visual Basic
问题点数：50
回复次数：9
发表时间：2001-8-19 21:34:43
例如要将两幅图片进行合并，如果通过在PICTUREBOX中进行处理速度很慢，是否可以先载如内存处理完后再在PICTUREBOX中显示呢？
回复贴子：
回复人： charset(神奈川) (2001-8-19 21:38:46) 得0分
50分呢！用BITBLT。
给我5分我再向下说。
我在CSDN里回答了好多可是没有分
这次要留个心眼……
用BitBlt进行对DC的操作。
回复人： charset(神奈川) (2001-8-19 21:44:47) 得0分
我前几天才知道的一种很快的办法！
LoadImage 和CreateCompatibleDC
CreateCompatibleBitmap
SelectObject
DeleteDC
DeleteObject
的确很快、很稳定！
回复人： sssa2000() (2001-8-19 22:28:45) 得0分
loadimage createcompatibleDC ........
能说一下详细用法吗？ 我觉得还是用 bitblt,还有 rea*(我记不太清了） 是用来释放内存的，这两个函数要配合使用，明天再告书你吧，记得给我加分呀。
回复人： wxj_lake(蔚蓝的风) (2001-8-19 23:05:44) 得0分
图片进行合并？拿去看一下
Public Declare Function AlphaBlend Lib "msimg32" (ByVal hdcDest As Long, _
ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, _
ByVal nWidthDest As Long, ByVal hHeightDest As Long, _
ByVal hdcSrc As Long, ByVal nXOriginSrc As Long, _
ByVal nYOriginSrc As Long, ByVal nWidthSrc As Long, _
ByVal nHeightSrc As Long, ByVal blendFunc As Long) As Boolean
'以上是module中的声明'在Pic(1)中画渐变色
Private Sub Command1_Click()
Dim i As Long, j As Long Pic(1).Cls
For i = 0 To Pic(1).ScaleWidth - 1
For j = 0 To Pic(1).ScaleHeight - 1
Pic(1).PSet (i, j), RGB(Fix(i * 255 / Pic(1).ScaleWidth), _
0, 255 - Fix(j * 255 / Pic(1).ScaleHeight))
Next
Pic(1).Refresh
Next
End Sub'合并Pic(0)和Pic(1)的图像
Private Sub Command2_Click()
Dim SourceConstantAlpha As Long, r As Byte, StrRes As String StrRes = InputBox("Give a number from 0 to 255 (the greater the " + _
"value the farest you get from the clouds):", _
"Alpha blend example...", 100)
If StrRes = "" Then Exit Sub
r = CLng(StrRes) Mod 256 SourceConstantAlpha = r * 65536
Pic(0).Cls
Call AlphaBlend(Pic(0).hDC, 0, 0, Pic(0).ScaleWidth, Pic(0).ScaleHeight, _
Pic(1).hDC, 0, 0, Pic(1).ScaleWidth, Pic(1).ScaleHeight, _
SourceConstantAlpha)
Pic(0).Refresh
End Sub
回复人： wxj_lake(蔚蓝的风) (2001-8-19 23:15:58) 得0分
如果一定要VB代码作合并，会慢一些。看看这个是半透明的窗体，VB即时混合的'模块中的代码
Option ExplicitPublic Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End TypePublic Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End TypePublic Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End TypePublic 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
Public Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Public Declare Function SetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Public Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public 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
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As LongPublic Function ShadeColors(ByVal Dst As Long, ByVal Src As Long, ByVal Shade As Byte)
Select Case Shade
Case 0: ShadeColors = Dst
Case 255: ShadeColors = Src
Case Else:
ShadeColors = (Src And &HFF) * Shade / 255 + (Dst And &HFF) * (255 - Shade) / 255 Or _
((Src And &HFF00&) * Shade / 255 + (Dst And &HFF00&) * (255 - Shade) / 255) And &HFF00& Or _
((Src And &HFF0000) * (Shade / 255) + (Dst And &HFF0000) * ((255 - Shade) / 255)) And &HFF0000
End Select
End FunctionPublic Function AlphaBlend(ByVal DstDC As Long, ByVal DstX As Long, ByVal DstY As Long, ByVal DstW As Long, ByVal DstH As Long, ByVal SrcDC As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Alpha As Byte, ByVal TransColor As Long, ByVal Flags As Long) As Long
If Alpha = 0 Or DstW = 0 Or DstH = 0 Then Exit Function
Dim B As Long, H As Long, F As Long, I As Long
Dim TmpDC As Long, TmpBmp As Long, TmpObj As Long
Dim Sr2DC As Long, Sr2Bmp As Long, Sr2Obj As Long
Dim Data1() As Long, Data2() As Long
Dim Info As BITMAPINFO
TmpDC = CreateCompatibleDC(SrcDC)
Sr2DC = CreateCompatibleDC(SrcDC)
TmpBmp = CreateCompatibleBitmap(DstDC, DstW, DstH)
Sr2Bmp = CreateCompatibleBitmap(DstDC, DstW, DstH)
TmpObj = SelectObject(TmpDC, TmpBmp)
Sr2Obj = SelectObject(Sr2DC, Sr2Bmp)
ReDim Data1(DstW * DstH * 4 - 1)
ReDim Data2(DstW * DstH * 4 - 1)
Info.bmiHeader.biSize = Len(Info.bmiHeader)
Info.bmiHeader.biWidth = DstW
Info.bmiHeader.biHeight = DstH
Info.bmiHeader.biPlanes = 1
Info.bmiHeader.biBitCount = 32
Info.bmiHeader.biCompression = 0 BitBlt TmpDC, 0, 0, DstW, DstH, DstDC, DstX, DstY, vbSrcCopy
BitBlt Sr2DC, 0, 0, DstW, DstH, SrcDC, SrcX, SrcY, vbSrcCopy
GetDIBits TmpDC, TmpBmp, 0, DstH, Data1(0), Info, 0
GetDIBits Sr2DC, Sr2Bmp, 0, DstH, Data2(0), Info, 0
For H = 0 To DstH - 1
F = H * DstW
For B = 0 To DstW - 1
I = F + B
If (Flags And &H1) And ((Data2(I) And &HFFFFFF) = TransColor) Then
Else
Data1(I) = ShadeColors(Data1(I), Data2(I), Alpha)
End If
Next B
Next H SetDIBitsToDevice DstDC, DstX, DstY, DstW, DstH, 0, 0, 0, DstH, Data1(0), Info, 0 Erase Data1
Erase Data2
DeleteObject SelectObject(TmpDC, TmpObj)
DeleteObject SelectObject(Sr2DC, Sr2Obj)
DeleteDC TmpDC
DeleteDC Sr2DC
End Function
'----------------------------------------'窗体中的代码
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 GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)Dim CurX As Single, CurY As Single
Dim WH As Long, WD As LongDim TPPX As Integer
Dim TPPY As IntegerPrivate Sub Form_Load()
Picture3.Picture = LoadPicture("back.bmp")
Width = Picture3.Width
Height = Picture3.Height
End SubPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Picture1_MouseDown Button, Shift, x, y
End SubPrivate Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Picture1_MouseMove Button, Shift, x, y
End SubPrivate Sub Image1_Click()
Me.WindowState = vbMinimized
End SubPrivate Sub Image2_Click()
Unload Me
End SubPrivate Sub Image3_Click()
MsgBox "Test"
End SubPrivate Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbLeftButton Then
CurX = x
CurY = y
End If
End SubPrivate Sub Picture1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim DeltaX As Long, DeltaY As Long
Dim WH As Long, WD As Long
If Button = 1 Then
WH = GetDesktopWindow
WD = GetDC(WH)
DeltaX = x - CurX
DeltaY = y - CurY
BitBlt Picture2.hdc, 0, 0, ScaleWidth \ TPPX, ScaleHeight \ TPPY, Picture2.hdc, DeltaX \ TPPX, DeltaY \ TPPY, vbSrcCopy
If DeltaX > 0 Then
BitBlt Picture2.hdc, (ScaleWidth - DeltaX) \ TPPX, 0, DeltaX \ TPPX, ScaleHeight \ TPPY, WD, (Left + Width) \ TPPX, (Top + DeltaY) \ TPPX, vbSrcCopy
ElseIf DeltaX < 0 Then
BitBlt Picture2.hdc, 0, 0, -DeltaX \ TPPX, ScaleHeight \ TPPY, WD, (Left + DeltaX) \ TPPX, (Top + DeltaY) \ TPPY, vbSrcCopy
End If
If DeltaY > 0 Then
BitBlt Picture2.hdc, 0, (ScaleHeight - DeltaY) \ TPPY, ScaleWidth \ TPPX, DeltaY \ TPPY, WD, (Left + DeltaX) \ TPPX, (Top + Height) \ TPPY, vbSrcCopy
ElseIf DeltaY < 0 Then
BitBlt Picture2.hdc, 0, 0, ScaleWidth \ TPPX, -DeltaY \ TPPY, WD, (Left + DeltaX) \ TPPX, (Top + DeltaY) \ TPPY, vbSrcCopy
End If
'Picture2.Refresh
BitBlt Picture1.hdc, 0, 0, ScaleWidth \ TPPX, ScaleHeight \ TPPY, Picture2.hdc, 0, 0, vbSrcCopy
AlphaBlend Picture1.hdc, 0, 0, ScaleWidth \ TPPX, ScaleHeight \ TPPY, Picture3.hdc, 0, 0, 128, &HFF00FF, 1
Move Left + DeltaX, Top + DeltaY
Picture1.Refresh
BitBlt Me.hdc, 0, 0, ScaleWidth \ TPPX, ScaleHeight \ TPPY, Picture1.hdc, 0, 0, vbSrcCopy
ReleaseDC WH, WD
End If
End SubPrivate Sub Form_Resize()
TPPX = Screen.TwipsPerPixelX
TPPY = Screen.TwipsPerPixelY
Picture1.Move 0, 0, Width, Height
Picture2.Move 0, 0, Width, Height
WH = GetDesktopWindow
WD = GetDC(WH)
BitBlt Picture2.hdc, 0, 0, ScaleWidth \ TPPX, ScaleHeight \ TPPY, WD, Left \ TPPX, Top \ TPPY, vbSrcCopy
BitBlt Picture1.hdc, 0, 0, ScaleWidth \ TPPX, ScaleHeight \ TPPY, Picture2.hdc, 0, 0, vbSrcCopy AlphaBlend Picture1.hdc, 0, 0, ScaleWidth \ TPPX, ScaleHeight \ TPPY, Picture3.hdc, 0, 0, 128, &HFF00FF, 1
ReleaseDC WH, WD
End Sub
回复人： jixian(极限) (2001-8-20 1:26:26) 得0分
.....@.......
回复人： textstar(小熊) (2001-8-20 22:12:13) 得0分
to charset(神奈川):你能告诉我你的方法吗？分数吗可以给啊，我很讲信誉的！
另外谢谢 wxj_lake(蔚蓝的风) 你给我的代码我试一下，看看行不行，一定给分！
回复人： charset(神奈川) (2001-8-21 9:28:28) 得0分
'不用PictureBox和其他控件的方法！一级棒！
Public Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPublic 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 LongPublic Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As LongPublic Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As LongPublic Declare Function LoadBitmap Lib "user32" Alias "LoadBitmapA" (ByVal hInstance As Long, ByVal lpBitmapName As String) As LongPublic Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As LongPublic Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As LongPublic Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As LongPublic Const SRCAND = &H8800C6
Public Const SRCCOPY = &HCC0020
Public Const SRCERASE = &H440328
Public Const SRCINVERT = &H660046
Public Const SRCPAINT = &HEE0086
Public Const BLACKNESS = &H42
Public Const WHITENESS = &HFF0062Public Const LR_LOADFROMFILE = &H10
Public Const IMAGE_BITMAP = 0
Const IMAGE_ICON = 1
Const IMAGE_CURSOR = 2
Const IMAGE_ENHMETAFILE = 3
Const CF_BITMAP = 2Public Function LoadBitmap2DC(hDC As Long, ByVal PicturePath As String, Optional ByVal nWidth As Long, Optional ByVal nHeight As Long) As Long
Dim PicPath As String
PicPath = PicturePath
Dim hBitmap As Long
hBitmap = LoadImage(0, PicPath, IMAGE_BITMAP, nWidth, nHeight, LR_LOADFROMFILE)
If hBitmap = 0 Then
LoadBitmap2DC = hBitmap
Exit Function
End If
hDC = CreateCompatibleDC(0)
SelectObject hDC, hBitmap
DeleteObject hBitmap
LoadBitmap2DC = -1
End FunctionPublic Sub CreateBlackness(hDC as long,ByVal nWidth as long,Byval nHeight as long)
hDC = CreateCompatibleDC(0)
Dim hBitmap As Long
hBitmap = CreateCompatibleBitmap(hDC, 100, 100)
SelectObject hDC, hBitmap
BitBlt hDC, 0, 0, 100, 100, 0, 0, 0, BLACKNESS
DeleteObject hBitmap
End Sub'你用CREATEBLACKNESS造个可以容纳两个图片的大小的HDC
'在这里是两个图片横放
CREATEBLACKNESS(hBlackness,p1Width+p2Width,p1Height)
dim p1Path As String
dim p2Path as string
p1path=app.path &"p1.bmp"
p2path=app.path &"p2.bmp"
LoadBitmap2DC Hpic1DC,p1path
loadbitmap2DC Hpic2DC,p2path
'不可以LoadBitmap2DC hDC,app.path &"some.bmp"
'这样会出错
bitblt MainDC,0,0,p1Width,p1Height,hpic1DC,0,0,srccopy
bitblt Maindc,p1Width,0,p2Width,p2Height,hpic2dc,0,0,srccopy
'在MainDC里就是两副图片的东西。
'最后不要忘了把DC们都DELETEDC
'谢谢你的赏光，有空多联系：[email protected]