Đánh giá chủ đề:
  • 4 Votes - 2.25 Average
  • 1
  • 2
  • 3
  • 4
  • 5
Mỗi ngày một code VBA
#1
Em mong các bác cùng em tham gia nhiệt tình luồng này nhé, các bác có gì hay cùng post lên cho anh em cùng được mở rộng tầm mắt nhé

Public Function Mahoa(Data As String, Optional Depth As Integer) As String
Dim TempChar As String
Dim TempAsc As Integer
Dim NewData As String
Dim vChar As Integer
For vChar = 1 To Len(Data)
TempChar = Mid$(Data, vChar, 1)
TempAsc = Asc(TempChar)
If Depth = 0 Then Depth = 40
If Depth > 254 Then Depth = 254

TempAsc = TempAsc + Depth
If TempAsc > 255 Then TempAsc = TempAsc - 255
TempChar = Chr(TempAsc)
NewData = NewData & TempChar
Next vChar
Mahoa = NewData

Giải thích các đối số:
Data: Chuối ký tự cần mã hoá
Depth: Tuỳ chọn độ dài mã hoá là các số nguyên

VD1: Mahoa("vba",8)=> kết quả là ~ji
nhưng mahoa("vba",9) => kết quả lại là kj
Các bác tự nghiên cứu tiếp nhé.

Tất nhiên đã có mã hoá thì phải có giải mã. Em xin khất các bác hôm sau nhé
Reply
#2
Như đã hẹn, em xin gửi các bác tham khảo code giaima

Public Function GiaiMa(Data As String, Optional Depth As Integer) As String
Dim TempChar As String
Dim TempAsc As Integer
Dim NewData As String
Dim vChar As Integer

For vChar = 1 To Len(Data)
TempChar = Mid$(Data, vChar, 1)
TempAsc = Asc(TempChar)
If Depth = 0 Then Depth = 40
If Depth > 254 Then Depth = 254
TempAsc = TempAsc - Depth
If TempAsc < 0 Then TempAsc = TempAsc + 255
TempChar = Chr(TempAsc)
NewData = NewData & TempChar
Next vChar
GiaiMa = NewData
End Function

Chú ý: VD các bác mã hoá dùng hàm mahoa("vba",9)=~ji
Do đó khi giải mã, các bác phải dùng hàm: giaima("~ji",9) => kết quả là vba
Nếu các bác dùng giaima("~ji",6) thì lại ra 1 kết quả khác đấy
Reply
Những người đã cảm ơn Noname , Cafe Via He , haquocquan , lacbuidoi , ZUNGNN , Hạ Vàng , conmeo , Minh Tiên , jason
#3
Về ứng dụng 2 hàm này các bác có thể sử dụng trong việc quản lý mã hoá mật khẩu trong table User của các bác là hay nhất
Reply
Những người đã cảm ơn Noname , haquocquan , ZUNGNN , Hạ Vàng , conmeo
#4
Hàm tạo thư mục theo đường dẫn

Public Function CreateDir(path As String) As Boolean

Static Start, pos As Integer
Static directory As String
Static result As Boolean
result = True

' initialize the error trap
On Error GoTo errCreation

' if null string why bother....
If path = "" Then Err.Raise vbObjectError + 1

' start will always be null
' the first time through
If Start = Empty Then
Start = 1
Else
Start = pos + 1
End If

' find "\" if the char exists
pos = InStr(Start, path, Chr$(92))

If (pos <> 0) Then
' not at the last directory in the path string...
directory = directory + Mid$(path, Start, pos - Start) + Chr$(92)
If InStr(1, Mid$(path, Start, pos - Start), Chr$(58)) = 0 And Dir(directory, vbDirectory) = "" Then
MkDir Mid$(directory, 1, Len(directory) - 1)
End If
' call itself
result = CreateDir(path)
ElseIf (pos = 0) Then
' the last directory or the only in the path string
directory = directory + Mid$(path, Start, Len(path) - Start + 1)
MkDir Mid$(directory, 1, Len(directory))
directory = ""
End If

' success return true
CreateDir = result

Exit Function

' if it gets here, an exception was thrown
' propogate the error to the calling function
errCreation:
Err.Clear
result = False
CreateDir = result

End Function

VD:
If Dir("C:\vba\vba1")="" then
createdir ("c:\vba\vba1")
endif
=> Hàm đã tạo ra thư mục vba1 nằm trong thư mục vba ở thư mục gốc của ổ đĩa C
Reply
#5
Cũng có một hàm tạo thư mục theo đường dẫn khác (sử dụng hàm của Access, không phải tự tạo hàm):
Ví dự
Mã:
MkDir("C:\VBA\VBA1")

Kết quả tương tự như trên
Chữ ký của haquocquan Guest, you are welcome!
ღღღღღTài sản của haquocquan (View All Items) ღღღღღ
Reply
Những người đã cảm ơn Noname , Hạ Vàng , conmeo , Minh Tiên
#6
Bác Haquocquan liệu có nhầm không nhỉ. Hàm Mkdir chỉ tạo được 1 cấp thôi thôi
VD: Mình cần tạo thư mục "D:\vba\vba1\vba2\vba3\vba4\vba5" thì khi dùng hàm Createdir ở trên chỉ cần gọi:
Createdir("D:\vba\vba1\vba2\vba3\vba4\vba5")
Nhưng dùng hàm Mkdir của bác thì phải dùng như sau:

Mrdir ("D:\vba")
Mrdir ("D:\vba\vba1")
Mrdir ("D:\vba\vba1\vba2")
Mrdir ("D:\vba\vba1\vba2\vba3")
Mrdir ("D:\vba\vba1\vba2\vba3\vba4")
Mrdir ("D:\vba\vba1\vba2\vba3\vba4\vba5")

Nếu dùng Mrdir ("D:\vba\vba1\vba2\vba3\vba4\vba5") chương trình sẽ báo lỗi ngay là: Runtime -error 76
Path not found
Bởi vì nó tìm ngay thư mục vba đã không thấy rồi. Nói tóm lại nó chỉ tạo được thư mục từng cấp thôi

Qua VD trên của em, về mỹ quan bác thấy dùng hàm nào hơn rồi đấy
Reply
Những người đã cảm ơn haquocquan , Hạ Vàng , conmeo
#7
4. Hàm tính số ngày làm việc loại trừ đi ngày T7 và CN

Public Function WorkingDays(StartDate As Date, EndDate As Date) As Integer
On Error GoTo Err_WorkingDays
Dim intCount As Integer
StartDate = StartDate + 1
intCount = 0
Do While StartDate <= EndDate

Select Case WeekDay(StartDate)
Case Is = 1, 7
intCount = intCount
Case Is = 2, 3, 4, 5, 6
intCount = intCount + 1
End Select
StartDate = StartDate + 1
Loop
WorkingDays = intCount

Exit_WorkingDays:
Exit Function

Err_WorkingDays:
Select Case Err

Case Else
MsgBox Err.Description
Resume Exit_WorkingDays
End Select
End Function


Reply
Những người đã cảm ơn Noname , haquocquan , cuongtuyetcz , lacbuidoi , Hạ Vàng , conmeo , hatashibl , Minh Tiên , DoquangLam , jason
#8
Mấy hôm rồi bận quá, hôm nay mới vào được mong các pro thông cảm nhá
5. Hàm Format các giá trị number, Text, Date trên các control trong Form hoặc Report hoặc câu lệnh SQL, rất tiện lợi
Public Function Cv(Value, Num_Text_or_Date As String) As Variant

'The Num_Text_or_Date parameter accepts:
' N, Num or Number for Boolean,Byte,Integer,Long,Currency,Single,Double
' T, Text or String for Text, Memo
' D or Date for Date/Time
If Not IsNull(Value) Then
Select Case Num_Text_or_Date
Case "N", "Num", "Number"
Cv = Value
Case "T", "Text", "String"
Cv = Chr(34) & Replace(Value, "'", "''") & Chr(34)
Case "D", "Date"
Cv = "#" & Format(Value, "mm/dd/yyyy") & "#"
Case Else
MsgBox "Gia tri nay chua duoc ung dung trong ham nay", vbExclamation
End Select
End If
End Function

VD khi sử dụng:
Dim SQL As String

SQL = "SELECT * FROM tblCustomers WHERE DateField = " & Cv(DateControl, "D")
SQL = SQL & " AND TextField = " & Cv(TextControl, "T")
Debug.Print SQL

Kết quả là:

SELECT * FROM tblCustomers WHERE DateField = #01/01/2008# AND TextField = "vba"

Theo tôi, cái này các bác có thể ứng dụng vào form tìm kiếm dữ liệu mà trong đó có các Option Group để lựa chọn nhiều tiêu chí tìm kiếm và chỉ cần duy nhất 1 textbox, và khi gõ gia trị vào Textbox này thì có thể nhận được kiểu number, text, date...
Bác nào chưa hiểu, Em sẽ gửi Demo lên sau nhé
Reply
#9
(17-01-11, 10:30 PM)vba Đã viết: Mấy hôm rồi bận quá, hôm nay mới vào được mong các pro thông cảm nhá
5. Hàm Format các giá trị number, Text, Date trên các control trong Form hoặc Report hoặc câu lệnh SQL, rất tiện lợi
Public Function Cv(Value, Num_Text_or_Date As String) As Variant

'The Num_Text_or_Date parameter accepts:
' N, Num or Number for Boolean,Byte,Integer,Long,Currency,Single,Double
' T, Text or String for Text, Memo
' D or Date for Date/Time
If Not IsNull(Value) Then
Select Case Num_Text_or_Date
Case "N", "Num", "Number"
Cv = Value
Case "T", "Text", "String"
Cv = Chr(34) & Replace(Value, "'", "''") & Chr(34)
Case "D", "Date"
Cv = "#" & Format(Value, "mm/dd/yyyy") & "#"
Case Else
MsgBox "Gia tri nay chua duoc ung dung trong ham nay", vbExclamation
End Select
End If
End Function

VD khi sử dụng:
Dim SQL As String

SQL = "SELECT * FROM tblCustomers WHERE DateField = " & Cv(DateControl, "D")
SQL = SQL & " AND TextField = " & Cv(TextControl, "T")
Debug.Print SQL

Kết quả là:

SELECT * FROM tblCustomers WHERE DateField = #01/01/2008# AND TextField = "vba"

Theo tôi, cái này các bác có thể ứng dụng vào form tìm kiếm dữ liệu mà trong đó có các Option Group để lựa chọn nhiều tiêu chí tìm kiếm và chỉ cần duy nhất 1 textbox, và khi gõ gia trị vào Textbox này thì có thể nhận được kiểu number, text, date...
Bác nào chưa hiểu, Em sẽ gửi Demo lên sau nhé

Cho mình xin file demo nhe bác vba
Cảm ơn bác nhiều.
Chữ ký của dannynguyen1980 Xin chào, mình là dannynguyen1980, Tham gia http://thuthuataccess.com/forum từ ngày 14-09 -11.
Reply
Những người đã cảm ơn vulhu06
#10
(08-01-11, 10:12 PM)vba Đã viết: Em mong các bác cùng em tham gia nhiệt tình luồng này nhé, các bác có gì hay cùng post lên cho anh em cùng được mở rộng tầm mắt nhé

Public Function Mahoa(Data As String, Optional Depth As Integer) As String
Dim TempChar As String
Dim TempAsc As Integer
Dim NewData As String
Dim vChar As Integer
For vChar = 1 To Len(Data)
TempChar = Mid$(Data, vChar, 1)
TempAsc = Asc(TempChar)
If Depth = 0 Then Depth = 40
If Depth > 254 Then Depth = 254

TempAsc = TempAsc + Depth
If TempAsc > 255 Then TempAsc = TempAsc - 255
TempChar = Chr(TempAsc)
NewData = NewData & TempChar
Next vChar
Mahoa = NewData

Giải thích các đối số:
Data: Chuối ký tự cần mã hoá
Depth: Tuỳ chọn độ dài mã hoá là các số nguyên

VD1: Mahoa("vba",8)=> kết quả là ~ji
nhưng mahoa("vba",9) => kết quả lại là kj
Các bác tự nghiên cứu tiếp nhé.

Tất nhiên đã có mã hoá thì phải có giải mã. Em xin khất các bác hôm sau nhé
Chào bạn "VBA" !
Hàm Mã hóa và Giải mã của bật rất hay.
Xong nếu đã Mã hóa theo cách này rồi thì có thể "giải mã được" bằng cách tra dần từ 1-255 vào hàm Giải mã ! Như thế tính bảo mật chưa OK lắm.
Bạn có cách nào mã hóa với bảo mật OK hơn, chia sẽ với diễn đàn nhé !
Cảm ơn bạn nhiều !
Chữ ký của Minh Tiên -----------------------------------------------
Đường tuy ngắn, không đi không đến
Việc tuy nhỏ, không làm không nên.
                                           Tuân Tử
-----------------------------------------------
Reply
Những người đã cảm ơn


Có thể liên quan đến chủ đề
Chủ đề: Tác giả Trả lời: Xem: Bài mới nhất
Photo [Thủ Thuật] Code chia sẽ hàng thừa Phung Duc 2 57 05-12-16, 04:34 PM
Bài mới nhất: Phung Duc
  [Hỏi] Viết code có điều kiện " lệnh Chạy tiếp khi đóng tbl cho sẵn" Trần Linh 3 140 21-10-16, 11:11 AM
Bài mới nhất: Minh Tiên
  Giải thích ý nghĩ của đoạn code feeling 3 197 06-10-16, 10:18 AM
Bài mới nhất: vulhu06
  [Help] Truy vấn ngày phát sinh gần nhất trong access cuuvinh 4 226 21-09-16, 05:01 PM
Bài mới nhất: cuuvinh
  [Hỏi] Sử dụng ngày trong truy vấn qua VBA tại sao không đúng? luonguct 5 323 09-06-16, 06:24 PM
Bài mới nhất: maidinhdan

Chuyển nhanh:


User(s) browsing this thread: 1 Guest(s)
Diễn Đàn Thơ Văn Thi Ẩm Lâu|Nhà Hàng Sông Thơ