多种多样的漂亮的windows,高手请进来..........在线等待!!!

Question

小弟想做一个漂亮的窗口,比如:做个 苹果 外形的窗口.
我知道只要做出 苹果 外形的区域就能完成这个窗口.
但是API中根本就没有 苹果 外形的函数啊!!!
用  CreatePolygonRgn  可以做出多边形的区域,但是需要自己输入 点的座标.
我的天, 苹果外轮廓的座标怎么得到,要非常精确的描绘,要很多点座标啊!每个座标都要自己输入,那么
多么累啊??????/
有没有更好的方法啊?????????????比如:把苹果的图片载入,外windows自己找到它的轮廓?我真的没办法了!55555555555555555555555555555
帮帮我 啊
我没有分数了!!不好意思!!!

Answer 1

我知道api可以实现规则的窗体，如圆形，椭圆，六角等等，不规则的不知道能不能实现

Answer 2

用API可以做到，具体怎么实现忘记了

Answer 3

给你收藏的两种方法，其实原理都是一样的，只是速度的差别Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 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 Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) 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 GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Const RGN_OR = 2
Private 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 Sub SetAutoRgn(hForm As Form, Optional transColor As Byte = vbNull)
    Dim bmByte() As Byte
    Dim X As Long, Y As Long
    Dim Rgn1 As Long, Rgn2 As Long
    Dim SPos As Long, EPos As Long
    Dim bm As BITMAP
    Dim hbm As Long
    Dim Wid As Long, Hgt As Long
    Dim xoff As Long, yoff As Long
    '获取窗体背景图片尺寸
    hbm = hForm.Picture
    GetObjectAPI hbm, Len(bm), bm
    Wid = bm.bmWidth
    Hgt = bm.bmHeight
    ReDim bmByte(1 To Wid, 1 To Hgt)
    GetBitmapBits hbm, Wid * Hgt, bmByte(1, 1) '获取图像数组
    '如果没有传入transColor参数，则用第一个像素作为透明色
    If transColor = vbNull Then transColor = bmByte(1, 1)
    Rgn1 = CreateRectRgn(0, 0, 0, 0)
    For Y = 1 To Hgt '逐行扫描
        X = 0
        Do
            X = X + 1
            While (bmByte(X, Y) = transColor) And (X < Wid)
                X = X + 1 '跳过是透明色的点
            Wend
            SPos = X
            While (bmByte(X, Y) <> transColor) And (X < Wid)
                X = X + 1 '跳过不是透明色的点
            Wend
            EPos = X - 1
            '这一段是合并区域
            If SPos <= EPos Then
                Rgn2 = CreateRectRgn(SPos - 1, Y - 1, EPos, Y)
                CombineRgn Rgn1, Rgn1, Rgn2, RGN_OR
                DeleteObject Rgn2
            End If
        Loop Until X >= Wid
    Next Y
    Erase bmByte()
    SetWindowRgn hForm.hwnd, Rgn1, True '设定窗体形状区域
    DeleteObject Rgn1
End Sub
'******************************根据某种颜色使窗体透明(慢)*************************************
Public Sub DoTransparency(bg As Form, transColor)
    Dim rgn     As Long
    Dim Rgn2    As Long
    Dim rgn3    As Long
    Dim rgn4    As Long
    Dim X1      As Long
    Dim Y1      As Long
    Dim i       As Long
    Dim j       As Long
    Dim tj      As Long
    rgn = CreateRectRgn(0, 0, 0, 0)
    Rgn2 = CreateRectRgn(0, 0, 0, 0)
    rgn3 = CreateRectRgn(0, 0, 0, 0)
    i = 1
    X1 = bg.Width / Screen.TwipsPerPixelX
    Y1 = bg.Height / Screen.TwipsPerPixelY
    Do While i < X1
        j = 1
        Do While j < Y1
            If GetPixel(bg.hdc, i, j) <> transColor Then
                 tj = j
                 Do While GetPixel(bg.hdc, i, j + 1) <> transColor
                     j = j + 1
                     If j = Y1 Then Exit Do
                 Loop
                 rgn4 = CreateRectRgn(i, tj, i + 1, j + 1)
                 CombineRgn rgn3, Rgn2, Rgn2, 5
                 CombineRgn Rgn2, rgn4, rgn3, 2
                 DeleteObject rgn4
            End If
            j = j + 1
        Loop
        CombineRgn rgn3, rgn, rgn, 5
        CombineRgn rgn, Rgn2, rgn3, 2
        i = i + 1
    Loop
    SetWindowRgn bg.hwnd, rgn, True
    DeleteObject rgn
    DeleteObject Rgn2
    DeleteObject rgn3
End Sub在使用之前请把form的borderstyle设置为0，如果使用第二种方法把AutoRedraw设置为TRUE。把FORM的Picture属性设置为你的图片。
Private Sub Form_Load()
SetAutoRgn Me  '第二个参数可不写，则用窗体的第一个像素作为透明色
'DoTransparency Me, vbRed  '第二个参数为窗体中不需要显示的颜色值
End Sub

Answer 4

放一个苹果的图片，用api处理就可以了

Answer 5

http://community.csdn.net/Expert/topic/4356/4356706.xml?temp=.3541834

Answer 6

Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 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 Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) 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 GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Const RGN_OR = 2
Private 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 Sub SetAutoRgn(hForm As Form, Optional transColor As Byte = vbNull)
    Dim bmByte() As Byte
    Dim X As Long, Y As Long
    Dim Rgn1 As Long, Rgn2 As Long
    Dim SPos As Long, EPos As Long
    Dim bm As BITMAP
    Dim hbm As Long
    Dim Wid As Long, Hgt As Long
    Dim xoff As Long, yoff As Long
    '获取窗体背景图片尺寸
    hbm = hForm.Picture
    GetObjectAPI hbm, Len(bm), bm
    Wid = bm.bmWidth
    Hgt = bm.bmHeight
    ReDim bmByte(1 To Wid, 1 To Hgt)
    GetBitmapBits hbm, Wid * Hgt, bmByte(1, 1) '获取图像数组
    '如果没有传入transColor参数，则用第一个像素作为透明色
    If transColor = vbNull Then transColor = bmByte(1, 1)
    Rgn1 = CreateRectRgn(0, 0, 0, 0)
    For Y = 1 To Hgt '逐行扫描
        X = 0
        Do
            X = X + 1
            While (bmByte(X, Y) = transColor) And (X < Wid)
                X = X + 1 '跳过是透明色的点
            Wend
            SPos = X
            While (bmByte(X, Y) <> transColor) And (X < Wid)
                X = X + 1 '跳过不是透明色的点
            Wend
            EPos = X - 1
            '这一段是合并区域
            If SPos <= EPos Then
                Rgn2 = CreateRectRgn(SPos - 1, Y - 1, EPos, Y)
                CombineRgn Rgn1, Rgn1, Rgn2, RGN_OR
                DeleteObject Rgn2
            End If
        Loop Until X >= Wid
    Next Y
    Erase bmByte()
    SetWindowRgn hForm.hwnd, Rgn1, True '设定窗体形状区域
    DeleteObject Rgn1
End Sub
incubus(梦淫妖) ( ) 啊！
这段代码怎么让我这么眼熟悉啊！看来看去。我发现是我写的哎！注释变量一点都不差嘛！
哎。不过这段代码的确值得收藏。我也一直把它存着呢！
不过不知道速度怎么样啊！