vs.net2005技术总结

1.DataGridView定位当前选中行.

                   Dim nRowIndex As Integer = 0

                    If dgv.Rows.Count > 0 Then
                        nRowIndex = dgv.CurrentRow.Index
                    End If
                   
                    dgv.DataSource = cswt_jDish.GetAll(True)
                    dgv.CurrentCell = dgv.Rows(nRowIndex).Cells(0)

 

2.移动Panel  (说明:label1在panel3内的最上方,目的是给panel3一个可拖动的区域)

     Private Sub Label1_MouseDown(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles

Label1.MouseDown
        OldPanlLoction = New Point(Me.Panel3.Location.X, Me.Panel3.Location.Y)
        OldMouseLoction = e.Location
        Panel3.Cursor = Windows.Forms.Cursors.SizeAll
    End Sub
    Dim OldPanlLoction As System.Drawing.Point '记录旧的panl坐标
    Dim OldMouseLoction As System.Drawing.Point '记录旧的鼠标坐标
    Dim MouseChangeLoction As System.Drawing.Point '鼠标移动的差值

    Private Sub Label1_MouseUp(ByVal sender As System.Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles

Label1.MouseUp
        Panel3.Cursor = Windows.Forms.Cursors.Hand
        MouseChangeLoction = New Point(OldPanlLoction.X + (e.X - OldMouseLoction.X), OldPanlLoction.Y + (e.Y -

OldMouseLoction.Y))
        Me.Panel3.Location = MouseChangeLoction
    End Sub

 

3.用四个按钮控制DataGridView的滚动条.
   dgvSelect.DisplayedRowCount(False)表示DataGridView显示给用户区域的行数.其中参数true为包括没显示全的,false表示只取完全显示

的行.
   dgvSelect.FirstDisplayedScrollingRowIndex 表示当前DataGridView可见行中的第一行的序号.
   因为列可能会有隐藏,所以在左右方向移动的时候判断是否隐藏列.

Private Sub btnUP_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnUP.Click
        Try
            If dgvSelect.FirstDisplayedScrollingRowIndex <= 0 Then
                If dgvSelect.CurrentRow.Index > 0 Then
                    dgvSelect.Rows(dgvSelect.SelectedRows(0).Index - 1).Selected = True'控制当前选中行继续向上
                End If
            Else
                dgvSelect.FirstDisplayedScrollingRowIndex -= 1
                dgvSelect.Rows(dgvSelect.FirstDisplayedScrollingRowIndex + dgvSelect.DisplayedRowCount(False) - 1).Selected =

True
            End If

        Catch ex As Exception

        End Try

    End Sub

    Private Sub btnDown_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnDown.Click
        Try
            dgvSelect.FirstDisplayedScrollingRowIndex += 1
            dgvSelect.Rows(dgvSelect.FirstDisplayedScrollingRowIndex + dgvSelect.DisplayedRowCount(False) - 1).Selected =

True
        Catch ex As Exception

        End Try

    End Sub

    Private Sub btnLeft_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnLeft.Click
        Try
            Dim i As Integer = 1
            Dim s As Boolean = False
            Dim k As Integer = 0
            k = dgvSelect.FirstDisplayedScrollingColumnIndex
            Do While s = False
                If dgvSelect.Columns(k - i).Visible = False Then
                    i += 1
                Else
                    s = True
                End If
            Loop
            dgvSelect.FirstDisplayedScrollingColumnIndex -= i
        Catch ex As Exception

        End Try
    End Sub

    Private Sub btnRight_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnRight.Click
        Try
            Dim i As Integer = 1
            Dim s As Boolean = False
            Dim k As Integer = 0
            k = dgvSelect.FirstDisplayedScrollingColumnIndex
            Do While s = False
                If dgvSelect.Columns(k + i).Visible = False Then
                    i += 1
                Else
                    s = True
                End If
            Loop

            dgvSelect.FirstDisplayedScrollingColumnIndex += i
        Catch ex As Exception

        End Try
    End Sub

4.子窗体控制父窗体控件.

父窗体需要打开子窗体的地方加入过程:
Private Sub OpenChild()
        For Each f As Form In Me.MdiChildren
           If f.Name = "fmswt_Scrolling" Then
                f.Activate()
                Return
            End If
        Next
        Dim frm As fmswt_Scrolling = New fmswt_Scrolling(Me)
        ''frm.MdiParent = Me
        frm.Show()
        frm.BringToFront()
    End Sub
在子窗体中加入:
Private MyForm As fmswt_yAddDishItem'此处为父窗体
    Sub New(ByVal f As fmswt_yAddDishItem)

        ' 此调用是 Windows 窗体设计器所必需的。
        InitializeComponent()
        MyForm = f
        ' 在 InitializeComponent() 调用之后添加任何初始化。

    End Sub

    Private Sub btnUP_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnUP.Click
        If MyForm.dgvSelect.FirstDisplayedScrollingRowIndex = 0 Then Exit Sub
        MyForm.dgvSelect.FirstDisplayedScrollingRowIndex -= 1
    End Sub

 

5.取系统分辨率:
Public Function GetScreenScale() As Integer
        Dim rect As Drawing.Rectangle = Screen.PrimaryScreen.Bounds
        If rect.Width = 1024 AndAlso rect.Height = 768 Then Return 2
        If rect.Width = 800 AndAlso rect.Height = 600 Then Return 1
        Return 2
    End Function

6.注册表访问:
Public Function SetReg(ByVal Key As String, ByVal Item As String, ByVal value As Object) As Boolean
        Try
            My.Computer.Registry.SetValue(Key, Item, value)
            Return True
        Catch ex As Exception
            Return False
        End Try
    End Function

    Public Function GetReg(ByVal Key As String, ByVal Item As String, ByVal DefaultValue As Object) As Object
        Try
            Return My.Computer.Registry.GetValue(key, Item, DefaultValue)
        Catch ex As Exception
            Return Nothing
        End Try
    End Function

7.格式化本机日期格式:
Public Function UpdateTimeFormat() As Boolean
        Try
            Dim sKey As String = "HKEY_CURRENT_USER/Control Panel/International"
            If GetReg(sKey, "s1159", "").ToString.Trim <> "上午" Then SetReg(sKey, "s1159", "上午")
            If GetReg(sKey, "s2359", "").ToString.Trim <> "下午" Then SetReg(sKey, "s2359", "下午")
            If GetReg(sKey, "sLongDate", "").ToString.Trim <> "yyyy'年'M'月'd'日'" Then SetReg(sKey, "sLongDate", "yyyy'年'M'

月'd'日'")
            If GetReg(sKey, "sShortDate", "").ToString.Trim <> "yyyy-MM-dd" Then SetReg(sKey, "sShortDate", "yyyy-MM-dd")
            If GetReg(sKey, "sThousand", "").ToString.Trim <> "," Then SetReg(sKey, "sThousand", ",")
            If GetReg(sKey, "sTime", "").ToString.Trim <> ":" Then SetReg(sKey, "sTime", ":")
            If GetReg(sKey, "sLongDate16", "").ToString.Trim <> "dddd', 'MMMM' 'dd', 'yyyy" Then SetReg(sKey, "sLongDate16",

"dddd', 'MMMM' 'dd', 'yyyy")
            If GetReg(sKey, "sTimeFormat", "").ToString.Trim <> "HH:mm:ss" Then SetReg(sKey, "sTimeFormat", "HH:mm:ss")
            If GetReg(sKey, "sMonDecimalSep", "").ToString.Trim <> "." Then SetReg(sKey, "sMonDecimalSep", ".")
            If GetReg(sKey, "sMonThousandSep", "").ToString.Trim <> "," Then SetReg(sKey, "sMonThousandSep", ",")
            If GetReg(sKey, "iNegNumber", "").ToString.Trim <> "1" Then SetReg(sKey, "iNegNumber", "1")
            If GetReg(sKey, "sNativeDigits", "").ToString.Trim <> "0123456789" Then SetReg(sKey, "sNativeDigits",

"0123456789")
            If GetReg(sKey, "sNegativeSign", "").ToString.Trim <> "-" Then SetReg(sKey, "sNegativeSign", "-")

            'My.Computer.Registry.SetValue("HKEY_CURRENT_USER/Control Panel/International", "s1159", "上午")
            'My.Computer.Registry.SetValue("HKEY_CURRENT_USER/Control Panel/International", "s2359", "下午")
            'My.Computer.Registry.SetValue("HKEY_CURRENT_USER/Control Panel/International", "sLongDate",

"yyyy'年'M'月'd'日'")
            'My.Computer.Registry.SetValue("HKEY_CURRENT_USER/Control Panel/International", "sShortDate", "yyyy-MM-dd")
            'My.Computer.Registry.SetValue("HKEY_CURRENT_USER/Control Panel/International", "sThousand", ",")
            'My.Computer.Registry.SetValue("HKEY_CURRENT_USER/Control Panel/International", "sTime", ":")
            'My.Computer.Registry.SetValue("HKEY_CURRENT_USER/Control Panel/International", "sLongDate16", "dddd', 'MMMM'

'dd', 'yyyy")
            'My.Computer.Registry.SetValue("HKEY_CURRENT_USER/Control Panel/International", "sTimeFormat", "HH:mm:ss")
            'My.Computer.Registry.SetValue("HKEY_CURRENT_USER/Control Panel/International", "sMonDecimalSep", ".")
            'My.Computer.Registry.SetValue("HKEY_CURRENT_USER/Control Panel/International", "sMonThousandSep", ",")
            'My.Computer.Registry.SetValue("HKEY_CURRENT_USER/Control Panel/International", "iNegNumber", "1")
            'My.Computer.Registry.SetValue("HKEY_CURRENT_USER/Control Panel/International", "sNativeDigits", "0123456789")
            'My.Computer.Registry.SetValue("HKEY_CURRENT_USER/Control Panel/International", "sNegativeSign", "-")
        Catch ex As Exception
            Return False
        End Try
        Return True
    End Function

8.取本机名称:
Public Function ComputerName() As String
        Try
            Return System.Net.Dns.GetHostName().Trim
        Catch ex As Exception
            Return ""
        End Try
       
    End Function

9.系统等待指定的秒:
Public Sub Wait(ByVal TimeLong As Long)
        Dim BeginTime As Date
        Dim EndTime As Date
        BeginTime = Now
        Do While True
            EndTime = Now
            If DateDiff(DateInterval.Second, BeginTime, EndTime) > TimeLong Then
                Exit Do
            End If
            Application.DoEvents()
        Loop
    End Sub

10.字节转换:
Public Function ToUnicode(ByVal strASCII As String) As String
        Try
            Dim ascii As Encoding = Encoding.ASCII
            Dim asciiBytes As Byte() = [ascii].GetBytes(strASCII)
            '转换成Unicode字节
            Dim unicodeBytes As Byte() = Encoding.Convert(Encoding.ASCII, Encoding.Unicode, asciiBytes, 0, asciiBytes.Length)

            Dim unicodeChars(Encoding.Unicode.GetCharCount(unicodeBytes, 0, unicodeBytes.Length)) As Char
            Encoding.Unicode.GetChars(unicodeBytes, 0, unicodeBytes.Length, unicodeChars, 0)
            Return New String(unicodeChars)  '返回Unicode字符串        Catch ex As Exception
            Return Nothing
        End Try
    End Function

    Public Function ToASCII(ByVal strUnicode As String) As String
        Try
            Dim unicode As Encoding = Encoding.Unicode
            Dim unicodeBytes As Byte() = [unicode].GetBytes(strUnicode)
            '转换成ASCII字节
            Dim asciiBytes As Byte() = Encoding.Convert(Encoding.Unicode, Encoding.ASCII, unicodeBytes, 0,

unicodeBytes.Length)

            Dim asciiChars(Encoding.ASCII.GetCharCount(asciiBytes, 0, asciiBytes.Length)) As Char
            Encoding.ASCII.GetChars(asciiBytes, 0, asciiBytes.Length, asciiChars, 0)
            Return New String(asciiChars)
        Catch ex As Exception
            Return Nothing
        End Try
    End Function

    Public Function ToUnicode(ByVal strASCII As String, ByVal bConvert As Boolean) As String
        Try
            Dim ascii As Encoding = Encoding.ASCII
            Dim asciiBytes As Byte() = [ascii].GetBytes(strASCII)
            '转换成Unicode字节
            Dim unicodeBytes As Byte() = Encoding.Convert(Encoding.ASCII, Encoding.Unicode, asciiBytes, 0, asciiBytes.Length)

            Dim unicodeChars(Encoding.Unicode.GetCharCount(unicodeBytes, 0, unicodeBytes.Length)) As Char
            Encoding.Unicode.GetChars(unicodeBytes, 0, unicodeBytes.Length, unicodeChars, 0)
            If bConvert Then
                For i As Integer = 0 To unicodeChars.Length - 1
                    unicodeChars(i) = ChrW(AscW(unicodeChars(i)) + 65535 - 2 * 256)
                Next
            End If
            Return New String(unicodeChars)  '返回Unicode字符串        Catch ex As Exception
            Return Nothing
        End Try
    End Function

    Public Function ToASCII(ByVal strUnicode As String, ByVal bConvert As Boolean) As String
        Try
            Dim unicode As Encoding = Encoding.Unicode
            Dim unicodeBytes As Byte() = [unicode].GetBytes(strUnicode)
            Dim unicodeChars(Encoding.Unicode.GetCharCount(unicodeBytes, 0, unicodeBytes.Length)) As Char
            Encoding.Unicode.GetChars(unicodeBytes, 0, unicodeBytes.Length, unicodeChars, 0)
            If bConvert Then
                For i As Integer = 0 To unicodeChars.Length - 1
                    If unicodeChars(i).Equals(Nothing) Then
                        unicodeChars(i) = Chr(0)
                        Exit For
                    End If
                    unicodeChars(i) = ChrW(AscW(unicodeChars(i)) - (65535 - 2 * 256))
                Next
            End If
            Dim strConverted As String = New String(unicodeChars)
            unicode = Encoding.Unicode
            unicodeBytes = [unicode].GetBytes(strConverted)
            '转换成ASCII字节
            Dim asciiBytes As Byte() = Encoding.Convert(Encoding.Unicode, Encoding.ASCII, unicodeBytes, 0,

unicodeBytes.Length)
            Dim asciiChars(Encoding.ASCII.GetCharCount(asciiBytes, 0, asciiBytes.Length)) As Char
            Encoding.ASCII.GetChars(asciiBytes, 0, asciiBytes.Length, asciiChars, 0)

            Return New String(asciiChars)
        Catch ex As Exception
            Return Nothing
        End Try
    End Function

 

11.检查时间格式:
''' <summary>
    ''' 检查是否时间格式
    ''' </summary>
    ''' <param name="psTime">要检查的时间</param>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Public Function CheckIsTime(ByVal psTime As String) As Boolean

        Dim r As New System.Text.RegularExpressions.Regex("^([0-1][0-9]|2[0-3]):[0-5][0-9]$")
        Dim m As System.Text.RegularExpressions.Match = r.Match(psTime)
        If m.Success = True Then
            Return True
        Else
            Return False
        End If

    End Function

''' <summary>
    ''' 检查字符串是否为日期时间类型
    ''' </summary>
    ''' <param name="psDateTime">要检查的日期时间字符串</param>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Public Function CheckIsDateTime(ByVal psDateTime As String) As Boolean

        Dim r As New System.Text.RegularExpressions.Regex("^[1-9][0-9][0-9][0-9]-(0[1-9]|1[0-2])-(0[1-9]|[1-2][0-9]|3[0-1])

([0-1][0-9]|2[0-3]):[0-5][0-9]$")
        Dim m As System.Text.RegularExpressions.Match = r.Match(psDateTime)

        If m.Success = True Then
            Return IsDate(psDateTime.Substring(1, 10).Replace("-", " "))
        Else
            Return False
        End If

    End Function

    ''' <summary>
    ''' 设置字符串为日期时间格式
    ''' </summary>
    ''' <param name="psDateTime"></param>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Public Function SetDateTimeFormat(ByVal psDateTime As String) As String
        psDateTime = SringAmendmentLen(psDateTime, 16)
        If CheckIsDateTime(psDateTime) = True Then
            Return psDateTime
        Else
            Return "2007-01-01 00:00"
        End If
    End Function

 

''' <summary>
    ''' 字符串调整长度
    ''' </summary>
    ''' <param name="psString">原字符串</param>
    ''' <param name="iLen">最大长度</param>
    ''' <returns></returns>
    ''' <remarks></remarks>
    <System.ComponentModel.Description("字符串调整长度")> _
    Public Function SringAmendmentLen(ByVal psString As String, ByVal iLen As Int16) As String
        If psString.Length > iLen Then
            Return psString.Substring(0, iLen)
        Else
            Return psString
        End If
    End Function

''' <summary>
    ''' 检查字符串是否为带年月的字符类型
    ''' </summary>
    ''' <param name="psYearMonth">要检查的带年月的字符串，“2001-01”</param>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Public Function CheckIsYearMonth(ByVal psYearMonth As String) As Boolean

        Dim r As New System.Text.RegularExpressions.Regex("^[1-9][0-9][0-9][0-9]-(0[1-9]|1[0-2])$")
        Dim m As System.Text.RegularExpressions.Match = r.Match(psYearMonth)

        Return m.Success
    End Function

 ''' <summary>
    ''' 字符转换为日期类型
    ''' </summary>
    ''' <param name="psDate">要转换的字符串</param>
    ''' <returns></returns>
    ''' <remarks></remarks>
    <System.ComponentModel.Description("字符转换为日期类型")> _
    Public Function CTtD(ByVal psDate As String) As Date
        If CheckDateFormat(psDate) = False Then
            Return Now
        End If
        Dim ReturnDate As Date = Date.ParseExact(psDate, "yyyy-MM-dd", System.Globalization.CultureInfo.CurrentCulture)
        Return ReturnDate
    End Function

    ''' <summary>
    ''' 检查是否日期格式
    ''' </summary>
    ''' <param name="psDate">要检查的数据</param>
    ''' <returns>是否为日期格式</returns>
    ''' <remarks></remarks>
    Public Function CheckDateFormat(ByVal psDate As String) As Boolean

        Dim r As New System.Text.RegularExpressions.Regex("^(/d{4}/-((0[1-9])|(1[012]))/-((0[1-9])|([1-2][0-9])|(3[01])))$")
        Dim m As System.Text.RegularExpressions.Match = r.Match(psDate)

        If m.Success = True Then
            Try
                Call Date.ParseExact(psDate, "yyyy-MM-dd", System.Globalization.CultureInfo.CurrentCulture)
                CheckDateFormat = True
            Catch ex As Exception
                CheckDateFormat = False
            End Try
            Return CheckDateFormat
        Else
            Return False
        End If

    End Function

''' <summary>
    ''' 检查是否日期格式
    ''' </summary>
    ''' <param name="psDate">要检查的数据</param>
    ''' <returns>是否为日期格式</returns>
    ''' <remarks></remarks>
    Public Function CheckDateFormat(ByVal psDate As String) As Boolean

        Dim r As New System.Text.RegularExpressions.Regex("^(/d{4}/-((0[1-9])|(1[012]))/-((0[1-9])|([1-2][0-9])|(3[01])))$")
        Dim m As System.Text.RegularExpressions.Match = r.Match(psDate)

        If m.Success = True Then
            Return True
        Else
            Return False
        End If

    End Function

    ''' <summary>
    ''' 字符转换为日期类型
    ''' </summary>
    ''' <param name="psDate">要转换的字符串</param>
    ''' <returns></returns>
    ''' <remarks></remarks>
    <System.ComponentModel.Description("字符转换为日期类型")> _
    Public Function CTtD(ByVal psDate As String) As Date
        If CheckDateFormat(psDate) = False Then
            Return CurrentDate
        End If
        Dim ReturnDate As Date = Date.ParseExact(psDate, "yyyy-MM-dd", System.Globalization.CultureInfo.CurrentCulture)
        Return ReturnDate
    End Function

12.插入指定长度的空格:

''' <summary>
    ''' 插入空格
    ''' </summary>
    ''' <param name="psSource">原文本</param>
    ''' <param name="piNum">插入的空格数</param>
    ''' <returns></returns>
    ''' <remarks></remarks>
    <System.ComponentModel.Description("插入指定长度的空格")> _
    Private Function InsertSpace(ByVal psSource As String, ByVal piNum As Int16) As String
        Dim Itemchar As Char
        Dim sReturn As String = ""
        For Each Itemchar In psSource
            sReturn += Itemchar & CreateString(piNum, "　")
        Next
        Return sReturn
    End Function

13.建立重复的字符

''' <summary>
    ''' 建立重复的字符
    ''' </summary>
    ''' <param name="piNum">字符个数</param>
    ''' <param name="psStr">重复的内容</param>
    ''' <returns>建立的结果</returns>
    ''' <remarks></remarks>
    <System.ComponentModel.Description("建立重复的字符")> _
    Public Function CreateString(ByVal piNum As Int16, ByVal psStr As String) As String
        Dim sReturn As String = ""
        Dim i As Int16
        For i = 0 To piNum - 1
            sReturn += psStr
        Next
        Return sReturn
    End Function

14.汉字转拼音缩写

''' <summary>
    ''' 汉字转拼音缩写
    ''' </summary>
    ''' <param name="char1">单个汉字字符</param>
    ''' <returns>转换后的拼音首字母</returns>
    ''' <remarks></remarks>
    Public Function getPYChar(ByVal char1 As String) As String
        Dim lChar As Integer
        lChar = 65536 + Asc(char1)
        If (lChar - 45217) >= 0 Then
            If (lChar - 45252) <= 0 Then
                Return "A"
            End If
        End If
        If lChar >= 45253 Then
            If lChar <= 45760 Then
                Return "B"
            End If
        End If
        If lChar >= 45761 Then
            If lChar <= 46317 Then
                Return "C"
            End If
        End If
        If lChar >= 46318 Then
            If lChar <= 46825 Then
                Return "D"
            End If
        End If
        If lChar >= 46826 Then
            If lChar <= 47009 Then
                Return "E"
            End If
        End If
        If lChar >= 47010 Then
            If lChar <= 47296 Then
                Return "F"
            End If
        End If
        If lChar >= 47297 Then
            If lChar <= 47613 Then
                Return "G"
            End If
        End If
        If lChar >= 47614 Then
            If lChar <= 48118 Then
                Return "H"
            End If
        End If
        If lChar >= 48119 Then
            If lChar <= 49061 Then
                Return "J"
            End If
        End If
        If lChar >= 49062 Then
            If lChar <= 49323 Then
                Return "K"
            End If
        End If
        If lChar >= 49324 Then
            If lChar <= 49895 Then
                Return "L"
            End If
        End If
        If lChar >= 49896 Then
            If lChar <= 50370 Then
                Return "M"
            End If
        End If
        If lChar >= 50371 Then
            If lChar <= 50613 Then
                Return "N"
            End If
        End If
        If lChar >= 50614 Then
            If lChar <= 50621 Then
                Return "O"
            End If
        End If
        If lChar >= 50622 Then
            If lChar <= 50905 Then
                Return "P"
            End If
        End If
        If lChar >= 50906 Then
            If lChar <= 51386 Then
                Return "Q"
            End If
        End If
        If lChar >= 51387 Then
            If lChar <= 51445 Then
                Return "R"
            End If
        End If
        If lChar >= 51446 Then
            If lChar <= 52217 Then
                Return "S"
            End If
        End If
        If lChar >= 52218 Then
            If lChar <= 52697 Then
                Return "T"
            End If
        End If
        If lChar >= 52698 Then
            If lChar <= 52979 Then
                Return "W"
            End If
        End If
        If lChar >= 52980 Then
            If lChar <= 53640 Then
                Return "X"
            End If
        End If
        If lChar >= 53641 Then
            If lChar <= 54480 Then
                Return "Y"
            End If
        End If
        If lChar >= 54481 Then
            If lChar <= 55282 Then
                Return "Z"
            End If
        End If
        Return ""
    End Function

    ''' <summary>
    ''' 根据字符串返回字符串的拼音缩写
    ''' </summary>
    ''' <param name="str">字符串</param>
    ''' <returns>拼音缩写</returns>
    ''' <remarks></remarks>
    Public Function getPY(ByVal str As String) As String
        Dim i As Integer
        Dim StrReturn As String
        StrReturn = ""
        For i = 0 To Len(str) - 1
            StrReturn = StrReturn & getPYChar(Mid(str, i + 1, 1))
        Next
        Return StrReturn
    End Function

15.字符日期转日期型

''' <summary>
    ''' 字符日期转日期型
    ''' </summary>
    ''' <param name="psDate">需转换字符，格式："2007-01-31 02:59"</param>
    ''' <param name="pdDate">返回转换后日期型对象</param>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Public Function sDateTodDate(ByVal psDate As String, ByRef pdDate As DateTime) As Boolean
        Try
            pdDate = New DateTime(Integer.Parse(psDate.Substring(0, 4)), Integer.Parse(psDate.Substring(5, 2)),

Integer.Parse(psDate.Substring(8, 2)), Integer.Parse(psDate.Substring(11, 2)), Integer.Parse(psDate.Substring(14, 2)), 0)
            sDateTodDate = True
        Catch ex As Exception
            sDateTodDate = False
        End Try
        Return sDateTodDate
    End Function

16.农历转新历

''' <summary>
    ''' 农历转新历
    ''' </summary>
    ''' <param name="pdDate">农历日期</param>
    ''' <param name="pbLeapMonth">若当前月份是润月，是否取润月日期，默认false</param>
    ''' <returns>新历日期</returns>
    ''' <remarks></remarks>
    Public Function GetOldtoNewDate(ByVal pdDate As Date, Optional ByVal pbLeapMonth As Boolean = False) As Date

        '合法性：1900~2100年之间
        If pdDate.Year < 1900 OrElse pdDate.Year > 2100 Then
            Return Nothing
        End If

        '1900~2100年之间的二进制编码
        '前12位对应每个月，1为30天，0为29天
        '后4位为润月的月份，"0000"为当年没有润月，"1111"为上一年的润月是30天，否则为29天
        '编码总计长度为16，不足则前面以0补足
        '新增年份可以添加到数组后面
        Dim lunarInfo() As Int32 = New Int32() { _
        &H4BD8, &H4AE0, &HA570, &H54D5, &HD260, &HD950, &H5554, &H56AF, &H9AD0, &H55D2, _
        &H4AE0, &HA5B6, &HA4D0, &HD250, &HD255, &HB54F, &HD6A0, &HADA2, &H95B0, &H4977, _
        &H497F, &HA4B0, &HB4B5, &H6A50, &H6D40, &HAB54, &H2B6F, &H9570, &H52F2, &H4970, _
        &H6566, &HD4A0, &HEA50, &H6A95, &H5ADF, &H2B60, &H86E3, &H92EF, &HC8D7, &HC95F, _
        &HD4A0, &HD8A6, &HB55F, &H56A0, &HA5B4, &H25DF, &H92D0, &HD2B2, &HA950, &HB557, _
        &H6CA0, &HB550, &H5355, &H4DAF, &HA5B0, &H4573, &H52BF, &HA9A8, &HE950, &H6AA0, _
        &HAEA6, &HAB50, &H4B60, &HAAE4, &HA570, &H5260, &HF263, &HD950, &H5B57, &H56A0, _
        &H96D0, &H4DD5, &H4AD0, &HA4D0, &HD4D4, &HD250, &HD558, &HB540, &HB6A0, &H95A6, _
        &H95BF, &H49B0, &HA974, &HA4B0, &HB27A, &H6A50, &H6D40, &HAF46, &HAB60, &H9570, _
        &H4AF5, &H4970, &H64B0, &H74A3, &HEA50, &H6B58, &H5AC0, &HAB60, &H96D5, &H92E0, _
        &HC960, &HD954, &HD4A0, &HDA50, &H7552, &H56A0, &HABB7, &H25D0, &H92D0, &HCAB5, _
        &HA950, &HB4A0, &HBAA4, &HAD50, &H55D9, &H4BA0, &HA5B0, &H5176, &H52BF, &HA930, _
        &H7954, &H6AA0, &HAD50, &H5B52, &H4B60, &HA6E6, &HA4E0, &HD260, &HEA65, &HD530, _
        &H5AA0, &H76A3, &H96D0, &H4AFB, &H4AD0, &HA4D0, &HD0B6, &HD25F, &HD520, &HDD45, _
        &HB5A0, &H56D0, &H55B2, &H49B0, &HA577, &HA4B0, &HAA50, &HB255, &H6D2F, &HADA0, _
        &H4B63, &H937F, &H49F8, &H4970, &H64B0, &H68A6, &HEA5F, &H6B20, &HA6C4, &HAAEF, _
        &H92E0, &HD2E3, &HC960, &HD557, &HD4A0, &HDA50, &H5D55, &H56A0, &HA6D0, &H55D4, _
        &H52D0, &HA9B8, &HA950, &HB4A0, &HB6A6, &HAD50, &H55A0, &HABA4, &HA5B0, &H52B0, _
        &HB273, &H6930, &H7337, &H6AA0, &HAD50, &H4B55, &H4B6F, &HA570, &H54E4, &HD260, _
        &HE968, &HD520, &HDAA0, &H6AA6, &H56DF, &H4AE0, &HA9D4, &HA4D0, &HD150, &HF252, _
        &HD520}

        Dim str As String
        Dim i As Int32, j As Int32
        Dim nDays As Int32

        nDays = 0

        '累加1900到指定日期的上一个年份的天数
        For i = 0 To pdDate.Year - 1900 - 1

            str = Convert.ToString(lunarInfo(i), 2)
            If str.Length < 16 Then
                Dim a As String = New String("0", 16 - str.Length)
                str = a & str
            End If

            For j = 1 To 12
                nDays = nDays + 29 + Val(Mid(str, j, 1))
            Next j

            If Convert.ToInt16(str.Substring(12, 4), 2) < 13 And Convert.ToInt16(str.Substring(12, 4), 2) <> 0 Then
                str = Convert.ToString(lunarInfo(i + 1), 2)
                If str.Length < 16 Then
                    Dim a As String = New String("0", 16 - str.Length)
                    str = a & str
                End If
                If Convert.ToString(str).Substring(12, 4) = "1111" Then
                    nDays = nDays + 30
                Else
                    nDays = nDays + 29
                End If
            End If

        Next

        '累加指定日期的第一个年份到上一个月的天数
        str = Convert.ToString(lunarInfo(pdDate.Year - 1900), 2)
        If str.Length < 16 Then
            Dim a As String = New String("0", 16 - str.Length)
            str = a & str
        End If
        For j = 1 To pdDate.Month - 1
            nDays = nDays + 29 + Val(Mid(str, j, 1))
        Next j
        If Convert.ToInt16(str.Substring(12, 4), 2) < pdDate.Month And Convert.ToInt16(str.Substring(12, 4), 2) <> 0 Then
            str = Convert.ToString(lunarInfo(pdDate.Year - 1900 + 1), 2)
            If str.Length < 16 Then
                Dim a As String = New String("0", 16 - str.Length)
                str = a & str
            End If
            If Convert.ToString(str).Substring(12, 4) = "1111" Then
                nDays = nDays + 30
            Else
                nDays = nDays + 29
            End If

            '若指定日期的月份有润月，并且取润月的日期时处理
        ElseIf Convert.ToInt16(str.Substring(12, 4), 2) = pdDate.Month Then
            If pbLeapMonth = True Then
                nDays = nDays + 29 + Val(Mid(str, pdDate.Month, 1))
            End If

        End If

        '累加指定日期当月的天数
        'nDays = nDays + pdDate.Day
        str = Convert.ToString(lunarInfo(pdDate.Year - 1900), 2)
        If str.Substring(pdDate.Month - 1, 1) = "1" Then
            If pdDate.Day = 31 Then
                Return Nothing
            Else
                nDays = nDays + pdDate.Day
            End If
        Else
            If pdDate.Day > 29 Then
                Return Nothing
            Else
                nDays = nDays + pdDate.Day
            End If
        End If

        '换算当前日期
        GetOldtoNewDate = DateAdd(DateInterval.Day, nDays - 1, Date.Parse("1900-01-31", New

System.Globalization.DateTimeFormatInfo))

        Return GetOldtoNewDate

    End Function

17.新历转旧历.
Public Function lunarDay(ByVal psInDay As String) As String

        Dim MonthAdd(11) As Long
        Dim NongliData(99) As Long
        Dim curTime As Date
        Dim curYear As Int16
        Dim curMonth As Int16
        Dim curDay As Int16
        Dim i, m, n, k, isEnd, bit As Long
        Dim TheDate As Long

        MonthAdd(0) = 0
        MonthAdd(1) = 31
        MonthAdd(2) = 59
        MonthAdd(3) = 90
        MonthAdd(4) = 120
        MonthAdd(5) = 151
        MonthAdd(6) = 181
        MonthAdd(7) = 212
        MonthAdd(8) = 243
        MonthAdd(9) = 273
        MonthAdd(10) = 304
        MonthAdd(11) = 334

        NongliData(0) = 2635
        NongliData(1) = 333387
        NongliData(2) = 1701
        NongliData(3) = 1748
        NongliData(4) = 267701
        NongliData(5) = 694
        NongliData(6) = 2391
        NongliData(7) = 133423
        NongliData(8) = 1175
        NongliData(9) = 396438
        NongliData(10) = 3402
        NongliData(11) = 3749
        NongliData(12) = 331177
        NongliData(13) = 1453
        NongliData(14) = 694
        NongliData(15) = 201326
        NongliData(16) = 2350
        NongliData(17) = 465197
        NongliData(18) = 3221
        NongliData(19) = 3402
        NongliData(20) = 400202
        NongliData(21) = 2901
        NongliData(22) = 1386
        NongliData(23) = 267611
        NongliData(24) = 605
        NongliData(25) = 2349
        NongliData(26) = 137515
        NongliData(27) = 2709
        NongliData(28) = 464533
        NongliData(29) = 1738
        NongliData(30) = 2901
        NongliData(31) = 330421
        NongliData(32) = 1242
        NongliData(33) = 2651
        NongliData(34) = 199255
        NongliData(35) = 1323
        NongliData(36) = 529706
        NongliData(37) = 3733
        NongliData(38) = 1706
        NongliData(39) = 398762
        NongliData(40) = 2741
        NongliData(41) = 1206
        NongliData(42) = 267438
        NongliData(43) = 2647
        NongliData(44) = 1318
        NongliData(45) = 204070
        NongliData(46) = 3477
        NongliData(47) = 461653
        NongliData(48) = 1386
        NongliData(49) = 2413
        NongliData(50) = 330077
        NongliData(51) = 1197
        NongliData(52) = 2637
        NongliData(53) = 268877
        NongliData(54) = 3365
        NongliData(55) = 531109
        NongliData(56) = 2900
        NongliData(57) = 2922
        NongliData(58) = 398042
        NongliData(59) = 2395
        NongliData(60) = 1179
        NongliData(61) = 267415
        NongliData(62) = 2635
        NongliData(63) = 661067
        NongliData(64) = 1701
        NongliData(65) = 1748
        NongliData(66) = 398772
        NongliData(67) = 2742
        NongliData(68) = 2391
        NongliData(69) = 330031
        NongliData(70) = 1175
        NongliData(71) = 1611
        NongliData(72) = 200010
        NongliData(73) = 3749
        NongliData(74) = 527717
        NongliData(75) = 1452
        NongliData(76) = 2742
        NongliData(77) = 332397
        NongliData(78) = 2350
        NongliData(79) = 3222
        NongliData(80) = 268949
        NongliData(81) = 3402
        NongliData(82) = 3493
        NongliData(83) = 133973
        NongliData(84) = 1386
        NongliData(85) = 464219
        NongliData(86) = 605
        NongliData(87) = 2349
        NongliData(88) = 334123
        NongliData(89) = 2709
        NongliData(90) = 2890
        NongliData(91) = 267946
        NongliData(92) = 2773
        NongliData(93) = 592565
        NongliData(94) = 1210
        NongliData(95) = 2651
        NongliData(96) = 395863
        NongliData(97) = 1323
        NongliData(98) = 2707
        NongliData(99) = 265877

        If psInDay = "" Or Not CheckDateFormat(psInDay) Then
            curTime = CurrentDate
        Else
            curTime = CTtD(psInDay)
        End If

        If DateDiff("d", curTime, CTtD("1921-02-08")) > 0 Then
            Return ""
        End If

        curYear = Microsoft.VisualBasic.Year(curTime)
        curMonth = Microsoft.VisualBasic.Month(curTime)
        curDay = Microsoft.VisualBasic.Day(curTime)

 

        TheDate = (curYear - 1921) * 365 + Int((curYear - 1921) / 4) + curDay + MonthAdd(curMonth - 1) - 38
        If ((curYear Mod 4) = 0 And curMonth > 2) Then
            TheDate = TheDate + 1
        End If

        isEnd = 0
        m = 0

        Do
            If (NongliData(m) < 4095) Then
                k = 11
            Else
                k = 12
            End If

            n = k

            Do
                If (n < 0) Then
                    Exit Do
                End If
                bit = NongliData(m)
                For i = 1 To n Step 1
                    bit = Int(bit / 2)
                Next
                bit = bit Mod 2

                If (TheDate <= 29 + bit) Then
                    isEnd = 1
                    Exit Do
                End If

                TheDate = TheDate - 29 - bit

                n = n - 1
            Loop

            If (isEnd = 1) Then
                Exit Do
            End If

            m = m + 1
        Loop

        curYear = 1921 + m
        curMonth = k - n + 1
        curDay = TheDate

        If (k = 12) Then
            If (curMonth = (Int(NongliData(m) / 65536) + 1)) Then
                curMonth = 1 - curMonth
            ElseIf (curMonth > (Int(NongliData(m) / 65536) + 1)) Then
                curMonth = curMonth - 1
            End If
        End If

        lunarDay = curYear & "/" & curMonth & "/" & curDay

    End Function