Tặng nhau những ý tưởng lập trình quý giá

[dangtuanson]

Trong kế toán quy định 1 tháng phải tổng kết và lập báo cáo, vậy tại sao chúng ta không tạo ra các bảng dữ liệu riêng cho từng tháng. Việc này cho ta tha hồ cất đi (backup) và restore (nạp trả) thông tin từng tháng khi cần thiết để dữ liệu luôn ít và gọn nhẹ giúp cho đảm bảo tốc độ tính toán nhanh. Tôi muốn chia sẻ ơới các bạn một số dòng sourcode để thực hiện ý đồ này.
a. Giả sử dữ liệu của chúng ta chứa trong file Data.mdb và chương trình chứa trong Prg.mdb (để hệ thống có thể chạy được trên LAN ta nên tổ chức dữ liệu riêng 1 file và phầ chương trình ở riêng 1 file)
b. Tổ chức 2 bảng lưu trữ thông tin mẫu cho chứng từ phát sinh nhập kho được tổ chức trong file PRG.MDB:
1. Tabname: Nhap (Soct, Ngayct, Makho, Makhach....)
2. Tabname: NhapCT (SoCT, Mahang, Soluong, Dongia,...)
c. Bây giờ muốn PRG tự phát sinh cho phiếu nhập kho của tháng 12 năm 2007, nghĩa là phải ra 2 tabs mới là:
1. Nhap2007 (có cấu trúc gống hệt như Tab Nhap)
2. NhapCT122007 (có cấu trúc gống hệt như Tab NhapCT)
và chúng cũng tự tạo quan hệ thông qua trơờng SoCT.
d. Lời giải:
- Khi khởi động chương trình bạn cần xóa bỏ tất cả các tabs link từ Data.mdb vào PRG.mdb bằng đoạn code sau:
Dim mydb as dao.datbase, i as byte, Filedata as string, tenbang as string
DoCmd.Hourglass True
For i = 0 To Mydb.TableDefs.Count - 1
If Mydb.TableDefs(i).Connect <> "" Then
DoCmd.DeleteObject acTable, Mydb.TableDefs(i).Name
End If
Next i
- Tạo lại các links cho từng tabs từ data.mdb sang PRG.mdb
' Biến dưới đây chứa tên file và đường dẫn của dữ liệu
Filedata="CKetoan\Data.mdb"
Set Mydb = OpenDatabase(Filedata)
For i = 0 To Mydb.TableDefs.Count - 1
tenbang = Mydb.TableDefs(i).Name
If (Left(tenbang, 2) <> "ms") then
DoCmd.TransferDatabase acLink, "Microsoft Access", Mydb.Name, acTable, tenbang, tenbang
End If
Next i
- Giả sử có 2 biến là THANG (tháng 12) và NAM (năm 2007), tạo tên 2 tabs nhập kho mới như sau:
Dim thnam as string, Nhp as string Nhpct as string
thnam=Right(100 + Thang,2) & Nam
Nhp="Nhap" & thnam
Nhpct="NhapCt" & thnam
- Kiểm tra xem tabs nhap122007 và nhapct122007 đã được tạo chưa:
Trước tiên lập hàm Tablist để kiểm tra sự tồn tại của 1 tab nào đó trên 1 file mdb chỉ định, hàm như sau
Function Listtab(Fdata As String, Bang As Variant) As Boolean
'--------------------------------
' Kiem tra su ton tai cua table
' Fdata là tên và đường dẫn đầy đủ của file data.mdb
' Bang : ten table can kiem tra có tồn tại hay không
' Ket qua: True - co / False - khong co
'--------------------------------
Dim I As Integer
Dim mdb As DAO.Database
If Fdata = "" Then
Set mdb = CurrentDb
Else
Set mdb = DBEngine.Workspaces(0).OpenDatabase(Fdata)
End If
Listtab = False
For I = 0 To mdb.TableDefs.Count - 1
If mdb.TableDefs(I).Name = Bang Then
Listtab = True
Exit Function
End If
Next I
Set mdb = Nothing
End Function
Vậy ta gọi hàm kiểm tra sự tồn tại của tab Nhap122007 có tồn tại trong Cketoan\Data.mdb như sau:
IF TabList("CKetoan\Data.mdb",Nhp)=true then
' Đã tồn tại thì thông báo
msgbox "Da co du lieu nhap kho thang nay!"
Else
' Nếu chưa có thì
' Tạo ra 2 tabs phát sinh vào Data.mdb
DoCmd.RunSQL "DELETE * FROM Nhap;"
DoCmd.RunSQL "DELETE * FROM NhapCT;"
DoCmd.CopyObject Filedata, Nhp, acTable, "Nhap"
DoCmd.CopyObject Filedata, Nhpct, acTable, "NhapCT"
' Tạo quan hệ cho 2 tabs vừa phát sinh
Dim MyRelation As DAO.Relation, RelName as string
Dim MyField As DAO.Field
' Đặt tên cho quan hệ giữa 2 tabs thông qua biến RelName
RelName = "N" & thnam
If Filedata = "" Then
Set MyDatabase = CurrentDb
Else
Set MyDB = OpenDatabase(Filedata)
End If
Set MyRelation = MyDB.CreateRelation(RelName, Nhp, NhpCt)
MyRelation.Attributes = dbRelationUpdateCascade + dbRelationDeleteCascade
Set MyField = MyRelation.CreateField("SoCT")
MyField.ForeignName = "SoCT"
MyRelation.Fields.Append MyField
MyDatabase.Relations.Append MyRelation
MyDatabase.Relations.Refresh
If Filedata <> "" Then
DoCmd.TransferDatabase acLink, "Microsoft Access", Filedata, acTable, Nhp, Nhp
DoCmd.TransferDatabase acLink, "Microsoft Access", Filedata, acTable, NhpCt, NhpCt
End If
Set MyDB = Nothing
End if

- Tất cả yêu cầu đã hoàn thành, chúc các bạn thành công và mong được chia sẻ với các bạn những ý tưởng quý giá.

 

[dangtuanson]

Ðề: Tặng nhau những ý tưởng lập trình quý giá

Hàm tạo tên tab với 6 ký tự cuối (gồm 2 ký tự đại diện tháng, 4 ký tự đại diện cho năm)
Ví dụ: "Nhap" ---> "Nhap122007"
Function MakeName(TabName as string, Thang, nam) as string
' TabName là phần tên của tab chưa có 6 ký tự cuối
' Thang: tháng
' Nam: Năm
Dim Nthang as byte, SNam as String
Nthang=Round(Thang,0)
SNam=Trim(Str(Nam))
IF (Nthang>13) OR (Len(SNam)<>4) then
MakeName=TabName
Else
MakeName=TabName & Right(100+Nthang,2) & SNam
End IF
End function

--- Hoàn thành---

Thay cho dòng
MakeName=TabName & Right(100+Nthang,2) & SNam
bạn có thể viết:
MakeName=TabName & Right("0"& Trim(Str(Nthang)),2) & SNam

 

[bonggon]

Ðề: Tặng nhau những ý tưởng lập trình quý giá

Hổng hiểu gì hết bạn í ơi!!!

 

[dangtuanson]

Ðề: Tặng nhau những ý tưởng lập trình quý giá

Gửi các bạn hàm chuyển đổi 1 chuỗi từ bảng mã TCVN3 sang UNICODE:

Đôi khi bạn muốn sử dụng lại dữ liệu từ 1 nguồn đã từng nhập bằng bảng mã TCVN3, nhất là các dữ liệu đã được tổ chức theo bảng... Vậy dùng hàm này kết hợp với các câu lệnh query bạn sẽ tạo được những dữ liệu mới theo mã tiếng Việt Unicode. Nếu không dùng hàm chúng ta phải thực hiện quy trình khá dài dòng: Export sang excel rồi dùng chức năng Chuyễn mã của unikey, sau đó lại Import vào...

Public Function TtoU(candoi As String) As String
' candoi - chuỗi ký tự thuộc bảng mã TCVN3
Dim Uchuoi As String, Tchuoi As String, dai As Byte, I As Byte, Kq As String * 1, vitri As Byte, tstr As String
tstr = tstr & ChrW(&HE1) & ChrW(&HE0) & ChrW(&H1EA3) & ChrW(&HE3) & ChrW(&H1EA1) & ChrW(&H103) & ChrW(&H1EAF) & ChrW(&H1EB1) & ChrW(&H1EB3) & ChrW(&H1EB5) & ChrW(&H1EB7) & ChrW(&HE2) & ChrW(&H1EA5) & ChrW(&H1EA7) & ChrW(&H1EA9) & ChrW(&H1EAB) & ChrW(&H1EAD) & ChrW(&HE9) & ChrW(&HE8) & ChrW(&H1EBB)
tstr = tstr & ChrW(&H1EBD) & ChrW(&H1EB9) & ChrW(&HEA) & ChrW(&H1EBF) & ChrW(&H1EC1) & ChrW(&H1EC3) & ChrW(&H1EC5) & ChrW(&H1EC7) & ChrW(&HED) & ChrW(&HEC) & ChrW(&H1EC9) & ChrW(&H129) & ChrW(&H1ECB) & ChrW(&HF3) & ChrW(&HF2) & ChrW(&H1ECF) & ChrW(&HF5) & ChrW(&H1ECD) & ChrW(&HF4) & ChrW(&H1ED1)
tstr = tstr & ChrW(&H1ED3) & ChrW(&H1ED5) & ChrW(&H1ED7) & ChrW(&H1ED9) & ChrW(&H1A1) & ChrW(&H1EDB) & ChrW(&H1EDD) & ChrW(&H1EDF) & ChrW(&H1EE1) & ChrW(&H1EE3) & ChrW(&HFA) & ChrW(&HF9) & ChrW(&H1EE7) & ChrW(&H169) & ChrW(&H1EE5) & ChrW(&H1B0) & ChrW(&H1EE9) & ChrW(&H1EEB) & ChrW(&H1EED) & ChrW(&H1EEF)
tstr = tstr & ChrW(&H1EF1) & ChrW(&HFD) & ChrW(&H1EF3) & ChrW(&H1EF7) & ChrW(&H1EF9) & ChrW(&H1EF5) & ChrW(&H111) & ChrW(&HC1) & ChrW(&HC0) & ChrW(&H1EA2) & ChrW(&HC3) & ChrW(&H1EA0) & ChrW(&H102) & ChrW(&H1EAE) & ChrW(&H1EB0) & ChrW(&H1EB2) & ChrW(&H1EB4) & ChrW(&H1EB6) & ChrW(&HC2) & ChrW(&H1EA4)
tstr = tstr & ChrW(&H1EA6) & ChrW(&H1EA8) & ChrW(&H1EAA) & ChrW(&H1EAC) & ChrW(&HC9) & ChrW(&HC8) & ChrW(&H1EBA) & ChrW(&H1EBC) & ChrW(&H1EB8) & ChrW(&HCA) & ChrW(&H1EBE) & ChrW(&H1EC0) & ChrW(&H1EC2) & ChrW(&H1EC4) & ChrW(&H1EC6) & ChrW(&HCD) & ChrW(&HCC) & ChrW(&H1EC8) & ChrW(&H128) & ChrW(&H1ECA)
tstr = tstr & ChrW(&HD3) & ChrW(&HD2) & ChrW(&H1ECE) & ChrW(&HD5) & ChrW(&H1ECC) & ChrW(&HD4) & ChrW(&H1ED0) & ChrW(&H1ED2) & ChrW(&H1ED4) & ChrW(&H1ED6) & ChrW(&H1ED8) & ChrW(&H1A0) & ChrW(&H1EDA) & ChrW(&H1EDC) & ChrW(&H1EDE) & ChrW(&H1EE0) & ChrW(&H1EE2) & ChrW(&HDA) & ChrW(&HD9) & ChrW(&H1EE6)
tstr = tstr & ChrW(&H168) & ChrW(&H1EE4) & ChrW(&H1AF) & ChrW(&H1EE8) & ChrW(&H1EEA) & ChrW(&H1EEC) & ChrW(&H1EEE) & ChrW(&H1EF0) & ChrW(&HDD) & ChrW(&H1EF2) & ChrW(&H1EF6) & ChrW(&H1EF8) & ChrW(&H1EF4) & ChrW(&H110)
Tchuoi = "¸µ¶·¹¨¾»¼½Æ©ÊÇÈÉËÐÌÎÏѪÕÒÓÔÖÝ×ØÜÞãßáâä«èåæçé¬íêëìîóïñòô­øõö÷ùýúûüþ®¸µ¶·¹¡¡¡¡¡¡¢¢¢¢¢¢ÐÌÎÏÑ££££££Ý×ØÜÞãßáâ䤤¤¤¤¤¥¥¥¥¥¥óïñòô¦¦¦¦¦¦ýúûüþ§"
Uchuoi = tstr
TtoU = ""
Kq = ""
For I = 1 To Len(candoi)
Kq = Mid(candoi, I, 1)
vitri = InStr(1, Tchuoi, Kq, vbBinaryCompare)
If vitri <> 0 Then
TtoU = TtoU & Mid(Uchuoi, vitri, 1)
Else
TtoU = TtoU & Kq
End If
Next
End Function

Chúc các bạn thành công

Hàm đổi chuỗi dàng bảng mã Unicode sang chuỗi dùng bảng mã TCVN3:

Trong những phép tìm kiếm theo chuỗi dùng mã Unicode đôi khi không cho ta kết quả chính xác... vì vậy ta cần phải dùng bảng mã TCVN3 (1 byte) để tìm thì kết quả luôn chính xác.

Public Function UtoT(candoi As String) As String
Dim Uchuoi As String, Tchuoi As String, dai As Byte, I As Byte, Kq As String * 1, vitri As Byte, tstr As String
tstr = tstr & ChrW(&HE1) & ChrW(&HE0) & ChrW(&H1EA3) & ChrW(&HE3) & ChrW(&H1EA1) & ChrW(&H103) & ChrW(&H1EAF) & ChrW(&H1EB1) & ChrW(&H1EB3) & ChrW(&H1EB5) & ChrW(&H1EB7) & ChrW(&HE2) & ChrW(&H1EA5) & ChrW(&H1EA7) & ChrW(&H1EA9) & ChrW(&H1EAB) & ChrW(&H1EAD) & ChrW(&HE9) & ChrW(&HE8) & ChrW(&H1EBB)
tstr = tstr & ChrW(&H1EBD) & ChrW(&H1EB9) & ChrW(&HEA) & ChrW(&H1EBF) & ChrW(&H1EC1) & ChrW(&H1EC3) & ChrW(&H1EC5) & ChrW(&H1EC7) & ChrW(&HED) & ChrW(&HEC) & ChrW(&H1EC9) & ChrW(&H129) & ChrW(&H1ECB) & ChrW(&HF3) & ChrW(&HF2) & ChrW(&H1ECF) & ChrW(&HF5) & ChrW(&H1ECD) & ChrW(&HF4) & ChrW(&H1ED1)
tstr = tstr & ChrW(&H1ED3) & ChrW(&H1ED5) & ChrW(&H1ED7) & ChrW(&H1ED9) & ChrW(&H1A1) & ChrW(&H1EDB) & ChrW(&H1EDD) & ChrW(&H1EDF) & ChrW(&H1EE1) & ChrW(&H1EE3) & ChrW(&HFA) & ChrW(&HF9) & ChrW(&H1EE7) & ChrW(&H169) & ChrW(&H1EE5) & ChrW(&H1B0) & ChrW(&H1EE9) & ChrW(&H1EEB) & ChrW(&H1EED) & ChrW(&H1EEF)
tstr = tstr & ChrW(&H1EF1) & ChrW(&HFD) & ChrW(&H1EF3) & ChrW(&H1EF7) & ChrW(&H1EF9) & ChrW(&H1EF5) & ChrW(&H111) & ChrW(&HC1) & ChrW(&HC0) & ChrW(&H1EA2) & ChrW(&HC3) & ChrW(&H1EA0) & ChrW(&H102) & ChrW(&H1EAE) & ChrW(&H1EB0) & ChrW(&H1EB2) & ChrW(&H1EB4) & ChrW(&H1EB6) & ChrW(&HC2) & ChrW(&H1EA4)
tstr = tstr & ChrW(&H1EA6) & ChrW(&H1EA8) & ChrW(&H1EAA) & ChrW(&H1EAC) & ChrW(&HC9) & ChrW(&HC8) & ChrW(&H1EBA) & ChrW(&H1EBC) & ChrW(&H1EB8) & ChrW(&HCA) & ChrW(&H1EBE) & ChrW(&H1EC0) & ChrW(&H1EC2) & ChrW(&H1EC4) & ChrW(&H1EC6) & ChrW(&HCD) & ChrW(&HCC) & ChrW(&H1EC8) & ChrW(&H128) & ChrW(&H1ECA)
tstr = tstr & ChrW(&HD3) & ChrW(&HD2) & ChrW(&H1ECE) & ChrW(&HD5) & ChrW(&H1ECC) & ChrW(&HD4) & ChrW(&H1ED0) & ChrW(&H1ED2) & ChrW(&H1ED4) & ChrW(&H1ED6) & ChrW(&H1ED8) & ChrW(&H1A0) & ChrW(&H1EDA) & ChrW(&H1EDC) & ChrW(&H1EDE) & ChrW(&H1EE0) & ChrW(&H1EE2) & ChrW(&HDA) & ChrW(&HD9) & ChrW(&H1EE6)
tstr = tstr & ChrW(&H168) & ChrW(&H1EE4) & ChrW(&H1AF) & ChrW(&H1EE8) & ChrW(&H1EEA) & ChrW(&H1EEC) & ChrW(&H1EEE) & ChrW(&H1EF0) & ChrW(&HDD) & ChrW(&H1EF2) & ChrW(&H1EF6) & ChrW(&H1EF8) & ChrW(&H1EF4) & ChrW(&H110)
Tchuoi = "¸µ¶·¹¨¾»¼½Æ©ÊÇÈÉËÐÌÎÏѪÕÒÓÔÖÝ×ØÜÞãßáâä«èåæçé¬íêëìîóïñòô­øõö÷ùýúûüþ®¸µ¶·¹¡¡¡¡¡¡¢¢¢¢¢¢ÐÌÎÏÑ££££££Ý×ØÜÞãßáâ䤤¤¤¤¤¥¥¥¥¥¥óïñòô¦¦¦¦¦¦ýúûüþ§"
Uchuoi = tstr
UtoT = ""
Kq = ""
For I = 1 To Len(candoi)
Kq = Mid(candoi, I, 1)
vitri = InStr(1, Uchuoi, Kq)
If vitri <> 0 Then
UtoT = UtoT & Mid(Tchuoi, vitri, 1)
Else
UtoT = UtoT & Kq
End If
Next
End Function

Hàm xác định số ngày của tháng và năm cho trước

Trong khi lập trình ta thường phải thực hiện các báo cáo trong tháng và năm nào đó mà chỉ cần truy xuất dữ liệu từ ngày đến ngày nào đó. Để kiểm tra việc nhập thông tin vào ô Từ ngày và Ô đến ngày không được vô lý, ta cần phải xác định được số ngày nhiều nhất trong 1 tháng cụ thể là bao nhiêu... thường bị rắc rối là tháng 2 và năm nhuận... Tôi trình thử 1 hàm sau:

Public Function Maxday(nam as integer, Thang as byte)
Maxday = 28
Dim I As Integer
For I = 1 To 4
If Trim(Month(DateSerial(nam, Thang, Maxday) + I)) <> Trim(Thang) Then
Maxday = Maxday + I - 1
Exit For
End If
Next
End Function

Hàm xác định số ngày của tháng và năm cho trước có thể viết cách khác:

Public Function Maxday(nam as integer, Thang as byte)
Dim NNam as Integer, NThang as byte
If Thang=12 then
Nthang=1
Nnam=Nam+1
Else
Nthang=Thang+1
Nnam=Nam
End If
Maxday=Day(Dateserial(Nnam,Nthang,1)-1)
End function

 

[myle]

Ðề: Tặng nhau những ý tưởng lập trình quý giá

Gửi các bạn hàm chuyển đổi 1 chuỗi từ bảng mã TCVN3 sang UNICODE:

Đôi khi bạn muốn sử dụng lại dữ liệu từ 1 nguồn đã từng nhập bằng bảng mã TCVN3, nhất là các dữ liệu đã được tổ chức theo bảng... Vậy dùng hàm này kết hợp với các câu lệnh query bạn sẽ tạo được những dữ liệu mới theo mã tiếng Việt Unicode. Nếu không dùng hàm chúng ta phải thực hiện quy trình khá dài dòng: Export sang excel rồi dùng chức năng Chuyễn mã của unikey, sau đó lại Import vào...

Public Function TtoU(candoi As String) As String
' candoi - chuỗi ký tự thuộc bảng mã TCVN3
Dim Uchuoi As String, Tchuoi As String, dai As Byte, I As Byte, Kq As String * 1, vitri As Byte, tstr As String
tstr = tstr & ChrW(&HE1) & ChrW(&HE0) & ChrW(&H1EA3) & ChrW(&HE3) & ChrW(&H1EA1) & ChrW(&H103) & ChrW(&H1EAF) & ChrW(&H1EB1) & ChrW(&H1EB3) & ChrW(&H1EB5) & ChrW(&H1EB7) & ChrW(&HE2) & ChrW(&H1EA5) & ChrW(&H1EA7) & ChrW(&H1EA9) & ChrW(&H1EAB) & ChrW(&H1EAD) & ChrW(&HE9) & ChrW(&HE8) & ChrW(&H1EBB)
tstr = tstr & ChrW(&H1EBD) & ChrW(&H1EB9) & ChrW(&HEA) & ChrW(&H1EBF) & ChrW(&H1EC1) & ChrW(&H1EC3) & ChrW(&H1EC5) & ChrW(&H1EC7) & ChrW(&HED) & ChrW(&HEC) & ChrW(&H1EC9) & ChrW(&H129) & ChrW(&H1ECB) & ChrW(&HF3) & ChrW(&HF2) & ChrW(&H1ECF) & ChrW(&HF5) & ChrW(&H1ECD) & ChrW(&HF4) & ChrW(&H1ED1)
tstr = tstr & ChrW(&H1ED3) & ChrW(&H1ED5) & ChrW(&H1ED7) & ChrW(&H1ED9) & ChrW(&H1A1) & ChrW(&H1EDB) & ChrW(&H1EDD) & ChrW(&H1EDF) & ChrW(&H1EE1) & ChrW(&H1EE3) & ChrW(&HFA) & ChrW(&HF9) & ChrW(&H1EE7) & ChrW(&H169) & ChrW(&H1EE5) & ChrW(&H1B0) & ChrW(&H1EE9) & ChrW(&H1EEB) & ChrW(&H1EED) & ChrW(&H1EEF)
tstr = tstr & ChrW(&H1EF1) & ChrW(&HFD) & ChrW(&H1EF3) & ChrW(&H1EF7) & ChrW(&H1EF9) & ChrW(&H1EF5) & ChrW(&H111) & ChrW(&HC1) & ChrW(&HC0) & ChrW(&H1EA2) & ChrW(&HC3) & ChrW(&H1EA0) & ChrW(&H102) & ChrW(&H1EAE) & ChrW(&H1EB0) & ChrW(&H1EB2) & ChrW(&H1EB4) & ChrW(&H1EB6) & ChrW(&HC2) & ChrW(&H1EA4)
tstr = tstr & ChrW(&H1EA6) & ChrW(&H1EA8) & ChrW(&H1EAA) & ChrW(&H1EAC) & ChrW(&HC9) & ChrW(&HC8) & ChrW(&H1EBA) & ChrW(&H1EBC) & ChrW(&H1EB8) & ChrW(&HCA) & ChrW(&H1EBE) & ChrW(&H1EC0) & ChrW(&H1EC2) & ChrW(&H1EC4) & ChrW(&H1EC6) & ChrW(&HCD) & ChrW(&HCC) & ChrW(&H1EC8) & ChrW(&H128) & ChrW(&H1ECA)
tstr = tstr & ChrW(&HD3) & ChrW(&HD2) & ChrW(&H1ECE) & ChrW(&HD5) & ChrW(&H1ECC) & ChrW(&HD4) & ChrW(&H1ED0) & ChrW(&H1ED2) & ChrW(&H1ED4) & ChrW(&H1ED6) & ChrW(&H1ED8) & ChrW(&H1A0) & ChrW(&H1EDA) & ChrW(&H1EDC) & ChrW(&H1EDE) & ChrW(&H1EE0) & ChrW(&H1EE2) & ChrW(&HDA) & ChrW(&HD9) & ChrW(&H1EE6)
tstr = tstr & ChrW(&H168) & ChrW(&H1EE4) & ChrW(&H1AF) & ChrW(&H1EE8) & ChrW(&H1EEA) & ChrW(&H1EEC) & ChrW(&H1EEE) & ChrW(&H1EF0) & ChrW(&HDD) & ChrW(&H1EF2) & ChrW(&H1EF6) & ChrW(&H1EF8) & ChrW(&H1EF4) & ChrW(&H110)
Tchuoi = "¸µ¶·¹¨¾»¼½Æ©ÊÇÈÉËÐÌÎÏѪÕÒÓÔÖÝ×ØÜÞãßáâä«èåæçé¬íêëìîóïñòô­øõö÷ùýúûüþ®¸µ¶·¹¡¡¡¡¡¡¢¢¢¢¢¢ÐÌÎÏÑ££££££Ý×ØÜÞãßáâ䤤¤¤¤¤¥¥¥¥¥¥óïñòô¦¦¦¦¦¦ýúûüþ§"
Uchuoi = tstr
TtoU = ""
Kq = ""
For I = 1 To Len(candoi)
Kq = Mid(candoi, I, 1)
vitri = InStr(1, Tchuoi, Kq, vbBinaryCompare)
If vitri <> 0 Then
TtoU = TtoU & Mid(Uchuoi, vitri, 1)
Else
TtoU = TtoU & Kq
End If
Next
End Function

Chúc các bạn thành công

Hàm đổi chuỗi dàng bảng mã Unicode sang chuỗi dùng bảng mã TCVN3:

Trong những phép tìm kiếm theo chuỗi dùng mã Unicode đôi khi không cho ta kết quả chính xác... vì vậy ta cần phải dùng bảng mã TCVN3 (1 byte) để tìm thì kết quả luôn chính xác.

Public Function UtoT(candoi As String) As String
Dim Uchuoi As String, Tchuoi As String, dai As Byte, I As Byte, Kq As String * 1, vitri As Byte, tstr As String
tstr = tstr & ChrW(&HE1) & ChrW(&HE0) & ChrW(&H1EA3) & ChrW(&HE3) & ChrW(&H1EA1) & ChrW(&H103) & ChrW(&H1EAF) & ChrW(&H1EB1) & ChrW(&H1EB3) & ChrW(&H1EB5) & ChrW(&H1EB7) & ChrW(&HE2) & ChrW(&H1EA5) & ChrW(&H1EA7) & ChrW(&H1EA9) & ChrW(&H1EAB) & ChrW(&H1EAD) & ChrW(&HE9) & ChrW(&HE8) & ChrW(&H1EBB)
tstr = tstr & ChrW(&H1EBD) & ChrW(&H1EB9) & ChrW(&HEA) & ChrW(&H1EBF) & ChrW(&H1EC1) & ChrW(&H1EC3) & ChrW(&H1EC5) & ChrW(&H1EC7) & ChrW(&HED) & ChrW(&HEC) & ChrW(&H1EC9) & ChrW(&H129) & ChrW(&H1ECB) & ChrW(&HF3) & ChrW(&HF2) & ChrW(&H1ECF) & ChrW(&HF5) & ChrW(&H1ECD) & ChrW(&HF4) & ChrW(&H1ED1)
tstr = tstr & ChrW(&H1ED3) & ChrW(&H1ED5) & ChrW(&H1ED7) & ChrW(&H1ED9) & ChrW(&H1A1) & ChrW(&H1EDB) & ChrW(&H1EDD) & ChrW(&H1EDF) & ChrW(&H1EE1) & ChrW(&H1EE3) & ChrW(&HFA) & ChrW(&HF9) & ChrW(&H1EE7) & ChrW(&H169) & ChrW(&H1EE5) & ChrW(&H1B0) & ChrW(&H1EE9) & ChrW(&H1EEB) & ChrW(&H1EED) & ChrW(&H1EEF)
tstr = tstr & ChrW(&H1EF1) & ChrW(&HFD) & ChrW(&H1EF3) & ChrW(&H1EF7) & ChrW(&H1EF9) & ChrW(&H1EF5) & ChrW(&H111) & ChrW(&HC1) & ChrW(&HC0) & ChrW(&H1EA2) & ChrW(&HC3) & ChrW(&H1EA0) & ChrW(&H102) & ChrW(&H1EAE) & ChrW(&H1EB0) & ChrW(&H1EB2) & ChrW(&H1EB4) & ChrW(&H1EB6) & ChrW(&HC2) & ChrW(&H1EA4)
tstr = tstr & ChrW(&H1EA6) & ChrW(&H1EA8) & ChrW(&H1EAA) & ChrW(&H1EAC) & ChrW(&HC9) & ChrW(&HC8) & ChrW(&H1EBA) & ChrW(&H1EBC) & ChrW(&H1EB8) & ChrW(&HCA) & ChrW(&H1EBE) & ChrW(&H1EC0) & ChrW(&H1EC2) & ChrW(&H1EC4) & ChrW(&H1EC6) & ChrW(&HCD) & ChrW(&HCC) & ChrW(&H1EC8) & ChrW(&H128) & ChrW(&H1ECA)
tstr = tstr & ChrW(&HD3) & ChrW(&HD2) & ChrW(&H1ECE) & ChrW(&HD5) & ChrW(&H1ECC) & ChrW(&HD4) & ChrW(&H1ED0) & ChrW(&H1ED2) & ChrW(&H1ED4) & ChrW(&H1ED6) & ChrW(&H1ED8) & ChrW(&H1A0) & ChrW(&H1EDA) & ChrW(&H1EDC) & ChrW(&H1EDE) & ChrW(&H1EE0) & ChrW(&H1EE2) & ChrW(&HDA) & ChrW(&HD9) & ChrW(&H1EE6)
tstr = tstr & ChrW(&H168) & ChrW(&H1EE4) & ChrW(&H1AF) & ChrW(&H1EE8) & ChrW(&H1EEA) & ChrW(&H1EEC) & ChrW(&H1EEE) & ChrW(&H1EF0) & ChrW(&HDD) & ChrW(&H1EF2) & ChrW(&H1EF6) & ChrW(&H1EF8) & ChrW(&H1EF4) & ChrW(&H110)
Tchuoi = "¸µ¶·¹¨¾»¼½Æ©ÊÇÈÉËÐÌÎÏѪÕÒÓÔÖÝ×ØÜÞãßáâä«èåæçé¬íêëìîóïñòô­øõö÷ùýúûüþ®¸µ¶·¹¡¡¡¡¡¡¢¢¢¢¢¢ÐÌÎÏÑ££££££Ý×ØÜÞãßáâ䤤¤¤¤¤¥¥¥¥¥¥óïñòô¦¦¦¦¦¦ýúûüþ§"
Uchuoi = tstr
UtoT = ""
Kq = ""
For I = 1 To Len(candoi)
Kq = Mid(candoi, I, 1)
vitri = InStr(1, Uchuoi, Kq)
If vitri <> 0 Then
UtoT = UtoT & Mid(Tchuoi, vitri, 1)
Else
UtoT = UtoT & Kq
End If
Next
End Function

Hàm xác định số ngày của tháng và năm cho trước

Trong khi lập trình ta thường phải thực hiện các báo cáo trong tháng và năm nào đó mà chỉ cần truy xuất dữ liệu từ ngày đến ngày nào đó. Để kiểm tra việc nhập thông tin vào ô Từ ngày và Ô đến ngày không được vô lý, ta cần phải xác định được số ngày nhiều nhất trong 1 tháng cụ thể là bao nhiêu... thường bị rắc rối là tháng 2 và năm nhuận... Tôi trình thử 1 hàm sau:

Public Function Maxday(nam as integer, Thang as byte)
Maxday = 28
Dim I As Integer
For I = 1 To 4
If Trim(Month(DateSerial(nam, Thang, Maxday) + I)) <> Trim(Thang) Then
Maxday = Maxday + I - 1
Exit For
End If
Next
End Function

Hàm xác định số ngày của tháng và năm cho trước có thể viết cách khác:

Public Function Maxday(nam as integer, Thang as byte)
Dim NNam as Integer, NThang as byte
If Thang=12 then
Nthang=1
Nnam=Nam+1
Else
Nthang=Thang+1
Nnam=Nam
End If
Maxday=Day(Dateserial(Nnam,Nthang,1)-1)
End function

Cám ơn Dangtuanson nhiều nhưng hiểu được chết liền, chắc để coppy về nhà ngâm cứu mới được hihihi

 

[dangtuanson]

Ðề: Tặng nhau những ý tưởng lập trình quý giá

Hàm xác định tên của ổ HDD (Ổ Logic)
Đôi khi lập trình xác định vị trí lưu dữ liệu hoặc bảo vệ chương trình bạn có cần xác định số hiệu ổ đĩa (logic) ta dùng hàm sau:

Public Function ShowDriveInfo(drvpath)
' drvpath là đường dẫn tới 1 file bất kỳ nào thuộc ổ đĩa mà bạn quan tâm
Dim fs, d
Set fs = CreateObject("Scripting.FileSystemObject")
Set d = fs.getDrive(fs.GetDriveName(fs.GetAbsolutePathName(drvpath)))
ShowDriveInfo = d.serialnumber
End Function

Lưu ý: Số hiệu này sẽ bị thay đổi nếu bạn format lại HDD.

Hàm đổi 1 số có ký số sang dạng chuỗi

Function Doi1so(motso As String) As String
' motso: "0","1","2","3","4","5","6","7","8","9"
If IsNull(Motso) or IsEmpty(Motso) or (len(motso)>1) or (Instr(1,"0123456789",Motso)=0)then
Doi1so=""
End If
Select Case motso
Case "1": Doi1so = "một "
Case "2": Doi1so = "hai "
Case "3": Doi1so = "ba "
Case "4": Doi1so = "bốn "
Case "5": Doi1so = "năm "
Case "6": Doi1so = "sáu "
Case "7": Doi1so = "bảy "
Case "8": Doi1so = "tám "
Case "9": Doi1so = "chín "
Case "0": Doi1so = "không "
End Select
End Function

Có thể dùng cách viết khác:

Function Doi1so(motso As String) As String
' motso: "0","1","2","3","4","5","6","7","8","9"
If IsNull(Motso) or IsEmpty(Motso) or (len(motso)>1) or (Instr(1,"0123456789",Motso)=0) then
Doi1so=""
End If
Dim Chuoi as string
Chuoi="khôngmột hai ba bốn năm sáu bảy tám chín "
Doi1so=Trim(Mid(val(Motso)*5+1,5))
End Function

Hàm đổi 1 số có từ 1 đến 3 ký số sang dạng chuỗi: 0-999
Có sử dụng hàm đổi 1 số có 1 ký số

Public Function Doi3so(num As Integer) As String
If num>999 then
Doi3so=""
Exit Function
End if
Dim I As Byte, k As Byte, snum As string, Kq As String
snum = Trim(Str(num))
I = Len(snum)
Kq = ""
For k = 1 To I
Kq = Doi1so(Mid(snum, I + 1 - k, 1))
Select Case k
Case 1: Doi3so = Kq
Case 2: Doi3so = Kq & "m­ươi " & Doi3so
Case 3: Doi3so = Kq & "trăm " & Doi3so
End Select
Next
Doi3so = Replace(Doi3so, "m­ươi năm", "mươi lăm")
Doi3so = Replace(Doi3so, "một mươi", "m­ười")
Doi3so = Replace(Doi3so, "không mươi", "lẻ")
Doi3so = Replace(Doi3so, "m­ười không", "mười")
Doi3so = Replace(Doi3so, "m­ươi không", "mười")
Doi3so = Replace(Doi3so, "lẻ không", "")
Doi3so = Replace(Doi3so, "m­ươi một", "mươi mốt")
Doi3so = Replace(Doi3so, "lẻ lăm", "lẻ năm")
Doi3so = Trim(Doi3so) & " "
End Function

Hàm đổi 1 số từ 0-999.999.999.999 sang dạng chuỗi
Có dùng các hàm đổi 1 số và đổi 3 số đã viết ở trên

Public Function NumToText(so As Double) As String
Dim num As Double, sonhom As Byte, chuoi As String, dai As Byte, j As Byte, chuoicon As String, Kq As String, SoDu As Byte
num = Int(so)
chuoi = Trim(Str(num))
dai = Len(chuoi)
sonhom = dai \ 3
SoDu = dai Mod 3
If (SoDu) <> 0 Then
sonhom = sonhom + 1
End If
For j = 1 To sonhom
Kq = ""
If j < sonhom Then
chuoicon = Mid(chuoi, dai - j * 3 + 1, 3)
Else
chuoicon = Left(chuoi, IIf(SoDu = 0, 3, SoDu))
End If
Kq = Doi3so(Val(chuoicon))
Select Case j
Case 1: NumToText = Kq
Case 2:
If Kq <> "không " Then
NumToText = Kq & "ngàn " & NumToText
End If
Case 3:
If Kq <> "không " Then
NumToText = Kq & " triệu " & NumToText
End If
Case 4:
If Kq <> "không " Then
NumToText = Kq & " tỷ " & NumToText
End If
End Select
Next
NumToText = Replace(NumToText, " ", " ")
NumToText = Replace(NumToText, " ", " ")
If Right(NumToText, 6) = "không " Then
NumToText = Left(NumToText, Len(NumToText) - 6)
End If
NumToText = UCase(Left(NumToText, 1)) & Mid(NumToText, 2)
End Function

 

[dangtuanson]

Ðề: Tặng nhau những ý tưởng lập trình quý giá

Lập trình cho 1 bài toán vui:

- Đề bài: Bạn có thể nghĩ sẵn trong đầu 1 số bất kỳ có giá trị từ 0-1.000, sau không quá 10 lần tôi hỏi,chắc chắn tôi sẽ đoán được số bạn nghĩ là con số nào. Câu hỏi của tôi chỉ đơn giản là: "Số của bạn nghĩ có phải là số N không?". Trong đó N là số bất kỳ tôi nghĩ ra để hỏi bạn. Nếu đúng thì coi như bạn thua. Còn không đúng thì bạn phải trả lời: "Số tôi nghĩ lớn hơn số bạn hỏi" hoặc "Số tôi nghĩ nhỏ hơn so với số bạn hỏi!"

Thuật toán như sau:

Sub Timso()
Dim sodau As Integer, socuoi As Integer, sohoi As Integer, I As Byte, Kq As String * 1
sohoi = 512
Kq = " "
For I = 1 To 10
Kq = InputBox("Hoi lan thu " & I & Chr(13) & Chr(10) & "So ban nghi la so " & sohoi & " phai khong?" & Chr(10) & Chr(13) & "Go D-Dung N-Nho hon L-Lon hon")
Select Case Kq
Case "D"
MsgBox "Ban da thua o lan hoi thu " & I
Exit Sub
Case "N"
socuoi = sohoi
Case "L"
sodau = sohoi
End Select
sohoi = (sodau + socuoi) / 2
Next
MsgBox "So ban nghi chinh la so " & sohoi
End sub

Tổng quát của bài toán: Bạn sẽ đoán ra 1 số từ 0-2 lũy thừa n trong vòng n lần hỏi.

 

[myle]

Ðề: Tặng nhau những ý tưởng lập trình quý giá

Bạn tuanson ơi, làm gì cn mà bạn lang thang sớm thế hichic, đúng là bạn có những lập trình quý giá thật, cám ơn bạn rất nhiều.........

 

[dangtuanson]

Ðề: Tặng nhau những ý tưởng lập trình quý giá

Xin gửi các bạn các hàm để chuyển số sang chuỗi bằng tiếng Anh:

Function SpellNumber(ByVal MyNumber)
Dim Dollars, Cents, Temp
Dim DecimalPlace, Count

ReDim Place(9) As String
Place(2) = " Thousand "
Place(3) = " Million "
Place(4) = " Billion "
Place(5) = " Trillion "

MyNumber = Trim(Str(MyNumber))

DecimalPlace = InStr(MyNumber, ".")
If DecimalPlace > 0 Then
Cents = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2))
MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
End If

Count = 1
Do While MyNumber <> ""
Temp = GetHundreds(Right(MyNumber, 3))
If Temp <> "" Then Dollars = Temp & Place(Count) & Dollars
If Len(MyNumber) > 3 Then
MyNumber = Left(MyNumber, Len(MyNumber) - 3)
Else
MyNumber = ""
End If
Count = Count + 1
Loop

Select Case Dollars
Case ""
Dollars = "No Dollars"
Case "One"
Dollars = "One Dollar"
Case Else
Dollars = Dollars & " Dollars"
End Select

Select Case Cents
Case ""
Cents = " and No Cents"
Case "One"
Cents = " and One Cent"
Case Else
Cents = " and " & Cents & " Cents"
End Select

SpellNumber = Dollars & Cents
End Function

'*******************************************
' Hàm chuyển đổi số có 3 chữ số sang text (100-999) *
'*******************************************

Function GetHundreds(ByVal MyNumber)
Dim Result As String

If Val(MyNumber) = 0 Then Exit Function
MyNumber = Right("000" & MyNumber, 3)

If Mid(MyNumber, 1, 1) <> "0" Then
Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
End If

If Mid(MyNumber, 2, 1) <> "0" Then
Result = Result & GetTens(Mid(MyNumber, 2))
Else
Result = Result & GetDigit(Mid(MyNumber, 3))
End If

GetHundreds = Result
End Function

'******************************
' Chuyển đổi số từ 10 to 99 sang text. *
'******************************
Function GetTens(TensText)
Dim Result As String

Result = ""
If Val(Left(TensText, 1)) = 1 Then
Select Case Val(TensText)
Case 10: Result = "Ten"
Case 11: Result = "Eleven"
Case 12: Result = "Twelve"
Case 13: Result = "Thirteen"
Case 14: Result = "Fourteen"
Case 15: Result = "Fifteen"
Case 16: Result = "Sixteen"
Case 17: Result = "Seventeen"
Case 18: Result = "Eighteen"
Case 19: Result = "Nineteen"
Case Else
End Select
Else
Select Case Val(Left(TensText, 1))
Case 2: Result = "Twenty "
Case 3: Result = "Thirty "
Case 4: Result = "Forty "
Case 5: Result = "Fifty "
Case 6: Result = "Sixty "
Case 7: Result = "Seventy "
Case 8: Result = "Eighty "
Case 9: Result = "Ninety "
Case Else
End Select
Result = Result & GetDigit _
(Right(TensText, 1))
End If
GetTens = Result
End Function

'**********************
' Đổi số từ 1 to 9 sang text. *
'**********************
Function GetDigit(Digit)
Select Case Val(Digit)
Case 1: GetDigit = "One"
Case 2: GetDigit = "Two"
Case 3: GetDigit = "Three"
Case 4: GetDigit = "Four"
Case 5: GetDigit = "Five"
Case 6: GetDigit = "Six"
Case 7: GetDigit = "Seven"
Case 8: GetDigit = "Eight"
Case 9: GetDigit = "Nine"
Case Else: GetDigit = ""
End Select
End Function

--- Chúc các bạn thành công ---

Hàm chuẩn hóa tên họ tên người. Ví dụ nhập họ tên: "tran THI vAN" thì hàm phải trả kết quả "Tran Thi Van". Hàm này chỉ dùng cho các ký tự không dấu.

Public Function ChangeCase(chuoi As String) As String
' Chuoi la chuỗi nhập họ và tên
Dim Schuoi As String, Dai As Byte, Kq As String * 1, i As Byte, Kqtruoc As String * 1
Schuoi = Trim(chuoi)
Dai = Len(Schuoi)
ChangeCase = ""
Kqtruoc = " "
For i = 1 To Dai
Kq = Mid(Schuoi, i, 1)
If Kqtruoc = " " Then
If Kq <> " " Then
ChangeCase = ChangeCase & UCase(Kq)
End If
Else
If Kq <> " " Then
ChangeCase = ChangeCase & LCase(Kq)
Else
ChangeCase = ChangeCase & Kq
End If
End If
Kqtruoc = Kq
Next
End Function

Bài tập hay cho các bạn yêu thích: Hàm chuyển đổi với chuỗi thuộc bảng mã Unicode có dấu tiếng Việt.
---- Chúc các bạn thành công ----