vb农历公历转换系统设计 第9页
Case Else
               ShowNumSam wPw2(1), Pt, 0, 1, i
     End Select
  Next i
End Sub
Public Sub SetAutoRgn(hForm As Form, Optional transColor As Byte = vbNull)
    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
    '获取窗体背景图片尺寸
    hbm = hForm.Picture
    GetObjectAPI hbm, Len(bm), bm
    Wid = bm.bmWidth ' ScaleX(Picture2.Width, vbTwips, vbPixels)
    Hgt = bm.bmHeight ' ScaleY(Picture2.Height, vbTwips, vbPixels)
    ReDim bmByte(1 To Wid, 1 To Hgt)
    GetBitmapBits hForm.Picture, Wid * Hgt, bmByte(1, 1) '获取图像数组
    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
    SetWindowRgn hForm.hwnd, Rgn1, True '设定窗体形状区域
    DeleteObject Rgn1
End Sub
Public Sub Ji_suan()
        f = ""
        txtDisp.Text = e
        op = ""
        chk = 1
End Sub
Public Sub txt_Sub()
       Select Case Val(Text2.Text)
         Case 1, 3, 5, 7, 8, 10, 12
            UpDown3.Max = 31
         Case 4, 6, 9, 11
            UpDown3.Max = 30
         Case 2
            If ((Val(Text1.Text) Mod 4) = 0) And ((Val(Text1.Text) Mod 100) <> 0) Or ((Val(Text1.Text) Mod 400) = 0) Then
                UpDown3.Max = 29
            Else
                UpDown3.Max = 28
            End If
       End Select
End Sub
Public Sub s_Disp()
  Dim kDay1 As Date, skDay1 As String
  Text4.Text = sdayF(Val(Text1.Text), Val(Text2.Text), Val(Text3.Text))
    skDay1 = Text1.Text + "," + Text2.Text + "," + Text3.Text
    kDay1 = skDay1
    disPlay (kDay1)
End Sub

Public Sub op_Sub()
     MPl.Play
    Select Case op
        Case "+"
            e = Str(Val(e) + Val(f))
            f = ""
        Case "-"
            e = Str(Val(e) - Val(f))
            f = ""
        Case "*"
            e = Str(Val(e) * Val(f))
            f = ""
        Case "/"
            e = Str(Val(e) / Val(f))
            f = ""
        Case "^"
            e = Str(Val(e) ^ Val(f))
            f = ""
    End Select
End Sub

二、提示信息模块相关代码：
Option Explicit
Private Const SWP_NOMOVE = 2
Private Const SWP_NOSIZE = 1
Private Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Const HTCAPTION = 2
Const WM_NCLBUTTONDOWN = &HA1
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 Long) As Long
' 内存中的提示数据库。
Dim Tips As New Collection
' 提示文件名称
Const TIP_FILE = "TIPOFDAY.TXT"
' 当前正在显示的提示集合的索引。
Dim CurrentTip As Long
Private Sub DoNextTip()
  If Op1.Value = 1 Then
    ' 随机选择一条提示。
    CurrentTip = Int((Tips.Count * Rnd) + 1)
  Else
    ' 或者，您可以按顺序遍历提示
   CurrentTip = CurrentTip + 1
    If Tips.Count < CurrentTip Then
        CurrentTip = 1
    End If
  End If
    ' 显示它。
    frmTip.DisplayCurrentTip
  End Sub
Function LoadTips(sFile As String) As Boolean
    Dim NextTip As String   ' 从文件中读出的每条提示。
    Dim InFile As Integer   ' 文件的描述符。
     ' 包含下一个自由文件描述符。
    InFile = FreeFile
    ' 确定为指定文件。

上一页  [1] [2] [3] [4] [5] [6] [7] [8] [9] [10] 下一页