frmregion.bas

一个clock的 vb 源码

Attribute VB_Name = "frmRegion"
Option Explicit

Public Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDc As Long) As Long

Public BmpObject As BITMAP
Public hDcMem As Long, hDcMemt As Long
Private hBmp As Long, hBmpt As Long

Public Sub AppInitialize(hWnd As Long)
    Dim StrPath As String
    Dim BmpBackFile As String, BmpTimeFile As String
    
    Call ShowWindow(hWnd, SW_HIDE)
        
    StrPath = GetKeyValue(HKEY_CURRENT_USER, "Software\Alarm Clock\Option", "SkinPath")

    BmpBackFile = StrPath & "\" & GetKeyValue(HKEY_CURRENT_USER, "Software\Alarm Clock\Load", "BmpBack")
    BmpTimeFile = StrPath & "\" & GetKeyValue(HKEY_CURRENT_USER, "Software\Alarm Clock\Load", "BmpTime")
    
    ' 判断注册表的键值以及文件是否存在
    ' 由于 LoadResImage 函数的原因不能在 VB 中进行调试
    If BmpBackFile <> "\" And (Dir(BmpBackFile) <> "") Then
        hBmp = LoadImage(0, BmpBackFile, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE)
            If hBmp = 0 Then   ' 判断图片格式
                Call MessageBox(hWnd, "您可能使用了非位图格式的图片来用作程序的外观图片，单击确定" & vbCrLf & "按钮可以忽略此错误。", "未知的图片格式", MB_ICONEXCLAMATION)
                hBmp = LoadResImage(App.hInstance, 2, IMAGE_BITMAP, 0, 0, 0)
            End If
    Else
        hBmp = LoadResImage(App.hInstance, 2, IMAGE_BITMAP, 0, 0, 0)
    End If
    
    If BmpTimeFile <> "\" And (Dir(BmpTimeFile) <> "") Then
        hBmpt = LoadImage(0, BmpTimeFile, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE)
            If hBmpt = 0 Then
                Call MessageBox(hWnd, "您可能使用了非位图格式的图片来用作程序的外观图片，单击确定" & vbCrLf & "按钮可以忽略此错误。", "未知的图片格式", MB_ICONEXCLAMATION)
                hBmpt = LoadResImage(App.hInstance, 3, IMAGE_BITMAP, 0, 0, 0)
            End If
    Else
        hBmpt = LoadResImage(App.hInstance, 3, IMAGE_BITMAP, 0, 0, 0)
    End If
        
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
    Call GetObjects(hBmp, Len(BmpObject), BmpObject)    ' 获取图片大小
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
End Sub
Public Sub SltBmphDc(hWnd As Long)
    If hDcMem <> 0 Then: Call DeleteDC(hDcMem)
    If hDcMemt <> 0 Then: Call DeleteDC(hDcMemt)
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
    Dim hDc As Long
    hDc = GetDC(hWnd)
    hDcMem = CreateCompatibleDC(hDc)      ' 创建内存设备场景
    hDcMemt = CreateCompatibleDC(hDc)
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
    Call SelectObject(hDcMem, hBmp)     ' 将取得的图片选入设备场景
    Call SelectObject(hDcMemt, hBmpt)
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
    Call DeleteObject(hBmp)             ' 释放资源
    Call DeleteObject(hBmpt)
    Call ReleaseDC(hWnd, hDc)
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
End Sub

Public Sub SetPosition(hWnd As Long)
    '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
    Dim strLeft As String, strTop As String     ' 窗口的位置
    Dim DesktopRect As RECT, hWndDesktop As Long
    
    hWndDesktop = GetDesktopWindow
    GetWindowRect hWndDesktop, DesktopRect
    
    strLeft = GetKeyValue(HKEY_CURRENT_USER, "Software\Alarm Clock\Load", "ClockLeft")
    strTop = GetKeyValue(HKEY_CURRENT_USER, "Software\Alarm Clock\Load", "ClockTop")

    If strLeft <> "" And strTop <> "" And IsNumeric(strLeft) And IsNumeric(strTop) Then
        MoveWindow hWnd, CLng(strLeft), CLng(strTop), BmpObject.bmWidth, BmpObject.bmHeight, 1
    Else
        MoveWindow hWnd, (DesktopRect.Right - BmpObject.bmWidth) / 2, (DesktopRect.Bottom - BmpObject.bmHeight) / 2, BmpObject.bmWidth, BmpObject.bmHeight, 1
    End If
    
End Sub

Public Function SetfrmRgn(hWnd As Long, hDcMem As Long, frmWidth As Long, frmHeight As Long) As Long
    '----------------------------------------------------
    ' 这是一个图片引擎(它可将窗体的形状设置为图片的形状)
    ' 适用于Windows 98 及 Windows Me
    '----------------------------------------------------
    Dim X As Long, Y As Long, BeginLine As Long, hdestrgn As Long
    Dim First As Boolean, InLine As Boolean
    Dim hRgn As Long, Color As Long
    First = Not False

    '----------------------------------------------------------
    Color = GetPixel(hDcMem, 0, 0)

        For Y = 0 To frmHeight
        For X = 0 To frmWidth
    
            If GetPixel(hDcMem, X, Y) = Color Or X = frmWidth Then
            If InLine Then
                InLine = False
                hRgn = CreateRectRgn(BeginLine, Y, X, Y + 1)
                    If First Then
                        hdestrgn = hRgn
                        First = False
            Else
                CombineRgn hdestrgn, hdestrgn, hRgn, RGN_OR
                DeleteObject hRgn
            End If
            End If
            Else
                If Not InLine Then
                    InLine = True
                    BeginLine = X
                End If
            End If
        Next X
        Next Y
    '--------------------------------------------------------
    If SetfrmRgn <> 0 Then: Call SetWindowRgn(hWnd, 0, True)
    SetfrmRgn = SetWindowRgn(hWnd, hdestrgn, True)
End Function