Xin thầy và các bạn xem giúp file đính kèm, vì chiều dài label ngắn mà dòng chữ dài nên khi hiện lên chữ sẽ bị mất nên mình nghĩ nên cắt bớt bằng hàm left nhưng khi thêm hàm left thì thấy dòng chữ ko chạy nữa
Xin thầy và các bạn xem giúp file đính kèm, vì chiều dài label ngắn mà dòng chữ dài nên khi hiện lên chữ sẽ bị mất nên mình nghĩ nên cắt bớt bằng hàm left nhưng khi thêm hàm left thì thấy dòng chữ ko chạy nữa
Xin thầy và các bạn xem giúp file đính kèm, vì chiều dài label ngắn mà dòng chữ dài nên khi hiện lên chữ sẽ bị mất nên mình nghĩ nên cắt bớt bằng hàm left nhưng khi thêm hàm left thì thấy dòng chữ ko chạy nữa
Chạy chữ kiểu đó.. mệt chết được
Tặng bạn kiểu khác nè:
1> Trong Module
PHP:
Function TimeProc(ByVal H As Long, ByVal nMSG As Long, ByVal nID As Long, ByVal nTsys As Long)
Dim Text As String
On Error Resume Next
Text = fchaychu.Label1.Caption
Text = Mid(Text, 2, Len(Text)) & Left(Text, 1)
fchaychu.Label1.Caption = Text
End Function
2> Trong UserForm
PHP:
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetTimer Lib "user32" _
(ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private hWnd As Long
Mã:
Private Sub UserForm_Initialize()
hWnd = FindWindow("ThunderDFrame", Me.Caption)
End Sub
Mã:
Sub StartTimer()
StopTimer
SetTimer Application.hWnd, 1, [COLOR=#ff0000]50[/COLOR], AddressOf TimeProc
End Sub
Mã:
Sub StopTimer()
KillTimer Application.hWnd, 1
End Sub
Mã:
Private Sub UserForm_Activate()
On Error Resume Next
StartTimer
End Sub
Mã:
Private Sub UserForm_Terminate()
StopTimer
End Sub
Điều kiện chạy chữ nằm trong code của Module còn tốc độ là số màu đỏ trong UserForm ---> Số càng lớn, tốc độ chạy càng chậm và ngược lại
Thật tình mà nói thì cái bài Thầy gửi lên em check lại không thấy lỗi, vậy sai ở chỗ nào vậy ạ? Kể cả em đã bỏ đi các On Error .. rồi mà vẫn không báo lỗi?
Thật tình mà nói thì cái bài Thầy gửi lên em check lại không thấy lỗi, vậy sai ở chỗ nào vậy ạ? Kể cả em đã bỏ đi các On Error .. rồi mà vẫn không báo lỗi?
Chổ màu đỏ ấy!
Bây giờ hên nó chạy được nhưng nếu đưa vào 1 chương trình lớn có thể bị lỗi nghiêm trọng (treo Excel luôn). Lúc đó chẳng biết đường nào mà lần
Chổ màu đỏ ấy!
Bây giờ hên nó chạy được nhưng nếu đưa vào 1 chương trình lớn có thể bị lỗi nghiêm trọng (treo Excel luôn). Lúc đó chẳng biết đường nào mà lần
À, Thầy ơi, em cũng thử gán cho Form Caption vào hàm, nó vẫn chạy ào ào, có điều làm sao để cho nó có chữ Unicode hả Thầy?
Mã:
Function TimeProc(ByVal H As Long, ByVal nMSG As Long, ByVal nID As Long, ByVal nTsys As Long)
Dim Text As String
'On Error Resume Next
Text = fchaychu.Label1.Caption
Text = Mid(Text, 2, Len(Text)) & Left(Text, 1)
fchaychu.Label1.Caption = Text
[COLOR=#ff0000][B]fchaychu.Caption = Text[/B][/COLOR]
End Function
À, Thầy ơi, em cũng thử gán cho Form Caption vào hàm, nó vẫn chạy ào ào, có điều làm sao để cho nó có chữ Unicode hả Thầy?
Mã:
Function TimeProc(ByVal H As Long, ByVal nMSG As Long, ByVal nID As Long, ByVal nTsys As Long)
Dim Text As String
'On Error Resume Next
Text = fchaychu.Label1.Caption
Text = Mid(Text, 2, Len(Text)) & Left(Text, 1)
fchaychu.Label1.Caption = Text
[COLOR=#ff0000][B]fchaychu.Caption = Text[/B][/COLOR]
End Function
Thật tình em cũng bó tay khi kết hợp với cái này, nó dù thế nào đi nữa nó cũng hoặc là đứng im và hiện đúng font, hai là nó chạy mà font bị lỗi
Với mảng em đã thấy nó khá trừu tượng rồi, với các API này em tưởng tượng còn không ra đừng nói chi đến trừu tượng!
Em thường dùng các thủ tục dưới đây, với óc sáng tạo của Thầy, em tin có thể Thầy cho nó chạy hoành tráng.
Mã:
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function DefWindowProc Lib "user32.dll" Alias "DefWindowProcW" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Sub SetUnicodeCaption(ByVal frm As UserForm, ByVal UnicodeString As String)
Dim hWnd&
hWnd = FindWindow("ThunderDFrame", frm.Caption)
DefWindowProc hWnd, &HC, 0, StrPtr(UnicodeString)
End Sub
Thủ tục chạy code trên form:
Mã:
Private Sub UserForm_Initialize()
SetUnicodeCaption Me, Sheet1.[D11].Value
End Sub
Chổ màu đỏ ấy!
Bây giờ hên nó chạy được nhưng nếu đưa vào 1 chương trình lớn có thể bị lỗi nghiêm trọng (treo Excel luôn). Lúc đó chẳng biết đường nào mà lần
Tuấn yên tâm đi. Trong trường hợp Tuấn cung cấp TimerProc thì thông điệp WM_TIMER không được gửi tới hàm cửa sổ nên Tuấn có nhập hWnd (của UserForm1) hay Application.hWnd, hay cái gì thì cũng thế thôi.
Có lần tôi đã viết về TimerProc và cơ cấu thông điệp nhưng lúc đó tôi bị "gạt" đi vì lý do: "Có viết cũng không ai hiểu. Có viết thì cũng không ai cần".
Các cụ đã nói: ăn có mời, làm có khiến. Không được mời ăn cỗ mà cứ đến, không khiến làm mà cứ làm thì vô duyên lắm. Tôi không có nhu cầu viết tới mức phải vô duyên.
Nếu các bạn copy code của người khác nhưng các bạn không tìm đọc để hiểu được code đó thì các bạn chỉ biết dùng. Nếu người ta viết chưa chuẩn thì các bạn cũng không biết.
Có thể thiết lập Timer bằng 2 cách:
1. Ta truyền vào SetTimer handle của cửa sổ được gán cho Timer và truền vào chỗ lpTimerFunc giá trị 0. Tức ta không truyền địa chỉ của sub TimerProc mà chỉ truyền handle của cửa sổ nào đó. Lúc đó thì trong những khoảng thời gian mà ta xác lập ở thông số thứ ba Windows sẽ gửi thông điệp WM_TIMER tới cửa sổ có handle nói trên. Nói chính xác thì Windows đặt thông điệp vào hàng đợi (message queue). Handle cần để Windows biết phải gửi thông điệp tới cửa sổ nào.
2. Ta không truyền handle của cửa sổ nào mà truyền địa chỉ của TimerProc. Lúc này thì trong khoảng thời gian được xác định bởi thông số thứ ba thì Windows sẽ gọi TimerProc.
Trường hợp 2 tương tự như khi trong Excel các bạn dùng Application.OnTime: các bạn phải "chỉ" ra sub sẽ được thực hiện. Chỉ khác là trong Excel sub kia chỉ được thực hiện 1 lần, muốn thực hiện tiếp thì lại phải xác lập tiếp trong khi với SetTimer thì TimerProc sẽ được thực hiện đều đặn cho tới khi Timer bị hủy - KillTimer
--------------
Các bạn sẽ hỏi: Thế nếu không sảy ra 2 trường hợp trên mà sảy ra trường hợp như code của Tuấn đưa lên, tức ta truyền cả handle và cả địa chỉ của TimerProc?
Nếu các bạn đọc kỹ phần Remarks trong hình ở trên thì các bạn phải biết rằng: khi đã truyền địa chỉ TimerProc thì thông điệp WM_TIMER không được gửi tới bất cứ cửa sổ nào cho dù ta truyền nó vào thông số thứ nhất của SetTimer. Nói cách khác thì: khi đã truyền địa chỉ của TimerProc thì thông số thứ nhất (window handle) sẽ bị "lờ" đi, vô dụng - vậy có thể truyền bất cứ giá trị nào kể cả những giá trị không phải là handle của bất cứ cửa sổ nào trong system, ví dụ truyền vào giá trị 0.
-----------------
Nếu các bạn còn nghi ngờ thì tôi đính kèm code. Để có thể kiểm tra xem liệu thông điệp WM_TIMER có được gửi tới cửa sổ hay không thì tôi dùng subclassing.
Module1
[GPECODE=vb]
Sub Button1_Click()
UserForm1.Show
End Sub
Sub Button2_Click()
UserForm2.Show
End Sub
Sub Button3_Click()
UserForm3.Show
End Sub
[/GPECODE]
Module2
[GPECODE=vb]
Public Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function SetTimer Lib "user32" _
(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
On Error GoTo end_
If uMsg = WM_TIMER Then Debug.Print "Print in WindowProc"
end_:
WindowProc = CallWindowProc(OldWindowProc, hwnd, uMsg, wParam, lParam)
End Function
Sub SetWindowProc(ByVal hWin As Long, ByVal DoSet As Boolean)
If DoSet Then
If OldWindowProc = 0 Then
OldWindowProc = SetWindowLong(hWin, GWL_WNDPROC, AddressOf WindowProc)
End If
ElseIf OldWindowProc <> 0 Then
SetWindowLong hWin, GWL_WNDPROC, OldWindowProc
OldWindowProc = 0
End If
End Sub
Function TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
Dim Text As String * 128, size As Long
On Error Resume Next
Debug.Print "Print in TimerProc"
End Function
[/GPECODE]
UserForm1
[GPECODE=vb]
Private hwnd As Long
Private Sub UserForm_Activate()
StartTimer
End Sub
Private Sub UserForm_Initialize()
Debug.Print "Bat dau vi du UserForm1"
hwnd = FindWindow("ThunderDFrame", Me.Caption)
SetWindowProc hwnd, True
End Sub
Sub StartTimer()
StopTimer
SetTimer hwnd, 1000, 50, 0
End Sub
Sub StopTimer()
KillTimer hwnd, 1000
End Sub
Private Sub UserForm_Terminate()
StopTimer
SetWindowProc hwnd, False
Debug.Print "Ket thuc vi du UserForm1"
End Sub
[/GPECODE]
UserForm2
[GPECODE=vb]
Private hwnd As Long
Private Sub UserForm_Activate()
StartTimer
End Sub
Private Sub UserForm_Initialize()
Debug.Print "Bat dau vi du UserForm2"
hwnd = FindWindow("ThunderDFrame", Me.Caption)
SetWindowProc hwnd, True
End Sub
Sub StartTimer()
StopTimer
SetTimer hwnd, 1000, 50, AddressOf TimerProc
End Sub
Sub StopTimer()
KillTimer hwnd, 1000
End Sub
Private Sub UserForm_Terminate()
StopTimer
SetWindowProc hwnd, False
Debug.Print "Ket thuc vi du UserForm2"
End Sub
[/GPECODE]
----------------
Khi các bạn nhấn Button1 thì các bạn có đại loại:
Bat dau vi du UserForm1
Print in WindowProc
Print in WindowProc
Print in WindowProc
Print in WindowProc
Print in WindowProc
Ket thuc vi du UserForm1
Dễ hiểu thôi vì các bạn chỉ truyền handle của UserForm1 nên thông điệp WM_TIMER được gửi tới hàm cửa sổ WindowProc nên ta có "Print in WindowProc".
Thật tình em cũng bó tay khi kết hợp với cái này, nó dù thế nào đi nữa nó cũng hoặc là đứng im và hiện đúng font, hai là nó chạy mà font bị lỗi
Với mảng em đã thấy nó khá trừu tượng rồi, với các API này em tưởng tượng còn không ra đừng nói chi đến trừu tượng!
Em thường dùng các thủ tục dưới đây, với óc sáng tạo của Thầy, em tin có thể Thầy cho nó chạy hoành tráng.
Mã:
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function DefWindowProc Lib "user32.dll" Alias "DefWindowProcW" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Sub SetUnicodeCaption(ByVal frm As UserForm, ByVal UnicodeString As String)
Dim hWnd&
hWnd = FindWindow("ThunderDFrame", frm.Caption)
DefWindowProc hWnd, &HC, 0, StrPtr(UnicodeString)
End Sub
Thủ tục chạy code trên form:
Mã:
Private Sub UserForm_Initialize()
SetUnicodeCaption Me, Sheet1.[D11].Value
End Sub
Đoạn code quan trọng để hiện Unicode text của bạn là: DefWindowProc hWnd, &HC, 0, StrPtr(Text) ---> Vậy thì cho nó vào Function TimeProc là xong chứ gì
Làm lại toàn bộ: 1> Code trong Module:
PHP:
Private Declare Function SetTimer Lib "user32" _
(ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function DefWindowProc Lib "user32.dll" Alias "DefWindowProcW" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public hWnd As Long
Mã:
Private Function TimeProc(ByVal H As Long, ByVal nMSG As Long, ByVal nID As Long, ByVal nTsys As Long)
Dim Text As String
On Error Resume Next
Text = frm.Label1.Caption '<--- frm là tên của UserForm nha
Text = Mid(Text, 2, Len(Text)) & Left(Text, 1)
frm.Label1.Caption = Text
[COLOR=#ff0000]DefWindowProc hWnd, [/COLOR][COLOR=#0000cd]12[/COLOR][COLOR=#ff0000], 0, StrPtr(Text)[/COLOR] ''<--- &HC viết cha nó thành số 12 cho rồi
End Function
Mã:
Sub StartTimer()
StopTimer
SetTimer hWnd, 1, 50, AddressOf TimeProc
End Sub
Mã:
Sub StopTimer()
KillTimer hWnd, 1
End Sub
2> Code trong UserForm:
PHP:
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Mã:
Private Sub UserForm_Initialize()
On Error Resume Next
hWnd = FindWindow("ThunderDFrame", Me.Caption)
StartTimer
End Sub
Mã:
Private Sub UserForm_Terminate()
StopTimer
End Sub
Đoạn code quan trọng để hiện Unicode text của bạn là: DefWindowProc hWnd, &HC, 0, StrPtr(Text) ---> Vậy thì cho nó vào Function TimeProc là xong chứ gì
Eo ui, sao mà hoành tráng thế! Nhưng thật sự em đã thử như vậy mấy lần rồi, nó cứ như bị treo máy, thậm chí bấm thoát cái VBE nó cũng không cho, bấm nút Stop nó cũng không cho. Chắc lúc thử nó bị công đoạn nào lỗi chăng ta?
Tuy nhiên, có một lệ thuộc vào Label, nếu không có label chạy thì caption đứng im re, vậy mình thực hiện trực tiếp sẽ như thế nào ạ? Và nếu được thì có thể làm cái hàm đó tổng quát cho nhiều Form có thể thực hiện được không ạ?
À, nhìn vào hàm nó như một vòng lặp, nó cứ lặp đi lặp lại nên không thể không lệ thuộc cái label, vì vậy ta phải sử dụng thêm một biến (public) để cho biến này chạy trong hàm thì không lệ thuộc label nữa!
Mã:
Option Explicit
Private Declare Function SetTimer Lib "user32" _
(ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" _
(ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function DefWindowProc Lib "user32.dll" Alias "DefWindowProcW" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public hWnd As Long, [COLOR=#ff0000][B]fCaption As String[/B][/COLOR]
Sub Button1_Click()
frm.Show
End Sub
Private Function TimeProc(ByVal H As Long, ByVal nMSG As Long, ByVal nID As Long, ByVal nTsys As Long)
Dim Text As String
On Error Resume Next
Text = [COLOR=#ff0000][B]fCaption [/B][/COLOR]
Text = Mid(Text, 2, Len(Text)) & Left(Text, 1)
[COLOR=#ff0000][B]fCaption [/B][/COLOR]= Text
DefWindowProc hWnd, 12, 0, StrPtr(Text)
End Function
Sub StartTimer()
StopTimer
SetTimer hWnd, 1, 50, AddressOf TimeProc
End Sub
Sub StopTimer()
KillTimer hWnd, 1
End Sub
Và khi show form mình chỉ việc chạy thêm thủ tục gán chuỗi cho biến đó thôi:
Mã:
Private Sub UserForm_Initialize()
On Error Resume Next
[COLOR=#ff0000][B]fCaption = Label1.Caption[/B][/COLOR]
hWnd = FindWindow("ThunderDFrame", Me.Caption)
StartTimer
End Sub
Đã giải quyết được vấn đề 1, còn vấn đề tổng quát cho tất cả các form phải như thế nào đây ta? Mò tiếp xem sao!
Không hiểu là vấn đề gì nữa
Biến Text bạn gán cho nó là chuổi gì chả được
Ví dụ:
Mã:
Public hWnd As Long, Text As String
Sub Button1_Click()
Text = "Cong hòa xa hoi chu nghia Viet Nam"
frm.Show
End Sub
Mã:
Private Function TimeProc(ByVal H As Long, ByVal nMSG As Long, ByVal nID As Long, ByVal nTsys As Long)
On Error Resume Next
Text = Mid(Text, 2, Len(Text)) & Left(Text, 1)
frm.Label1.Caption = Text ''(1)
DefWindowProc hWnd, 12, 0, StrPtr(Text) ''(2)
'' Đoạn (1) và (2) là gán Marquee vào Label và Title
End Function
Không hiểu là vấn đề gì nữa
Biến Text bạn gán cho nó là chuổi gì chả được
Ví dụ:
Mã:
Public hWnd As Long, Text As String
Sub Button1_Click()
Text = "Cong hòa xa hoi chu nghia Viet Nam"
frm.Show
End Sub
Mã:
Private Function TimeProc(ByVal H As Long, ByVal nMSG As Long, ByVal nID As Long, ByVal nTsys As Long)
On Error Resume Next
Text = Mid(Text, 2, Len(Text)) & Left(Text, 1)
frm.Label1.Caption = Text ''(1)
DefWindowProc hWnd, 12, 0, StrPtr(Text) ''(2)
'' Đoạn (1) và (2) là gán Marquee vào Label và Title
End Function
Có một đặc điểm mà em thử nhiều cách vẫn không làm được, nếu như dùng form1 để mở form2 rồi đóng form1 (unload) và cũng như vậy đối với form2 thì khi mở đi mở lại trên form thì OK. Song nếu ta không dùng Unload mà dùng Me.Hide thì form1 mở xong rồi hide và cho hiện form2, rồi từ form2 cho hiện lại form1 thì form1 không chạy chữ!
[GPECODE=vb]Private Sub UserForm_Activate()
fCaption = Sheet1.Range("D11").Value
StartTimer
End Sub
Private Sub UserForm_Deactivate()
StopTimer
End Sub
Private Sub UserForm_Initialize()
hWnd = FindWindow("ThunderDFrame", Me.Caption)
End Sub
Private Sub UserForm_Terminate()
StopTimer
Unload UserForm1
End Sub
Private Sub CommandButton1_Click()
'Unload Me
Me.Hide
UserForm1.Show
End Sub
[/GPECODE]
Có một đặc điểm mà em thử nhiều cách vẫn không làm được, nếu như dùng form1 để mở form2 rồi đóng form1 (unload) và cũng như vậy đối với form2 thì khi mở đi mở lại trên form thì OK. Song nếu ta không dùng Unload mà dùng Me.Hide thì form1 mở xong rồi hide và cho hiện form2, rồi từ form2 cho hiện lại form1 thì form1 không chạy chữ!
[GPECODE=vb]Private Sub UserForm_Activate()
fCaption = Sheet1.Range("D11").Value
StartTimer
End Sub
Private Sub UserForm_Deactivate()
StopTimer
End Sub
Private Sub UserForm_Initialize()
hWnd = FindWindow("ThunderDFrame", Me.Caption)
End Sub
Private Sub UserForm_Terminate()
StopTimer
Unload UserForm1
End Sub
Private Sub CommandButton1_Click()
'Unload Me
Me.Hide
UserForm1.Show
End Sub
[/GPECODE]