form1.frm

生成50年内的阴历表的sqlserver代码,能够在sqlserver中创建阴历表,并写入阴历值.

VERSION 5.00
Object = "{092CEE2B-A97D-11D1-A113-44B1FCC00000}#16.0#0"; "calendar.ocx"
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   7455
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   13080
   LinkTopic       =   "Form1"
   ScaleHeight     =   7455
   ScaleWidth      =   13080
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command3 
      Caption         =   "生成sql"
      Height          =   645
      Left            =   8205
      TabIndex        =   3
      Top             =   2370
      Width           =   1845
   End
   Begin VB.CommandButton Command2 
      Caption         =   "Command2"
      Height          =   1065
      Left            =   9600
      TabIndex        =   2
      Top             =   4470
      Width           =   1815
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   690
      Left            =   7620
      TabIndex        =   1
      Top             =   4890
      Width           =   1830
   End
   Begin VB.TextBox Text1 
      Height          =   6480
      Left            =   225
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   0
      Top             =   195
      Width           =   6855
   End
   Begin 农历控件.Calendar Calendar1 
      Left            =   8535
      Top             =   1395
      _ExtentX        =   847
      _ExtentY        =   794
      DateNow         =   39333
      ChineseDate     =   "七月廿七"
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub Command1_Click()
    Dim A As Long
    Dim S As String
    Dim YangLi As String
    Dim YinLi As String, YinLiYue As String
    For A = 1 To 5000
        YangLi = Format(DateAdd("d", A, "2007-01-01"), "YYYY-MM-DD")
        Calendar1.DateNow = YangLi
        YinLi = Calendar1.ChineseDate
        Text1.Text = Text1.Text & YinLi & vbCrLf
'        YinLiYue = Mid(YinLi, 3)
'        If (InStr(1, Text1.Text, YinLiYue) = 0) Then
'            Text1.Text = Text1.Text & vbCrLf & YinLiYue
'        End If
    Next
    
End Sub

'把阴历转为数字型的
'正月初一 : 01-01
'腊月廿五 : 12-25
Private Function 数字阴历(ByVal 阴历 As String) As String
    Dim 阴历月 As String, month As String
    Dim 阴历日 As String, day As String
    Dim Rval As String
    阴历月 = Mid(阴历, 1, 2)
    阴历日 = Mid(阴历, 3, 2)
    Select Case 阴历月
        Case "正月"
            month = "01"
        Case "二月"
            month = "02"
        Case "三月"
            month = "03"
        Case "四月"
            month = "04"
        Case "五月"
            month = "05"
        Case "六月"
            month = "06"
        Case "七月"
            month = "07"
        Case "八月"
            month = "08"
        Case "九月"
            month = "09"
        Case "十月"
            month = "10"
        Case "冬月"
            month = "11"
        Case "腊月"
            month = "12"
    End Select
    Select Case 阴历日
        Case "初一"
            day = "01"
        Case "初二"
            day = "02"
        Case "初三"
            day = "03"
        Case "初四"
            day = "04"
        Case "初五"
            day = "05"
        Case "初六"
            day = "06"
        Case "初七"
            day = "07"
        Case "初八"
            day = "08"
        Case "初九"
            day = "09"
        Case "初十"
            day = "10"
        Case "十一"
            day = "11"
        Case "十二"
            day = "12"
        Case "十三"
            day = "13"
        Case "十四"
            day = "14"
        Case "十五"
            day = "15"
        Case "十六"
            day = "16"
        Case "十七"
            day = "17"
        Case "十八"
            day = "18"
        Case "十九"
            day = "19"
        Case "二十"
            day = "20"
        Case "廿一"
            day = "21"
        Case "廿二"
            day = "22"
        Case "廿三"
            day = "23"
        Case "廿四"
            day = "24"
        Case "廿五"
            day = "25"
        Case "廿六"
            day = "26"
        Case "廿七"
            day = "27"
        Case "廿八"
            day = "28"
        Case "廿九"
            day = "29"
        Case "三十"
            day = "30"
    End Select
    Rval = month & "-" & day
    数字阴历 = Rval
End Function

Private Sub Command2_Click()
    Calendar1.DateNow = "2031-12-31"
    MsgBox Calendar1.ChineseDate
    'MsgBox 数字阴历(Calendar1.ChineseDate)
End Sub

Private Sub Command3_Click()
    Dim S As String
    Dim A As Long
    Dim d As String
    Dim YL As String
    'MsgBox DateAdd("d", 7304, "2007-01-01")
    For A = 0 To 2000
        d = Format(DateAdd("d", A, "2026-12-31"), "YYYY-MM-DD")
        Calendar1.DateNow = d
        YL = Calendar1.ChineseDate
        S = S & "insert into XZY阴历 values('" & d & "','" & getweek(d) & "','" & Calendar1.ChineseGanZhi & "','" & Calendar1.ChineseAnimal & "','" & Mid(YL, 1, 2) & "','" & Mid(YL, 3) & "','" & Mid(数字阴历(YL), 1, 2) & "','" & Mid(数字阴历(YL), 4) & "')" & vbCrLf
    Next
    Call SaveData(S, "c:\a.txt")
End Sub
Public Function getweek(ByVal d As String)
    Select Case Weekday(d, vbMonday)
        Case 1
            getweek = "一"
        Case 2
            getweek = "二"
        Case 3
            getweek = "三"
        Case 4
            getweek = "四"
        Case 5
            getweek = "五"
        Case 6
            getweek = "六"
        Case 7
            getweek = "日"
    End Select
End Function
Public Function SaveData(strData As String, strFileName As String) As Long
 
    On Error GoTo SysErr:
    Dim I As Integer

    SaveData = 1
                     
    Open strFileName For Output As #1              '写文件
        Print #1, strData
    Close #1
    
    Exit Function
SysErr:
    Close #1
    MsgBox Err.Description
'    ShowMsg (Err.Description)
End Function