Attribute VB_Name = "mod_Shape"
Option Explicit

Private Const HTCAPTION = 2
Private Const WM_NCLBUTTONDOWN = &HA1

Private Type BITMAPHEADER
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmbpImage As Integer
    bmBits As Long
End Type


Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Public Const WS_EX_LAYERED = &H80000
Public Const LWA_COLORKEY = &H1

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 CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

Public Type OSVERSIONINFO '
   dwOSVersionInfoSize As Long
   dwMajorVersion As Long
   dwMinorVersion As Long
   dwBuildNumber As Long
   dwPlatformId As Long           '1 = Windows 95/98
                                  '2 = Windows NT
   szCSDVersion As String * 128
End Type
Public Const VER_PLATFORM_WIN32_NT = 2
Public Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Integer


Public Function mkSkin(ByVal Form As Form, ByVal cTransparent As Long, Optional Image As String) As Boolean
    Dim iImage As BITMAPHEADER
    Dim Ret As Long
    Dim xdcImage, ydcImage As Byte
    Dim tImage As Boolean
    Dim bImage, bpImage, cImage, dtImage, etImage, hImage, hRgn, hRgnt, sImage, xImage, xMax, yImage, yMax As Long
    Dim lngRow As Long
    Dim lngCol As Long
    Dim lngStart As Long
    
    Dim OSInfo As OSVERSIONINFO
    Dim IsWindowsNTa As Boolean

    With OSInfo
        .dwOSVersionInfoSize = Len(OSInfo)
        .szCSDVersion = Space$(128)
        GetVersionEx OSInfo
        IsWindowsNTa = (.dwPlatformId = VER_PLATFORM_WIN32_NT)
    End With
    If IsWindowsNTa = True Then
        Form.Picture = LoadPicture(Image)
        hImage = Form.Picture
        GetObject Form.Picture, Len(iImage), iImage
        xMax = iImage.bmWidth
        yMax = iImage.bmHeight
        Form.Width = xMax * Screen.TwipsPerPixelX
        Form.Height = yMax * Screen.TwipsPerPixelY
        
        
        'Set the window style to 'Layered'
        Ret = GetWindowLong(Form.hwnd, GWL_EXSTYLE)
        Ret = Ret Or WS_EX_LAYERED
        SetWindowLong Form.hwnd, GWL_EXSTYLE, Ret
        'Set the opacity of the layered window to 128
        SetLayeredWindowAttributes Form.hwnd, cTransparent, 0, LWA_COLORKEY
        Form.Refresh
    Else
        Form.Picture = LoadPicture(Image)
        hImage = Form.Picture
        GetObject Form.Picture, Len(iImage), iImage
        xMax = iImage.bmWidth
        yMax = iImage.bmHeight
        hRgn = CreateRectRgn(0, 0, 0, 0)
        bpImage = 3
        sImage = xMax * yMax * bpImage
        Form.Width = xMax * Screen.TwipsPerPixelX
        Form.Height = yMax * Screen.TwipsPerPixelY
        ReDim pbImage(0 To sImage) As Byte
        ReDim pimage(0 To xMax, 0 To yMax) As Long
        GetBitmapBits hImage, sImage, pbImage(0)
        For bImage = 0 To sImage - 3 Step bpImage
            yImage = Int((bImage) / (xMax * bpImage))
            xImage = ((bImage) / bpImage) - ((yImage) * xMax)
            pimage(xImage, yImage) = RGB(pbImage(bImage), pbImage(bImage + 1), pbImage(bImage + 2))
        Next bImage
            
        For lngRow& = 0 To yMax - 1
            lngCol& = 0
            Do While lngCol& < xMax
                Do While lngCol& < xMax And pimage(lngCol, lngRow) = cTransparent
                    lngCol& = lngCol& + 1
                Loop
                If lngCol& < xMax Then
                    lngStart& = lngCol&
                    Do While lngCol& < xMax And pimage(lngCol, lngRow) <> cTransparent
                        lngCol& = lngCol& + 1
                    Loop
                    If lngCol& > xMax Then lngCol& = xMax
                    hRgnt = CreateRectRgn(lngStart&, lngRow&, lngCol&, lngRow& + 1)
                    CombineRgn hRgn, hRgn, hRgnt, 2
                    DeleteObject (hRgnt)
                End If
            Loop
        Next
            
        mkSkin = SetWindowRgn(Form.hwnd, hRgn, 1)
        DeleteObject hRgn
        Form.Refresh
    End If
End Function

Public Function mkSkin_old(ByVal Form As Form, ByVal cTransparent As Long, Optional Image As String) As Boolean
    Dim xdcImage, ydcImage As Byte
    Dim iImage As BITMAPHEADER
    Dim tImage As Boolean
    Dim bImage, bpImage, cImage, dtImage, etImage, hImage, hRgn, hRgnt, sImage, xImage, xMax, yImage, yMax As Long
    Form.Picture = LoadPicture(Image)
    hImage = Form.Picture
    GetObject Form.Picture, Len(iImage), iImage
    xMax = iImage.bmWidth
    yMax = iImage.bmHeight
    hRgn = CreateRectRgn(0, 0, 0, 0)
    bpImage = iImage.bmbpImage / 8
    sImage = xMax * yMax * bpImage
    If sImage = 0 Then
            mkSkin_old = False
            Exit Function
        End If
     Select Case Form.BorderStyle
            Case vbBSNone
                xdcImage = 0
                ydcImage = 0
            Case vbFixedSingle
                xdcImage = 2
                ydcImage = 21
            Case vbSizable
                xdcImage = 3
                ydcImage = 22
            Case vbFixedDialog
                xdcImage = 2
                ydcImage = 21
            Case vbFixedToolWindow
                xdcImage = 2
                ydcImage = 18
            Case vbSizableToolWindow
                xdcImage = 3
                ydcImage = 19
        End Select
    Form.Width = (xMax + xdcImage + 3) * Screen.TwipsPerPixelX
    Form.Height = (yMax + ydcImage + 3) * Screen.TwipsPerPixelY
    ReDim pbImage(1 To sImage) As Byte
    ReDim pimage(1 To xMax, 1 To yMax) As Long
    GetBitmapBits hImage, sImage, pbImage(1)
    Select Case bpImage
            Case 1
                For bImage = 1 To sImage
                    yImage = Int((bImage - 1) / (xMax * bpImage)) + 1
                    xImage = ((bImage - 1) / bpImage) - ((yImage - 1) * xMax) + 1
                    pimage(xImage, yImage) = pbImage(bImage)
                Next bImage
            Case 3
                For bImage = 1 To sImage - 3 Step bpImage
                    yImage = Int((bImage - 1) / (xMax * bpImage)) + 1
                    xImage = ((bImage - 1) / bpImage) - ((yImage - 1) * xMax) + 1
                    pimage(xImage, yImage) = RGB(pbImage(bImage), pbImage(bImage + 1), pbImage(bImage + 2))
                Next bImage
        End Select
        For yImage = (Form.ScaleTop / Screen.TwipsPerPixelY) + 1 To yMax
            xImage = 1
            tImage = False
                While xImage <> xMax + 1
                    cImage = pimage(xImage, yImage)
                    If cImage <> cTransparent And tImage = False Then
                            dtImage = xImage
                            tImage = True
                        End If
                If cImage <> cTransparent And xImage = xMax Then cImage = cTransparent
                If cImage = cTransparent And tImage = True Then
                            etImage = xImage
                            tImage = False
                            hRgnt = CreateRectRgn(dtImage + xdcImage, ydcImage + yImage, etImage + xdcImage, ydcImage + yImage + 1)
                            CombineRgn hRgn, hRgn, hRgnt, 2
                            DeleteObject hRgnt
                        End If
                xImage = xImage + 1
            Wend
        Next yImage
    mkSkin_old = SetWindowRgn(Form.hwnd, hRgn, 1)
    DeleteObject hRgn
    Form.Refresh
End Function

Function mvSkin(ByVal Form As Form, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = vbLeftButton Then
            ReleaseCapture
            SendMessage Form.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
        End If
End Function
