dlgabout.bas

一个clock的 vb 源码

Attribute VB_Name = "DlgAbout"
Option Explicit

'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' 这里是关于对话框
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
' 此乃 API 浏览器的 BUG 如按照此API会收到 Dll调用约定的错误 49
' Private Declare Function PtInRect Lib "user32" (lpRect As RECT, pt As POINTAPI) As Long

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Boolean
Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long

' DefSystem Cursor
Private Const IDC_HAND = 32649&

' Format Text
Private Const DT_LEFT = &H0

Private Const WM_LBUTTONUP = &H202

Private hFontCn As Long
Private hFontUEn As Long
Private hFont16En As Long
Private hFont15En As Long
Private hDcBlack As Long
Private EmailRect As RECT
Private HomePageRect As RECT
Private DlgAbuot As New clsDialog
Private urlTextColor As Boolean


Public Function CreateDlgAbout(hWndParent As Long)  'hWndParent As Long
    Call DlgAbuot.CreateDialog(hWndParent, AddressOf DlgProc)
    Set DlgAbuot = Nothing
End Function

Private Function DlgProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case uMsg
        Case WM_INITDIALOG
            Dim lpRect As RECT, hDesktop As Long
            hDesktop = GetDesktopWindow
            Call GetWindowRect(hDesktop, lpRect)
            Call MoveWindow(hWnd, (lpRect.Right - 350) / 2, (lpRect.Bottom - 190) / 2, 350, 190, 1)
            Call SendMessage(hWnd, WM_SETTEXT, 0, ByVal "关于 Alarm Clock")
            
            hFont16En = hFont(20, , "Times New Roman")  ' Size 18
            hFont15En = hFont(16, , "Times New Roman")  '      15
            hFontUEn = hFont(15, 1, "Times New Roman")  ' 15 And Under Line
            hFontCn = hFont(12)                         ' 12 China
            
            ' Email 文字区域
            EmailRect.Left = 206: EmailRect.Top = 118
            EmailRect.Right = 315:  EmailRect.Bottom = 133
            
            ' HomePage 文字区域
            HomePageRect.Left = 100: HomePageRect.Top = 118
            HomePageRect.Right = 200: HomePageRect.Bottom = 132
            
            urlTextColor = False  ' 初始化连接文字变量
            
            Dim hDcDlg As Long
            Dim hBmp As Long
            
            hDcDlg = GetDC(hWnd)
            hDcBlack = CreateCompatibleDC(hDcDlg)      ' 创建内存设备场景
            hBmp = LoadResImage(App.hInstance, 4, IMAGE_BITMAP, 0, 0, LR_LOADMAP3DCOLORS)
            
            Call ReleaseDC(hWnd, hDcDlg)
            
            If hBmp <> 0 Then
                    Call SelectObject(hDcBlack, hBmp)     ' 将取得的图片选入设备场景
                    SetTimer hWnd, 10, 260, 0                 ' 开始图片定时器
                    Call DeleteObject(hBmp)
            End If
            

        Case WM_TIMER
        '------------------------------------------------------------------------------------
            Dim ReRect As RECT
            If wParam = 10 Then
                With ReRect
                    .Left = 4: .Right = 350
                    .Top = 15: .Bottom = 80
                End With
                InvalidateRect hWnd, ReRect, 0
             End If
        '------------------------------------------------------------------------------------
        Case WM_PAINT
        '------------------------------------------------------------------------------------
            Dim hDc As Long
            Static I As Long
            Dim lpPaint As PAINTSTRUCT
            
            hDc = BeginPaint(hWnd, lpPaint)
            '--------------------------------------------------------------------------------
                    Call SelectObject(hDc, hFont16En)  ' 将16号大小的字体选入设备场景
                    Call SetBkMode(hDc, NEWTRANSPARENT)             ' 输出文字的背景
                    Call SetTextColor(hDc, RGB(Int((255 * Rnd) + 1), Int((255 * Rnd) + 1), Int((255 * Rnd) + 1)))
                    Call TextOut(hDc, 100, 16, "Alarm Clock 1.0", 15)
                
                    Call SelectObject(hDc, hFont15En)  ' 将15号大小的字体选入设备场景
                    Call SetTextColor(hDc, 0)
                    Call TextOut(hDc, 100, 45, "Copyright (C) 2001-2002 Jiang Jian", 34)
                
                    Call SelectObject(hDc, hFontCn)
                    TextOut hDc, 100, 70, "本软件为免费软件您可以自由使用或传播,其", 39
                    TextOut hDc, 10, 86, "它权利作者保留.本软件界面模仿罗云彬的卡通闹钟.软件100%", 54
                    TextOut hDc, 10, 102, "是用 Win32 API 编写决不包含控件、窗体、对话框资源.欢迎", 54
                    TextOut hDc, 10, 120, "访问VB编程站点:", 15
                    TextOut hDc, 10, 138, "作者：江建     2002年5月20日写于中国安徽淮南", 44

                    Call SelectObject(hDc, hFontUEn)   ' 将带下划线的字体选入设备场景
                    If urlTextColor Then
                        Call SetTextColor(hDc, vbRed)
                    Else
                        Call SetTextColor(hDc, vbBlue)
                    End If
                    Call DrawText(hDc, "Http://vbcc.126.com", -1, HomePageRect, DT_LEFT)
                    Call DrawText(hDc, "Email:[e-mail]", -1, EmailRect, DT_LEFT)
                '-----------------------------------------------------------------
                ' 动画输出
                Call BitBlt(hDc, 5, 15, 80, 64, hDcBlack, 80 * I, 0, SRCCOPY)
                I = I + 1
                If I = 14 Then I = 0
                '-----------------------------------------------------------------
            Call EndPaint(hWnd, lpPaint)
        '------------------------------------------------------------------------------------
        Case WM_LBUTTONDOWN
        '------------------------------------------------------------------------------------
            ' 以下几个消息是处理超连接的。
            ' 判断鼠标是否在区域内按下 如果是(设置颜色变量)并刷新文字区域
            If PtInRect(EmailRect, LoWord(lParam), HIWord(lParam)) Then
                urlTextColor = True
                InvalidateRect hWnd, EmailRect, 0
                Call SetCursor(LoadCursor(0, IDC_HAND))
            End If
            
            If PtInRect(HomePageRect, LoWord(lParam), HIWord(lParam)) Then
                urlTextColor = True
                InvalidateRect hWnd, HomePageRect, 0
                Call SetCursor(LoadCursor(0, IDC_HAND))
            End If
            
        '------------------------------------------------------------------------------------
        Case WM_LBUTTONUP
        '------------------------------------------------------------------------------------
            If PtInRect(EmailRect, LoWord(lParam), HIWord(lParam)) Then
                ShellExecute 0, "Open", "mailto:[e-mail]?Subject=I Like Colck Software", 0, 0, 0
                urlTextColor = False
                InvalidateRect hWnd, EmailRect, 0
                Call SetCursor(LoadCursor(0, IDC_HAND))
            End If
            
            If PtInRect(HomePageRect, LoWord(lParam), HIWord(lParam)) Then
                ShellExecute 0, "Open", "Http://vbcc.126.com", 0, 0, 0
                urlTextColor = False
                InvalidateRect hWnd, HomePageRect, 0
                Call SetCursor(LoadCursor(0, IDC_HAND))
            End If
        '------------------------------------------------------------------------------------
        Case WM_MOUSEMOVE
        '------------------------------------------------------------------------------------
            If PtInRect(EmailRect, LoWord(lParam), HIWord(lParam)) Or PtInRect(HomePageRect, LoWord(lParam), HIWord(lParam)) Then
                Call SetCursor(LoadCursor(0, IDC_HAND))
            Else
                urlTextColor = False
                InvalidateRect hWnd, EmailRect, 0
                InvalidateRect hWnd, HomePageRect, 0
            End If
        '------------------------------------------------------------------------------------
        Case WM_CLOSE
            Call KillTimer(hWnd, 10)
            Call DeleteDC(hDcBlack)
            DeleteObject hFont15En
            DeleteObject hFont16En
            DeleteObject hFontUEn
            DeleteObject hFontCn
            Call EndDialog(hWnd, 0)
    End Select
End Function


Private Function hFont(Optional nHeight As Long = 16, Optional fdwUnderline As Long = 0, Optional lpszFace As String = "宋体") As Long
    hFont = CreateFont(nHeight, 0, 0, 0, 400, 0, fdwUnderline, 0, DEFAULT_CHARSET, _
            OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, _
            DEFAULT_PITCH Or FF_DONTCARE, lpszFace)
End Function