怎样将圆形的图片的四角去掉啊急！！！！！！！！

太空11 2004-12-09 01:46:42

怎样将圆形的图片的四角去掉啊急！！！！！！！！

在程序中有一个长方形按钮，上边放上了，一个椭圆形的图片（图片是方形的），怎么能把四个角去掉啊，在运行程序的时候，效果是椭圆形。谢在先。

...全文

1179 13 打赏收藏转发到动态举报

写回复

用AI写文章

13 条回复

切换为时间正序

请发表友善的回复…

发表回复

kmzs 2004-12-11

打赏
举报

还是会址。。。

fishzone 2004-12-09

打赏
举报

哦，她好像要做按钮，看来我白说了。
直接用image控件加gif图片就可以了。

fishzone 2004-12-09

打赏
举报

Public Sub FitToPicture(picShape As PictureBox, frmFROM As Form)

Const RGN_OR = 2

Dim border_width As Single
Dim title_height As Single
Dim bm As BITMAP
Dim bytes() As Byte
Dim ints() As Integer
Dim longs() As Long
Dim R As Integer
Dim C As Integer
Dim start_c As Integer
Dim stop_c As Integer
Dim x0 As Long
Dim y0 As Long
Dim combined_rgn As Long
Dim new_rgn As Long
Dim offset As Integer
Dim colourDepth As Integer

'picShape.Picture = frmMain.imlAll.ListImages("Main").Picture

frmFROM.ScaleMode = vbPixels

picShape.ScaleMode = vbPixels
picShape.AutoRedraw = True
picShape.Picture = picShape.Image

' 获取窗体的边框大小
border_width = (frmFROM.ScaleX(frmFROM.Width, vbTwips, vbPixels) - frmFROM.ScaleWidth) / 2
title_height = frmFROM.ScaleX(frmFROM.Height, vbTwips, vbPixels) - border_width - frmFROM.ScaleHeight

' 获取图片大小
x0 = picShape.Left + border_width
y0 = picShape.Top + title_height

'给出图片信息
GetObject picShape.Image, Len(bm), bm
Select Case bm.bmBitsPixel
Case 15, 16:
'MsgBox _
"图片框中图片的颜色大高。",vbExclamation + vbOKOnly

colourDepth = 2

' 分配空格给图片.
ReDim ints(0 To bm.bmWidthBytes \ 2 - 1, 0 To bm.bmHeight - 1)
' 给出图片表面数据
GetBitmapBits picShape.Image, bm.bmHeight * bm.bmWidthBytes, ints(0, 0)

' 建立表单区域
For R = 0 To bm.bmHeight - 2

C = 0
Do While C < bm.bmWidth
start_c = 0
stop_c = 0

' 查找白色区域,屏蔽
Do While C < bm.bmWidth
If (ints(C, R) And &H7FFF) <> &H7FFF Then Exit Do
C = C + 1
Loop
start_c = C

Do While C < bm.bmWidth
If (ints(C, R) And &H7FFF) = &H7FFF Then Exit Do
C = C + 1
Loop
stop_c = C

If start_c < bm.bmWidth Then
If stop_c >= bm.bmWidth Then stop_c = bm.bmWidth - 1

new_rgn = CreateRectRgn(start_c + x0, R + y0, stop_c + x0, R + y0 + 1)

If combined_rgn = 0 Then
combined_rgn = new_rgn
Else
CombineRgn combined_rgn, combined_rgn, new_rgn, RGN_OR
DeleteObject new_rgn
End If
End If
Loop
Next R

Case 24:
colourDepth = 3

ReDim bytes(0 To bm.bmWidthBytes - 1, 0 To bm.bmHeight - 1)

GetBitmapBits picShape.Image, bm.bmHeight * bm.bmWidthBytes, bytes(0, 0)
For R = 0 To bm.bmHeight - 2
' Create a region for this row.
C = 0
Do While C < bm.bmWidth
start_c = 0
stop_c = 0

offset = C * colourDepth

Do While C < bm.bmWidth
If bytes(offset, R) <> 255 Or _
bytes(offset + 1, R) <> 255 Or _
bytes(offset + 2, R) <> 255 Then Exit Do
C = C + 1
offset = offset + colourDepth
Loop
start_c = C

Do While C < bm.bmWidth
If bytes(offset, R) = 255 And _
bytes(offset + 1, R) = 255 And _
bytes(offset + 2, R) = 255 _
Then Exit Do
C = C + 1
offset = offset + colourDepth
Loop
stop_c = C

If start_c < bm.bmWidth Then
If stop_c >= bm.bmWidth Then stop_c = bm.bmWidth - 1

' 建立区域
new_rgn = CreateRectRgn(start_c + x0, R + y0, stop_c + x0, R + y0 + 1)

If combined_rgn = 0 Then
combined_rgn = new_rgn
Else
CombineRgn combined_rgn, combined_rgn, new_rgn, RGN_OR
DeleteObject new_rgn
End If
End If
Loop
Next R
Case 32:
colourDepth = 4

ReDim longs(0 To bm.bmWidthBytes \ 4 - 1, 0 To bm.bmHeight - 1)

GetBitmapBits picShape.Image, bm.bmHeight * bm.bmWidthBytes, longs(0, 0)

For R = 0 To bm.bmHeight - 2

C = 0
Do While C < bm.bmWidth
start_c = 0
stop_c = 0

Do While C < bm.bmWidth
If (longs(C, R) And &HFFFFFF) <> &HFFFFFF Then Exit Do
C = C + 1
Loop
start_c = C

Do While C < bm.bmWidth
If (longs(C, R) And &HFFFFFF) = &HFFFFFF Then Exit Do
C = C + 1
Loop
stop_c = C

If start_c < bm.bmWidth Then
If stop_c >= bm.bmWidth Then stop_c = bm.bmWidth - 1

new_rgn = CreateRectRgn(start_c + x0, R + y0, stop_c + x0, R + y0 + 1)

If combined_rgn = 0 Then
combined_rgn = new_rgn
Else
CombineRgn combined_rgn, combined_rgn, new_rgn, RGN_OR
DeleteObject new_rgn
End If
End If
Loop
Next R
Case Else
'MsgBox "对不起，程序必须在 16位, 24-位或 32-位颜色下。", _
vbExclamation + vbOKOnly, "Error"
GoTo HandleAll
End Select

'设置表单外观为建立区域
SetWindowRgn frmFROM.hwnd, combined_rgn, True
DeleteObject combined_rgn

HandleAll:

End Sub

fishzone 2004-12-09

打赏
举报

这个是把图片中白色部分变成透明。
把下面的过程放到标准模块中。
用的时候，在form中放一个和窗体一样大的 picturebox，在这个picturebox 中的picture属性
放一张部分白色的图片。
像这样调用就可以了：

Public Sub Form_Load()
FitToPicture picMain, Me
End Sub

Option Explicit

Public Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type

Public Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Public Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Declare Function CreateRectRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Public Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

太空11 2004-12-09