VB技术

在vb中动态创建调用存储过程

木子的blog — Mon, 26 Sep 2005 07:27:00 GMT

'定义变量
Dim cmd As New ADODB.Command
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset

'打开连接
cnn.ConnectionString = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=maindb;Data Source=jim"

cnn.CursorLocation = adUseClient
cnn.Open

If cnn.State <> 1 Then MsgBox "失败”

Set cmd.ActiveConnection = cnn

cmd.CommandType = adCmdText

'''''''''''''''检查存取过程是否存在，若有则删除
Set rst = Nothing
rst.Open "SELECT name FROM sysobjects WHERE name = 'proc_name1' AND type = 'P'", cnn
If rst.RecordCount > 0 Then
   cmd.CommandText = "DROP PROCEDURE proc_name1 "
   cmd.Execute
End If
''''''''''''''''''''''''''''''

Set rst = Nothing
rst.Open "SELECT name FROM sysobjects WHERE name = 'proc_name1' AND type = 'P'", cnn
If rst.RecordCount > 0 Then
   cmd.CommandText = "DROP PROCEDURE proc_name1 "
   cmd.Execute
End If
''''''''''''''''''''''''''''''
'创存储过程proc_name1 (@var_item_no 为输入参数) employee为当前库中已知表
cmd.CommandText = "Create proc proc_name1 @var_item_no varchar(40) as Select * From employee where emp_id like @var_item_no"
cmd.Execute

'通过传递参数值来执行存取过程
cmd.CommandType = adCmdStoredProc
cmd.CommandText = "proc_name1"

cmd.Parameters.Refresh
cmd.Parameters(1).Value = Text1.Text
Set rst = Nothing
Set rst = cmd.Execute()

利用Visual Basic命令操作文件

木子的blog — Mon, 26 Sep 2005 01:59:00 GMT

一打开和关闭文件

　　 1、顺序文件

　　打开顺序文件，我们可以使用Open语句。它的格式如下：

Open pathname For [Input |Output |Append] As [#]filenumber [Len = buffersize]

　　说明：

　　（1）参数pathname 表示要打开的文件名，文件名可以包含有驱动器和目录

　　（2）Input Output 和Append用于设置顺序文件的打开方式。其中，Input表示从打开的文件中读取数据。以这种方式打开文件时，文件必须存在，否则会产生错误。Output表示向打开的文件中写入数据。以这种方式打开文件时，文件中原有的数据将被覆盖，新的数据将从文件开始写入。如果文件不存在，则创建一个新文件。Append表示向打开的文件中添加数据。以这种方式打开时，文件中原有的数据将被保留，新的数据将从文件为开始添加。如果文件不存在，则创建一个新文件。

　　（3）As[#]filenumber 子句用于为打开的文件指定文件号.对文件进行读写操作时,要用文件号表示该文件.文件号是介于1~511之间的整数,既可以是数字,又可以是变量.也可以省略不用.

　　 (4)当在文件与程序之间拷贝数据时,Len=buffersize子句指定缓冲区的字符数.

　　例如:

Open App.Path + "\test.dat" For Output As 1

Open App.Path + "\test.dat" For Output As 1

　　这两句代码在当前应用程序所在目录下创建了一个名为test.dat的文本文件,分配文件号为1.

Open App.Path + "\test.dat" For Input As [#]filenumber

　　这条语句是从文本文件中读取数据.

Open App.Path + "\test.dat" For Append As [#]filenumber

　　这条语句则是像文本文件中添加数据

　　 2、随机文件

　　操作随机文件之前,首先必须定义用于保存数据项的记录类型.该记录是用户自定义数据类型,他们是随机文件中存储数据的基本结构.例如:

Type Student
　 No As Integer
　 Name As String * 20
　 age As Integer
End Type

Dim Stud As Student ‘定义一个可以存放学生材料的变量

　　随机文件中,所有的数据都将保存到若干个结构为Student类型的记录中, 而从随机文件中读出的数据则可以存放到变量Stud中.

　　之后我们就可以打开并读写文件了.下面是打开随机文件的语法格式:

Open filename For Random as [#]filenumber Len = Reclength

　　说明:

　　 (1)参数filename 和filenumber 分别表示文件名或文件号.

　　 (2)关键字Random 表示打开的是随机文件

　　 (3)Len子句用于设置记录长度,长度由参数Reclength指定.Reclength的值必须大于0,而且必须与定义的记录结构的长度一致.计算记录长度的方法是将记录结构中每个元素的长度相加.例如前面声明的Student的长度应该是2+20+2=24字节.

　　打开一个记录类型为Student 的随机文件的方法是:

Open "c:\Student.txt " For Random As #1 Len = 25

　　 3、二进制文件

　　打开二进制文件的语法格式如下:

Open pathname For Binary As [#]filenumber

　　说明:

　　 (1) 参数filename 和filenumber 分别表示文件名或文件号.

　　 (2)关键字Binary 表示打开的是二进制文件

　　 (3)对于二进制文件,不能指定字节长度.每个打开的二进制文件都有一个自己的指针,文件指针是一个数字值,指向下一次读写操作的文件中的位置.二进制文件中的每个”位置”对应一个数据字节,因此,有n个字节的文件,就有1到n个位置.

　　我们可以用Seek()函数返回当前的文件指针位置(即下一个要读写的字节 );用Loc()函数返回上一次读写的字节位置,除非用Seek语句移动了指针,Loc()返回值总比Seek()的小1.我们来看下面的例子:

Open “student.txt” for Binary as #1

　　该语句用二进制的方式打开了student.txt文件.

二读文件

　　 1、顺序文件

　　顺序文件的读取有三种方式：

　　（1）Line Input # 语句

　　该语句从打开的顺序文件中读取一行数据。这里的一行指的是从当前指针位置开始到回车符或回车换行符之间的所有数据。Line Input # 语句的语法格式如下：

Line Input # 文件号，变量号

　　说明：“文件号”是打开文件时所用的文件号；“变量号”使用来存放读出数据的一个或多个变量，如果有多个变量，中间用空格分割开。Input# 语句为参数列表中的每一个变量读取文件的一个域，并将读出的域存入变量中。该语句只能顺序的从第一个域开始，直到读取想要的域。

　　请看下面代码：

Dim strLine As String

Open "c:\vb\test.txt" For Input As #1

Do Until EOF(1)
　 Line Input #1, strLine
　 text1.Text = text1.Text + strLine + Chr(13) + Chr(10)
Loop

Close #1

　　此段代码逐行读取一个文件到文本框中。

　　（2）Input函数

　　此函数可以从顺序文件中一次读取指定长度的字符串。具体地说，就是从文件的当前位置开始，读取指定个数的字符，然后将他们返回。Input函数可以读取包括换行符，回车符，空格符等在内的各种字符。下面是它的语法格式：

　　变量 = Input（串长度，文件号）

　　例如，要从一个打开文件中读取12个字符并复制到变量file中，我们可以这样写：

file = Input（12，filenum）

　　如果要将整个文件复制到变量，请使用InputB函数将字节从文件复制到变量。由于InputB函数返回一个ASCII字符串，因此，必须用StrCopy函数将ASCII字符串转换为Unicode字符串。代码如下：

file = StrCopy （Input （LOF（filenanum），filenum），vbUnicode）

　　（3）Input # 语句

　　 Input #语句可以从文件中同时向多个变量内读入数据，而且读入的数据可以是不同类型的。

　　下面使它的语法格式：

Input # 文件号，变量列表

　　例如，我们要在文件student.txt中写入数据,下面是代码:

Open "student.txt" For Output As #filenum

Write #filenum, "张三", "初一年级", 14
Write #filenum, "李四", "职业高中", 18

Dim name As String, nianji As String, age As Integer
Dim name1 As String, nianji1 As String, age1 As Integer
Open "student.txt" For Input As #filenum
Input #filenum, name, nianji, age
Input #filenum, name1, nianji1, age1
Close #filenum

　　执行结果:

name=”张三” ,nianji = “初一年级” ,age =14

name=”李四” ,nianji = “职业高中” ,age =18

　　 2、随机文件

　　读取随机文件是可以使用Get # 语句,数据从文件的一个指定记录中读出后,存入一个用户自定义的变量中.

　　语法格式: Get # FileNum ,[RecNum],UserType

　　说明:

　　 (1)FileNum 是要打开的文件号;RecNum是要读取的记录号,若省略,则读取下一个记录

　　 (2)UserType 是一个用来存放读出数据的用户自定义的数据类型变量.

　　下面是一个例子:

Get # 1,5,Student

　　该语句读取文件号为1的文件中的第5条记录.

　　 3、二进制文件

　　读写二进制文件的方法和读写随机文件的方法基本相同,下面是相关的语句格式及其说明:

　　格式: Get [#]fileNumber ,[Pos], Var

　　功能: 用二进制方式,从文件的中指定的位置开始读取,所给变量长度的数据

　　说明:

　　 (1)FileNumber是以二进制方式打开的文件号.

　　 (2)Pos用来指定读写操作发生时的字节位置,若省略,则使用当前文件指针位置.

　　 (3)Var是用来存放读出的数据的变量.该语句会自动根据var变量包含的字节长度读取适当的文件,如果Var是一个可变长度的字符串变量,则传送的字节数等于Var中目前的字节数.对于文件长度的判断我们可以使用Lof()函数,Eof()函数检查文件的结尾位置.

　　下面的代码复制studert.txt文件到student1.txt文件中

Dim ar As String * 1, i As Integer
Open "c:\student.txt" For Binary As #1
Open "c:\student2.txt" For Binary As #2
For i = 1 To LOF(1)
　 Get #1, , ar
　 Put #2, , ar
Next i

Close #1, #2

三写文件

　　 1、顺序文件

　　写顺序文件我们可以用Write # 和Print #语句向一个已经打开的文件中写入数据.

　　下面是他们的格式和说明:

　　 Print # 的语法格式:

　　Print # 文件号,变量列表

　　例如,将文本框中的文本写到文件中,代码如下:

Open "file.txt" For Output As #filenum

Input #filenum, text1.text

　　 Write # 语句的语法格式:

Write # 文件号,变量列表

　　说明:用Write # 语句写入的信息便于以后用Input #语句来读取数据,因为Write #语句自动将写入到文件中的信息用逗号分开,并为字符串数据加上双引号.例如:

Open "student.txt" For Output As #filenum

Write #filenum, "张三", "初一年级", 14
Write #filenum, "李四", "职业高中", 18

　　 2、随机文件

　　向随机文件中写入数据,使用Put　＃语句.语法格式如下:

Put [#] FileNum ,[RecNum],UserType

　　说明:

　　 (1) FileNum 是要打开的文件号;RecNum是要写入的记录号,若省略,则再上一次用Get 和Put语句所读写过的记录的后一条记录中写入,如果没有执行过Get 和Put语句,就从第一条记录开始

　　 (2)UserType 是包含要写入数据的用户自定义的数据类型变量.例如:我们向前面的student.txt文件中的第5个记录写入数据,可用这些语句:

stud.No = 0301
stud.Name = “王武”
stud.Age =20
Put #1 ,5,stud

　　如果要插入的数据不只一两条的话,首先要确定文件和每条记录的长度,这样就可以计算出文件中究竟有多少条记录.我们可以用Lof()函数返回文件的长度,Len()函数返回每个记录的长度,计算文件中的记录个数可以用文件的长度除以给个记录的长度.示例如下:

Nextrec= (Lof(1)\Len(UserType))+1

Put #1,Nextrec,UserType

　　 3、二进制文件

　　下面是以二进制方式写入文件的语句格式及其说明:

　　格式:

Put [#]fileNumber ,[Pos], Var

　　功能: 用二进制方式,从文件的中指定的位置开始写入,所给变量长度的数据

　　说明:

　　 (1)FileNumber是以二进制方式打开的文件号.

　　 (2)Pos用来指定写操作发生时的字节位置,若省略,则使用当前文件指针位置.

　　 (3)Var是用来存放写入的数据的变量.该语句会自动根据var变量包含的字节长度写入文件,如果Var是一个可变长度的字符串变量,则传送的字节数等于Var中目前的字节数.

　　使用方法可参考二进制文件的读操作.

在vb中进行读存注册表方法

木子的blog — Fri, 16 Sep 2005 02:39:00 GMT

Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_DYN_DATA = &H80000006
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const HKEY_CURRENT_CONFIG = &H80000005
Private Const REG_OPTION_NON_VOLATILE = 0 ' Key is preserved when system is rebooted

Private Const REG_SZ = 1                         ' Unicode nul terminated string
Private Const REG_DWORD = 4                      ' 32-bit number
Private Const REG_NONE = 0                       ' No value type
Private Const REG_LINK = 6                       ' Symbolic Link (unicode)
Private Const REG_MULTI_SZ = 7                   ' Multiple Unicode strings
Private Const REG_BINARY = 3                     ' Free form binary
Private Const REG_EXPAND_SZ = 2                  ' Unicode nul terminated string

Private Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
End Type

Private Declare Function GetComputerNameE Lib "testdll.dll" (ByVal name As String) As Long

Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

Private Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition As Long) As Long

Private Declare Function RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpValue As String, lpcbValue As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long ' Note that if you declare the lpData parameter as String, you must pass it By Value.

Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long ' Note that if you declare the lpData parameter as String, you must pass it By Value.

'以下是过程例子
Private Sub Command3_Click()
Dim hKey As Long, hSkey As Long
Dim result As Long
Dim Disposition As Long
Dim sa As SECURITY_ATTRIBUTES
Dim InNum As Long, OutNum As Long
Dim InStrs As String * 80
InStrs = "刚ノセ"

InNum = 3
   ' result = RegCreateKeyEx(HKEY_CURRENT_USER, "\\HKEY_CURRENT_USER\Software\未来公司", 0, " ", REG_OPTION_NON_VOLATILE, KEY_WRITE, sa, hKey, Disposition)
    result = RegOpenKey(HKEY_CURRENT_USER, "Software", hKey)
    result = RegCreateKey(hKey, "未来公司", hSkey)
    result = RegQueryValueEx(hSkey, "Ω计", 0, REG_DWORD, OutNum, 4)

    If OutNum = 0 Then
       InNum = 1
    Else
      InNum = OutNum + 1
    End If
    result = RegSetValueEx(hSkey, "Ω计", 0, REG_DWORD, InNum, Len(InNum))
    result = RegSetValueEx(hSkey, "セ", 0, REG_SZ, ByVal InStrs, Len(InStrs))
    Me.Caption = OutNum
    RegCloseKey (hKey)
End Sub

在vb中進陰陽歷轉化

木子的blog — Wed, 07 Sep 2005 03:45:00 GMT

Option Explicit
Dim Test() As Integer
Const N = 10
Dim s(1 To N) As Integer
Dim I%

Dim Ml(0 To 11) As Integer '正常年份的每月天數據數組

Dim Y%, M%, D%   'y 年 m 月 d 日
Dim Outy%, Outm%, Outd%   'outy 輸出年;月;日
Dim Nm(0 To 50, 0 To 13) As String ' 兩位數組一列存取當前年份   二列存取(當年是月份yun,若是0沒有; 農曆每月初一所對應的陽歷日期)

Sub Init()
Dim Str As String
Str = 0 & "," & "0217" & "," & "0318" & "," & "0417" & "," & "0517" & "," & "0615" & "," & "0715" & "," & "0814" & "," & "0912" & "," & "1011" & "," & "1110" & "," & "1209" & "," & "1308"
Str = Str & "," & 0 & "," & "0206" & "," & "0308" & "," & "0406" & "," & "0506" & "," & "0605" & "," & "0704" & "," & "0803" & "," & "0901" & "," & "1001" & "," & "1030" & "," & "1129" & "," & "1228"
Str = Str & "," & 5 & "," & "0127" & "," & "0225" & "," & "0326" & "," & "0424" & "," & "0524" & "," & "0622" & "," & "0722" & "," & "0820" & "," & "0919" & "," & "1019" & "," & "1117" & "," & "1217" & "," & "1315"
Str = Str & "," & 0 & "," & "0214" & "," & "0315" & "," & "0414" & "," & "0513" & "," & "0611" & "," & "0711" & "," & "0810" & "," & "0908" & "," & "1008" & "," & "1107" & "," & "1206" & "," & "1305"
Str = Str & "," & 0 & "," & "0203" & "," & "0305" & "," & "0403" & "," & "0503" & "," & "0601" & "," & "0630" & "," & "0730" & "," & "0828" & "," & "0927" & "," & "1027" & "," & "1125" & "," & "1225"
Str = Str & "," & 3 & "," & "0124" & "," & "0222" & "," & "0324" & "," & "0422" & "," & "0522" & "," & "0620" & "," & "0719" & "," & "0818" & "," & "0916" & "," & "1016" & "," & "1114" & "," & "1214" & "," & "1313"
Str = Str & "," & 0 & "," & "0212" & "," & "0312" & "," & "0411" & "," & "0510" & "," & "0609" & "," & "0708" & "," & "0806" & "," & "0905" & "," & "1004" & "," & "1103" & "," & "1202" & "," & "1301"
Str = Str & "," & 8 & "," & "0131" & "," & "0302" & "," & "0331" & "," & "0430" & "," & "0529" & "," & "0628" & "," & "0727" & "," & "0825" & "," & "0924" & "," & "1023" & "," & "1122" & "," & "1221" & "," & "1320"
Str = Str & "," & 0 & "," & "0218" & "," & "0320" & "," & "0419" & "," & "0519" & "," & "0617" & "," & "0717" & "," & "0815" & "," & "0913" & "," & "1013" & "," & "1111" & "," & "1211" & "," & "1309"
Str = Str & "," & 0 & "," & "0208" & "," & "0309" & "," & "0408" & "," & "0508" & "," & "0606" & "," & "0706" & "," & "0804" & "," & "0903" & "," & "1002" & "," & "1101" & "," & "1130" & "," & "1230"
Str = Str & "," & 6 & "," & "0128" & "," & "0227" & "," & "0327" & "," & "0426" & "," & "0525" & "," & "0624" & "," & "0724" & "," & "0822" & "," & "0921" & "," & "1020" & "," & "1119" & "," & "1218" & "," & "1317"
Str = Str & "," & 0 & "," & "0215" & "," & "0317" & "," & "0415" & "," & "0515" & "," & "0613" & "," & "0713" & "," & "0811" & "," & "0910" & "," & "1010" & "," & "1108" & "," & "1208" & "," & "1306"
Str = Str & "," & 0 & "," & "0205" & "," & "0306" & "," & "0405" & "," & "0504" & "," & "0602" & "," & "0702" & "," & "0731" & "," & "0830" & "," & "0929" & "," & "1028" & "," & "1127" & "," & "1227"
Str = Str & "," & 4 & "," & "0125" & "," & "0224" & "," & "0325" & "," & "0424" & "," & "0523" & "," & "0621" & "," & "0721" & "," & "0819" & "," & "0918" & "," & "1017" & "," & "1116" & "," & "1216" & "," & "1315"
Str = Str & "," & 0 & "," & "0213" & "," & "0314" & "," & "0412" & "," & "0512" & "," & "0610" & "," & "0709" & "," & "0808" & "," & "0906" & "," & "1006" & "," & "1104" & "," & "1204" & "," & "1303"
Str = Str & "," & 0 & "," & "0202" & "," & "0303" & "," & "0402" & "," & "0501" & "," & "0531" & "," & "0629" & "," & "0728" & "," & "0827" & "," & "0925" & "," & "1024" & "," & "1123" & "," & "1223"
Str = Str & "," & 3 & "," & "0121" & "," & "0220" & "," & "0322" & "," & "0421" & "," & "0520" & "," & "0619" & "," & "0718" & "," & "0816" & "," & "0915" & "," & "1014" & "," & "1112" & "," & "1212" & "," & "1311"
Str = Str & "," & 0 & "," & "0209" & "," & "0311" & "," & "0410" & "," & "0509" & "," & "0608" & "," & "0708" & "," & "0806" & "," & "0904" & "," & "1004" & "," & "1102" & "," & "1202" & "," & "1231"
Str = Str & "," & 7 & "," & "0130" & "," & "0228" & "," & "0329" & "," & "0427" & "," & "0527" & "," & "0626" & "," & "0725" & "," & "0824" & "," & "0922" & "," & "1022" & "," & "1120" & "," & "1220" & "," & "1318"
Str = Str & "," & 0 & "," & "0217" & "," & "0318" & "," & "0417" & "," & "0516" & "," & "0615" & "," & "0714" & "," & "0813" & "," & "0912" & "," & "1011" & "," & "1110" & "," & "1209" & "," & "1308"
Str = Str & "," & 0 & "," & "0206" & "," & "0308" & "," & "0406" & "," & "0505" & "," & "0604" & "," & "0703" & "," & "0802" & "," & "0901" & "," & "0930" & "," & "1030" & "," & "1129" & "," & "1228"
Str = Str & "," & 5 & "," & "0127" & "," & "0225" & "," & "0327" & "," & "0425" & "," & "0524" & "," & "0623" & "," & "0722" & "," & "0821" & "," & "0919" & "," & "1019" & "," & "1118" & "," & "1218" & "," & "1316"
Str = Str & "," & 0 & "," & "0215" & "," & "0315" & "," & "0414" & "," & "0513" & "," & "0611" & "," & "0711" & "," & "0809" & "," & "0908" & "," & "1007" & "," & "1106" & "," & "1206" & "," & "1304"
Str = Str & "," & 0 & "," & "0203" & "," & "0305" & "," & "0403" & "," & "0503" & "," & "0601" & "," & "0630" & "," & "0730" & "," & "0828" & "," & "0926" & "," & "1026" & "," & "1125" & "," & "1224"
Str = Str & "," & 4 & "," & "0123" & "," & "0222" & "," & "0324" & "," & "0422" & "," & "0522" & "," & "0620" & "," & "0719" & "," & "0818" & "," & "0916" & "," & "1015" & "," & "1114" & "," & "1214" & "," & "1312"
Str = Str & "," & 0 & "," & "0211" & "," & "0313" & "," & "0412" & "," & "0511" & "," & "0610" & "," & "0709" & "," & "0807" & "," & "0906" & "," & "1005" & "," & "1103" & "," & "1203" & "," & "1301"
Str = Str & "," & 8 & "," & "0131" & "," & "0301" & "," & "0331" & "," & "0429" & "," & "0529" & "," & "0627" & "," & "0727" & "," & "0825" & "," & "0924" & "," & "1023" & "," & "1121" & "," & "1221" & "," & "1319"
Str = Str & "," & 0 & "," & "0218" & "," & "0320" & "," & "0418" & "," & "0518" & "," & "0617" & "," & "0716" & "," & "0815" & "," & "0913" & "," & "1013" & "," & "1111" & "," & "1211" & "," & "1309"
Str = Str & "," & 0 & "," & "0207" & "," & "0309" & "," & "0407" & "," & "0507" & "," & "0606" & "," & "0705" & "," & "0804" & "," & "0903" & "," & "1002" & "," & "1101" & "," & "1130" & "," & "1230"
Str = Str & "," & 6 & "," & "0128" & "," & "0227" & "," & "0328" & "," & "0426" & "," & "0526" & "," & "0624" & "," & "0724" & "," & "0823" & "," & "0921" & "," & "1021" & "," & "1120" & "," & "1219" & "," & "1318"
Str = Str & "," & 0 & "," & "0216" & "," & "0317" & "," & "0415" & "," & "0514" & "," & "0613" & "," & "0712" & "," & "0811" & "," & "0909" & "," & "1009" & "," & "1108" & "," & "1207" & "," & "1306"
Str = Str & "," & 0 & "," & "0205" & "," & "0306" & "," & "0405" & "," & "0504" & "," & "0602" & "," & "0702" & "," & "0731" & "," & "0829" & "," & "0928" & "," & "1028" & "," & "1126" & "," & "1226"
Str = Str & "," & 4 & "," & "0125" & "," & "0224" & "," & "0325" & "," & "0424" & "," & "0523" & "," & "0621" & "," & "0721" & "," & "0819" & "," & "0917" & "," & "1017" & "," & "1115" & "," & "1215" & "," & "1314"
Str = Str & "," & 0 & "," & "0213" & "," & "0315" & "," & "0413" & "," & "0513" & "," & "0611" & "," & "0710" & "," & "0809" & "," & "0907" & "," & "1006" & "," & "1105" & "," & "1204" & "," & "1303"
Str = Str & "," & 0 & "," & "0202" & "," & "0303" & "," & "0401" & "," & "0501" & "," & "0531" & "," & "0629" & "," & "0728" & "," & "0827" & "," & "0925" & "," & "1024" & "," & "1123" & "," & "1222"
Str = Str & "," & 2 & "," & "0121" & "," & "0220" & "," & "0321" & "," & "0420" & "," & "0520" & "," & "0618" & "," & "0718" & "," & "0816" & "," & "0915" & "," & "1014" & "," & "1112" & "," & "1212" & "," & "1310"
Str = Str & "," & 0 & "," & "0209" & "," & "0310" & "," & "0409" & "," & "0509" & "," & "0607" & "," & "0707" & "," & "0806" & "," & "0904" & "," & "1004" & "," & "1102" & "," & "1202" & "," & "1231"
Str = Str & "," & 6 & "," & "0129" & "," & "0228" & "," & "0329" & "," & "0428" & "," & "0527" & "," & "0626" & "," & "0726" & "," & "0824" & "," & "0923" & "," & "1023" & "," & "1121" & "," & "1221" & "," & "1319"
Str = Str & "," & 0 & "," & "0217" & "," & "0318" & "," & "0416" & "," & "0516" & "," & "0614" & "," & "0714" & "," & "0812" & "," & "0911" & "," & "1011" & "," & "1109" & "," & "1209" & "," & "1308"
Str = Str & "," & 0 & "," & "0206" & "," & "0308" & "," & "0406" & "," & "0505" & "," & "0604" & "," & "0703" & "," & "0802" & "," & "0831" & "," & "0930" & "," & "1029" & "," & "1128" & "," & "1228"
Str = Str & "," & 5 & "," & "0127" & "," & "0225" & "," & "0327" & "," & "0425" & "," & "0524" & "," & "0623" & "," & "0722" & "," & "0820" & "," & "0919" & "," & "1018" & "," & "1117" & "," & "1217" & "," & "1316"
Str = Str & "," & 0 & "," & "0215" & "," & "0316" & "," & "0415" & "," & "0514" & "," & "0612" & "," & "0712" & "," & "0810" & "," & "0908" & "," & "1008" & "," & "1106" & "," & "1206" & "," & "1305"
Str = Str & "," & 0 & "," & "0204" & "," & "0304" & "," & "0403" & "," & "0503" & "," & "0601" & "," & "0630" & "," & "0730" & "," & "0828" & "," & "0926" & "," & "1026" & "," & "1124" & "," & "1224"
Str = Str & "," & 3 & "," & "0123" & "," & "0221" & "," & "0323" & "," & "0422" & "," & "0521" & "," & "0620" & "," & "0719" & "," & "0818" & "," & "0916" & "," & "1015" & "," & "1114" & "," & "1213" & "," & "1312"
Str = Str & "," & 0 & "," & "0210" & "," & "0312" & "," & "0411" & "," & "0511" & "," & "0609" & "," & "0709" & "," & "0807" & "," & "0906" & "," & "1005" & "," & "1103" & "," & "1203" & "," & "1301"
Str = Str & "," & 8 & "," & "0131" & "," & "0301" & "," & "0331" & "," & "0430" & "," & "0529" & "," & "0628" & "," & "0727" & "," & "0826" & "," & "0925" & "," & "1024" & "," & "1122" & "," & "1222" & "," & "1320"
Str = Str & "," & 0 & "," & "0219" & "," & "0319" & "," & "0418" & "," & "0517" & "," & "0616" & "," & "0716" & "," & "0814" & "," & "0913" & "," & "1012" & "," & "1111" & "," & "1211" & "," & "1309"
Str = Str & "," & 0 & "," & "0207" & "," & "0309" & "," & "0407" & "," & "0507" & "," & "0605" & "," & "0705" & "," & "0803" & "," & "0902" & "," & "1002" & "," & "1031" & "," & "1130" & "," & "1230"
Str = Str & "," & 5 & "," & "0128" & "," & "0227" & "," & "0328" & "," & "0426" & "," & "0526" & "," & "0624" & "," & "0723" & "," & "0822" & "," & "0921" & "," & "1020" & "," & "1119" & "," & "1219" & "," & "1317"
Str = Str & "," & 0 & "," & "0216" & "," & "0318" & "," & "0416" & "," & "0515" & "," & "0614" & "," & "0713" & "," & "0811" & "," & "0910" & "," & "1009" & "," & "1108" & "," & "1208" & "," & "1307"
Str = Str & "," & 0 & "," & "0205" & "," & "0306" & "," & "0405" & "," & "0504" & "," & "0602" & "," & "0702" & "," & "0731" & "," & "0829" & "," & "0928" & "," & "1027" & "," & "1126" & "," & "1226"

'ml=new Array(31,28,31,30,31,30,31,31,30,31,30,31);   //正常平年月份天數
Ml(0) = 31: Ml(1) = 28: Ml(2) = 31: Ml(3) = 30
Ml(4) = 31: Ml(5) = 30: Ml(6) = 31: Ml(7) = 31
Ml(8) = 30: Ml(9) = 31: Ml(10) = 30: Ml(11) = 31
Dim Test() As String
Dim J%, K%
Test = Split(Str, ",", -1, vbTextCompare)

   J = 0
For I = 0 To UBound(Test)
      Select Case J
             Case 2, 5, 7, 10, 13, 16, 18, 21, 24, 26, 29, 32, 35, 37, 40, 43, 45, 48 '有14個
                  For K = 0 To 13
                    Nm(J, K) = Test(I + K)
                  Next K
                  I = I + 13
             Case Else
                  For K = 0 To 12
                     Nm(J, K) = Test(I + K)
                  Next K
                 I = I + 12
      End Select
      J = J + 1
Next I
End Sub

Function Length(Y, M) As Integer '當前年月的天數
If ((M = 2) And ((Y + 50) Mod 4 = 0)) Then
Length = 29
Else
Length = Ml((M + 11) Mod 12)
End If
End Function

Function Ctog(objDate As Date) As Date '//轉公歷

Y = Year(objDate) - 1950
M = Month(objDate)
D = Day(objDate)

If Check1.Value = 1 And M <> Nm(Y, 0) Then
MsgBox "不存在日期"
End If

If (Check1.Value = 1 And M = Nm(Y, 0)) Or (CInt(Nm(Y, 0)) > 0 And M > CInt(Nm(Y, 0))) Then M = M + 1
Outm = CInt(Mid(Nm(Y, M), 1, 2))
Outd = CInt(Mid(Nm(Y, M), 3, 4)) + D - 1
If (Outd > Length(Y, Outm)) Then
     Outd = Outd - Length(Y, Outm)
     Outm = Outm + 1
End If
Outy = Y + 1950
If (Outm > 12) Then
   Outm = Outm - 12
   Outy = Outy + 1
   End If
' Lab.Caption = "陽歷為: (公歷)" & outy & "年" & outm & "月" & outd & "日"
Ctog = DateSerial(Outy, Outm, Outd)
End Function

Function Gtoc(objDate As Date) As Date '////轉農歷
Dim Md$, K%
Dim Rn$ '字符串存取是否yun
Y = Year(objDate) - 1950
M = Month(objDate)
D = Day(objDate)
If D > Length(Y, M) Then MsgBox "日期出錯"

Md = Format(D, "00")
Md = Format(M, "00") & Md

Select Case Y
        Case 2, 5, 7, 10, 13, 16, 18, 21, 24, 26, 29, 32, 35, 37, 40, 43, 45, 48 '有14個
            K = 13
        Case Else
            K = 12
End Select

For I = 0 To 12
   If CInt(Nm(Y, I + 1)) > CInt(Md) Or I + 1 = K Then Exit For
Next I
If I = 0 Then
    If Y = 0 Then
       MsgBox "超出范"
       Exit Function
    End If

    Y = Y - 1
    I = K

Md = CInt(CInt(Md) + 1200)
If CInt(Nm(Y, I)) > CInt(Md) Then I = I - 1
End If

If Mid(Nm(Y, I), 1, 2) = Mid(Md, 1, 2) Then
Outd = CInt(Mid(Md, 3, 2)) - CInt(Mid(Nm(Y, I), 3, 2)) + 1
Else
Outd = Length(Y, Mid(Nm(Y, I), 1, 2)) + CInt(Mid(Md, 3, 2)) - CInt(Mid(Nm(Y, I), 3, 2)) + 1

End If
Outm = I
Rn = ""
If (Nm(Y, 0) <> 0) Then

If (Outm = Nm(Y, 0) + 1) Then Rn = "云月"
If (Outm > Nm(Y, 0)) Then Outm = Outm - 1
End If
Outy = Y + 1950

Gtoc = DateSerial(Outy, Outm, Outd)

End Function

Private Sub Command2_Click()
If DTPicker1.Year < 1952 Or DTPicker1.Year > 2000 Then
MsgBox "超出計算值"
Exit Sub
End If
Lab.Caption = "陰歷為: (農歷)" & Ctog(DTPicker1.Value)
End Sub

Private Sub Command3_Click()
If DTPicker1.Year < 1952 Or DTPicker1.Year > 2000 Then
MsgBox "超出計算值"
Exit Sub
End If
Lab.Caption = "陰歷為: (農歷)" & Gtoc(DTPicker2.Value)
End Sub

Private Sub Form_Load()
DTPicker1.Value = "1980/01/01"
DTPicker2.Value = "1980/01/01"
Init
End Sub

在vb中创建透明窗体代码

木子的blog — Fri, 02 Sep 2005 03:39:00 GMT

Option Explicit
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRECT As RECT) As Long

Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRECT As RECT) As Long

Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long

Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long

Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

Const RGN_XOR = 3

Private Type POINTAPI

x As Long

Y As Long

End Type

Private Type RECT

Left As Long

Top As Long

Right As Long

Bottom As Long

End Type

Private rctClient As RECT, rctFrame As RECT

Private hClient As Long, hFrame As Long

Public Sub MakeTransparent(frm As Form)
Image1.Visible = False
GetFrameClientRgn frm

SetWindowRgn frm.hWnd, hFrame, True
Image1.Visible = True
End Sub

Private Sub GetFrameClientRgn(frm As Form)

GetWindowRect frm.hWnd, rctFrame

GetClientRect frm.hWnd, rctClient

'?怠痻Г????辊Г?

Dim lpTL As POINTAPI, lpBR As POINTAPI

lpTL.x = rctFrame.Left

lpTL.Y = rctFrame.Top

lpBR.x = rctFrame.Right

lpBR.Y = rctFrame.Bottom

ScreenToClient frm.hWnd, lpTL

ScreenToClient frm.hWnd, lpBR

rctFrame.Left = lpTL.x

rctFrame.Top = lpTL.Y

rctFrame.Right = lpBR.x

rctFrame.Bottom = lpBR.Y

rctClient.Left = Abs(rctFrame.Left)

rctClient.Top = Abs(rctFrame.Top)

rctClient.Right = rctClient.Right + Abs(rctFrame.Left)

rctClient.Bottom = rctClient.Bottom + Abs(rctFrame.Top)

rctFrame.Right = rctFrame.Right + Abs(rctFrame.Left)

rctFrame.Bottom = rctFrame.Bottom + Abs(rctFrame.Top)

rctFrame.Top = 0

rctFrame.Left = 0

hClient = CreateRectRgn(rctClient.Left, rctClient.Top, rctClient.Right, rctClient.Bottom)

hFrame = CreateRectRgn(rctFrame.Left, rctFrame.Top, rctFrame.Right, rctFrame.Bottom)

CombineRgn hFrame, hClient, hFrame, RGN_XOR

End Sub