Hướng dẩn cách tạo(viết) ActiveX control (ocx)

Các bài viết hướng dẫn, giúp các bạn hiểu và tiếp cận với Visual Basic nhanh hơn
Đăng trả lời
Hình đại diện của thành viên
DQHung
Guru
Guru
Bài viết: 576
Ngày tham gia: Thứ 2 12/02/2007 3:24 pm
Đến từ: Rach Gia - Kien Giang
Been thanked: 40 times
Tiếp xúc:

Hướng dẩn cách tạo(viết) ActiveX control (ocx)

Gửi bài by DQHung »

Tên bài viết: Hướng dẩn cách tạo(viết) ActiveX control (ocx)
Tác giả: DQHung
Cấp độ bài viết: Cơ bản & Nâng cao
Tóm tắt: Giúp cho các bạn làm quen dần với việc tạo ra một usercontrol để tạo ocx hay để add vào dự án của bạn

Dành Cho VB6
-----------------------------------------------
Đây là hướng dẩn “đủ” để các bạn tạo 1 ActiveX Control (usercontrol or ocx) :

Cách 1 : Tạo 1 usercontrol dựa vào 1 control có sẳn
- Ví dụ thiết kế một Label mới dựa vào label chuẩn của VB6
+ Tạo một dự án mới, sau đó add vào một usercontrol (h1)
h1.JPG
h1.JPG (10.52 KiB) Đã xem 17959 lần
+ Và mở usercontrol đó lên.Add vào đó 1 label tên là label1
+Cách để bạn tạo các property nhanh nhất và gọn nhất là dùng “ActiveX Controls Interface Wizard …” (để mở nó bạn chọn Menu “Add-In” > “Add-In Manager” , hiện hộp thoại lên bấm vào “VB ActiveX Control Interface Wizard” check cả 2 “Loaded/Unloaded” và “Load on startup” và bấm OK)
,sau đó muốn sử dụng nó bạn chỉ việc vào menu “Add-in” sẻ thấy nó ngay.
+ Bấm vào “ActiveX Controls Interface Wizard …” và hiện ra hộp thoại
h2.JPG
bạn có thể check “Skip this screen in the future.” để mai mốt nó khỏi “làm phiền”
bấm next (Nếu trong project của bạn chỉ có 1 control thì nó sẽ qua hộp thoại này,nếu có nhiều control thì nó sẽ hiện hộp thoại khác để bạn chọn control)
h3.JPG
Đây là bước quan trọng, bạn phải dò tìm những property , method, event của label và chuyễn qua hết vào bên phải (có thể chọn những thứ khác không phải của label), xong bấm next
h4.JPG
Sau đó bấm vào những property,method.event của label và bên phải bấm vào combo và chọn label1 tương ứng (vì ta dùng lại những cái củ của label)
,chọn xong hết bấm next (cái này dành cho cách 2),bấm next thêm cái nửa và bấm finnish là xong, cuối cùng chỉ việc thêm vào vài dòng code sau để label khích với usercontrol :

Private Sub UserControl_Resize()
Label1.Move 0, 0, ScaleWidth, ScaleHeight
End Sub
--------------------------------------------------------
Kỳ sao mình sẽ hướng dẩn cách tạo usercontrol không theo control chuẩn của VB6 (Tức là tự chế :D)
Hình đại diện của thành viên
DQHung
Guru
Guru
Bài viết: 576
Ngày tham gia: Thứ 2 12/02/2007 3:24 pm
Đến từ: Rach Gia - Kien Giang
Been thanked: 40 times
Tiếp xúc:

Re: Hướng dẩn cách tạo(viết) ActiveX control (ocx)

Gửi bài by DQHung »

Cách 2 : Tạo usercontrol dựa vào API (không phải là Createwindow hay CreatewindowEx)
- Ví dụ này cũng vẩn tạo 1 label mới nhưng hổ trợ unicode (Không theo chuẩn của VB6)
Bạn vẩn dùng "ActiveX control Interface wizard …" để tạo các property,method,event nhưng không theo cách củ :
-Bước 1 : Không cho gì vào usercontrol mới cả,Mở "ActiveX control Interface wizard …" ta chọn các property,method,event chủ yếu cho label mới là :BackColor,BackStyle,Click,DoubleClick,Enable,Font,ForeColor,KeyDown,KeyPress,KeyUp,MouseDown,MouseUp,MoseMove,Refresh, bấm next.
h1.JPG
-Bước 2 : bấm new và hiện hôp thoại
h2.JPG
h2.JPG (10.67 KiB) Đã xem 17292 lần
Gỏ vào đó từ "Caption" (Ta tạo property mới) ,trong frame "Type" chọn Property và bấm OK,sau đó bấm next.
Bước 3 : tất cả những Property,Method,Event bên phải đều chọn là Usercontrol hết ,trừ Property "Caption" mà ta mới tạo là để trống (tức là (None))
h3.JPG
Bấm next.
h4.JPG
Trong hộp thoại này,ta chỉ có 1 public name duy nhất là property "Caption" (Vì lúc nãy ta cho nó là (none).)
-Chổ "Data Type" chọn là "String" (Vì đây là caption nên có kiểu String, nếu là một property khác thì tùy vào cấu trúc ta muốn khởi tạo mà đặt, ví dụ ta có property "Picture" thì chổ này phải chọn là "StdPicture" hay "Picture")
-Chổ Default Value (Giá trị ban đầu của caption,tức là khi add vào form nó sẽ mang giá trị này)
- Run Time và Design Time đều chọn là "Read/Write" để người dùng có thể chỉnh sửa lúc đang thiết kế hay đang chạy.
Bấm next, bấm tiếp Finish.
-Xong phần chuẩn bị,bây giờ bắt tay vào làm 1 Label mới (giả)

Chuẩn bị các hàm API sau :

Mã: Chọn tất cả

Private Type RECT        Left As Long        Top As Long        Right As Long        Bottom As LongEnd Type Const DT_EDITCONTROL = &H2000Const DT_LEFT = &H0Const DT_WORDBREAK = &H10 Private Declare Function DrawTextW Lib "user32" (ByVal hdc As Long, ByVal lpStr As Long, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long'Hàm này dùng để vẽ chuỗi Unicode lên usercontrol 'Tạo 1 hàm mới có tên là "DrawLabel" như sau (Hàm này dùng để vẽ toàn bộ UniLabel) : Private Sub DrawLabel()     Dim wRC as RECT , FL as Long     Usercontrol.Cls 'Làm sạch sẽ Usercontrol trước khi vẽ lên     With wRC 'Đặt vị trí để vẽ         .Left = 0          .Top = 0          .Right = ScaleWidth          .Bottom = ScaleHeight      End With     FL = DT_LEFT or DT_WORDBREAK or DT_EDITCONTROL       'bạn có thể cho thêm các cờ vào nếu muốn     DrawTextW Usercontrol.hdc, StrPtr(m_Caption), -1, wRC, FL 'vẽ chuỗiEnd Sub 'Thế là hoàn tất,bạn chỉ còn việc cuối là đưa nó vào 'Sub Resize và Show của Usercontrol là xong Private Sub UserControl_Resize()    DrawLabel 'Vẽ lại khi control thay đỗi kích thướcEnd Sub Private Sub UserControl_Show()    DrawLabel 'Vẽ khi control xuất hiệnEnd Sub Public Sub Refresh()    DrawLabel    UserControl.RefreshEnd Sub 
h1.JPG
Tập tin đính kèm
excontrol.rar
Source code của ví dụ trên
(3.24 KiB) Đã tải về 1332 lần
Hình đại diện của thành viên
DQHung
Guru
Guru
Bài viết: 576
Ngày tham gia: Thứ 2 12/02/2007 3:24 pm
Đến từ: Rach Gia - Kien Giang
Been thanked: 40 times
Tiếp xúc:

Re: Hướng dẩn cách tạo(viết) ActiveX control (ocx)

Gửi bài by DQHung »

Tên bài viết: Hướng dẩn cách tạo(viết) ActiveX control (ocx)
Tác giả: DQHung
Cấp độ bài viết: Chưa đánh giá
Tóm tắt: Cách 3
Cách 3 : Tạo control bằng hàm CreateWindowEx (tất nhiên là có unicode kể cả khi dùng file manifest XP)
Ví dụ này tạo một CommandButton bằng hàm trên
- Chuẫn bị : Bộ subclass của Steve McMahon (Để bẩy các event của control), gồm các file : subclass.bas,subclass.cls,isubclass.cls (Có gởi kèm)
Đưa dòng này vào đầu tiên (sử dụng subclass) :

Mã: Chọn tất cả

Implements ISubclass

Chép đoạn API sau vào usercontrol mới

Mã: Chọn tất cả

Private Declare Function CreateWindowExW Lib "user32" (ByVal dwExStyle As Long, ByVal lpClassName As Long, ByVal lpWindowName As Long, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As LongPrivate Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As LongPrivate Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongPrivate Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As LongPrivate Declare Function SendMessageW Lib "user32" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Const WM_SETTEXT = &HCPrivate Const WS_CHILD = &H40000000Private Const WS_VISIBLE = &H10000000Private Const BS_PUSHBUTTON = &H0&Private Const WM_GETFONT = &H31Private Const WM_SETFONT = &H30Private Const WM_COMMAND = &H111


Dùng "ActiveX control Interface wizard …" tạo 2 property có tên là "Caption" (để là none) và "Font" chọn usercontrol (Nếu ko rành bước này xem lại 2 bài trên)

Khởi tạo 2 biến

Mã: Chọn tất cả

Dim hFont As Long ' Dùng để chứa handleFont của FontDim bHwnd As Long ' Handle của Control 
Viết 1 hàm để tạo control

Mã: Chọn tất cả

Private Sub CreateButton()   bHwnd = CreateWindowExW(0, StrPtr("Button"), StrPtr(m_Caption), WS_CHILD Or WS_VISIBLE Or BS_PUSHBUTTON, 0, 0, ScaleWidth, ScaleHeight, UserControl.hwnd, 0, App.hInstance, 0)   'Tạo button   hFont = SendMessage(UserControl.hwnd, WM_GETFONT, 0&, ByVal 0&) ' Lấy hFont của Usercontrol    SendMessage bHwnd, WM_SETFONT, hFont, ByVal 1& ' set hFont vừa lấy của usercontrol qua controlEnd Sub 
sử lý hàm winProc

Mã: Chọn tất cả

Private Property Let ISubclass_MsgResponse(ByVal RHS As EMsgResponse)'End Property Private Property Get ISubclass_MsgResponse() As EMsgResponse   ISubclass_MsgResponse = emrPreprocessEnd Property Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long    Select Case iMsg       Case WM_COMMAND ' Nếu control click thì chuyển ngay đến event click          RaiseEvent Click    End SelectEnd Function'hàm Init này để bắt đầu subclass, thường là lúc UserControl_ReadPropertiesPrivate Sub Init(hWndA As Long)   AttachMessage Me, hWndA, WM_COMMAND ' subclass thông điệp WM_COMMANDEnd Sub'Hàm remove để gở bỏ subclassPrivate Sub Remove(hWndA As Long)   DetachMessage Me, hWndA, WM_COMMAND ' Bỏ subclass   ' Chú ý nếu ta subclass bao nhiêu thông điệp thì phải remove bấy nhiêu,nếu thiếu có thể gây lỗiEnd Sub

Mã: Chọn tất cả

Private Sub UserControl_Resize()   MoveWindow bHwnd, 0, 0, ScaleWidth, ScaleHeight, 0 ' Làm cho command khít với usercontrolEnd Sub Private Sub UserControl_Show()   CreateButton ' Tạo commandEnd Sub Private Sub UserControl_Terminate()   DestroyWindow bHwnd 'xóa control (Commandbutton)   DetachMessage Me, UserControl.hwnd, WM_COMMAND '(gở bỏ subclass)End Sub Private Sub UserControl_ReadProperties(PropBag As PropertyBag)    Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)    m_Caption = PropBag.ReadProperty("Caption", m_def_Caption)    If Ambient.UserMode Then 'nếu control đang trong lúc chạy (Run Time) thì tiếp tục       Init UserControl.hwnd ' Bắt đầu subclass    End IfEnd Sub 'trong Property Let Caption và Property Set Font Public Property Let Caption(ByVal New_Caption As String)    m_Caption = New_Caption    SendMessageW bHwnd, WM_SETTEXT, &H1, StrPtr(New_Caption) ' thay caption mới cho control    PropertyChanged "Caption"End Property Public Property Set Font(ByVal New_Font As Font)    Set UserControl.Font = New_Font    hFont = SendMessage(UserControl.hwnd, WM_GETFONT, 0&, ByVal 0&)    SendMessage bHwnd, WM_SETFONT, hFont, ByVal 1& 'gán font mới cho control    PropertyChanged "Font"End Property 
Và kết thúc, bạn đã có một control unicode theo chuẫn của VB6.
Nếu đọc không hiểu có thể tải source về nghiên cứu thêm vì trong bài viết mình chỉ viết vắn tắc.
Khi khác nếu có thời gian mình sẽ tiếp tục.
Tập tin đính kèm
CreateWindowsEx.rar
Source có kèm bộ subclass và cả file manifest để các bạn test
(18.05 KiB) Đã tải về 1301 lần
Hình đại diện của thành viên
DQHung
Guru
Guru
Bài viết: 576
Ngày tham gia: Thứ 2 12/02/2007 3:24 pm
Đến từ: Rach Gia - Kien Giang
Been thanked: 40 times
Tiếp xúc:

Re: Hướng dẩn cách tạo(viết) ActiveX control (ocx)

Gửi bài by DQHung »

Tên bài viết: Hướng dẫn cách tạo một control mảng
Tác giả: Dương Quốc Hưng
Cấp độ bài viết: Nâng cao
Tóm tắt: Tạo một Unicode Toolbar bằng các hàm vẽ và không Subclass/Hook
Trong bài này các bạn sẽ được biết đến các kỹ năng :
- Sử dụng "Property Page".
- Tạo/quản lý đối tượng bằng Class.
- Tạo một control (điều khiển) có dạng mảng và thủ thuật (Điều quan trọng mà mình muốn gửi đến trong bài này).

------------------------------------------------------------------------------------------------------------
Bắt đầu vào làm việc.
- Để tạo một Toolbar (giả) bạn phải tạo một khung xương cho nó để lưu các dử liệu liên quan.Có thể đến đây bạn chưa hiểu mấy nhưng lúc viết mình sẽ nói rõ hơn.
- Mình sẽ thiết kế khung xương cho Toolbar là như sau (Các bạn nên xem kỹ vì chữ Button cũng gần giống với Buttons) :
+ Buttons [Index or Key] (Parent, quản lý các Button)
- Add (Function, dùng để thêm 1 Button vào Buttons)
- Remove (Function, dùng để xóa 1 Button ra khỏi Buttons)
- Clear (Sub, Xóa tất cả các Button trong Buttons)
- Count (Property Get, trả về số lượng Button trong Buttons)
- Item (Property Get, trả về một đối tượng là Button thứ Index)
+Button (Child, chứa các thông tin của một Button)
- Public Caption As String (chứa nhãn của Button)
- Public ToolTipText As String (chứa ToolTipText)
- Public Key As String (Chứa key)
- Public Tag As String (chứa Tag)
-
+ Có thể thêm vài Property nếu muốn, tất nhiên sau khi thêm phải sửa lại Class Buttons
- Phần trên là lý thuyết, còn đây là code :
- Tạo một dự án Standard EXE. Add một Class vào và đặt tên là Buttons, copy đoạn code sau vào :

Mã: Chọn tất cả

Public Caption As StringPublic ToolTipText As StringPublic Key As StringPublic Tag As String Private mleft As Long 'Ta đặt chúng là private vì không muốn user thấy và chỉnh/sửa các thuộc tính này.Private mright As Long 'Các thuộc tính này để lưu lại vị trí left và right của Button, chủ yếu là dể quản lý button trong Toolbar (lúc Click và kiểm tra)'Hides propertyFriend Property Let Left(m_left As Long)   mleft = m_leftEnd Property Friend Property Get Left() As Long   Left = mleftEnd Property Friend Property Let Right(m_right As Long)   mright = m_rightEnd Property Friend Property Get Right() As Long   Right = mrightEnd Property
- Bây giờ ta đã có một đối tượng là Button. Ta tạo thêm Butttons để quản lý các Button này. Add 1 Class mới và đặt tên là Buttons và ... code đây :

Mã: Chọn tất cả

Private m_Count As Long  'biến này dùng để lưu lại số lượng button được addPrivate m_Button() As New Button 'Các Button Private Function GetItemIndex(ByVal sValue As Variant) As Long   'hàm này dùng để kiểm tra xem giá trị ta cho vào là Index hay là Key của Button.Và trả về Index của Button đó.'Ví dụ như ta có thể dùng : Buttons(2).Caption hoặc Buttons("open").Caption (nếu Index 2 có Key = "open").     Dim i As Long    If IsNumeric(sValue) = True Then        GetItemIndex = sValue    Else        For i = 1 To m_Count            If m_Button(i).Key = sValue Then                GetItemIndex = i                Exit Function            End If        Next i    End IfEnd Function  Public Function Add(Optional ByVal Caption As String = "Button", Optional Key As String = "Key", Optional ByVal ToolTipText As String = "", Optional ByVal Tag As String = "") As Button'Hàm này dùng để add một Button vào Buttons    On Error GoTo Loi    'ta cộng thêm 1 vào biến đếm    m_Count = m_Count + 1    'khởi tạo button thứ "m_Count"    ReDim Preserve m_Button(m_Count)        'gán các giá trị của Button mới tạo    With m_Button(m_Count)       .Caption = Caption       .Key = Key       .Tag = Tag       If m_Count > 1 Then          .Left = m_Button(m_Count - 1).Right       Else          .Left = 1       End If    End With    'Trả về Button    Set Add = m_Button(m_Count)    Exit FunctionLoi:    'Nếu bị lỗi sẽ trả về nothing    Set Add = NothingEnd Function Public Sub Clear()    'gán biến đếm = 0    m_Count = 0    'Xóa hết các Button    Erase m_Button()End Sub Public Property Get Count() As Long 'Trả về số lượng cho user    Count = m_CountEnd Property Public Sub Remove(ByVal Index As Variant)'Xóa button  Dim i As Long, idx As Long  idx = GetItemIndex(Index)  If (idx < 1) Or (idx > m_Count) Then  'Nếu index nhỏ hơn 1 và lớn hơn số lượng button thì thoát khỏi property      MsgBox "Not found Button !", vbInformation, "DQHung"      Exit Sub  Else     'ngược lại ta đè button cần xóa bởi button phía trước nó.     'Tức là nếu ta xóa button số 6 thì button 7 sẽ đè lên button 6 và button 8 sẽ đè lên button 7 ... cứ vậy cho đến hết.     For i = idx + 1 To m_Count        m_Button(i - 1).Caption = m_Button(i).Caption        m_Button(i - 1).Key = m_Button(i).Key        m_Button(i - 1).Left = m_Button(i).Left        m_Button(i - 1).Right = m_Button(i).Right        m_Button(i - 1).ToolTipText = m_Button(i).ToolTipText     Next i     m_Count = m_Count - 1     'sau khi xóa xong khởi tạo lại button,vì ta dùng mảng nên phải khởi tạo lại nếu không button xóa vẫn tồn tại.     ReDim Preserve m_Button(0 To m_Count)  End IfEnd Sub Public Property Get Item(ByVal Index As Variant) As Button    'Func này trả về 1 button cho user sử lý     On Error GoTo Loi     Set Item = m_Button(GetItemIndex(Index))     Exit PropertyLoi:     Set Item = NothingEnd Property
- Để tiện việc dùng các item thì mình nên tạo cách gọi Button tắc, giống như các bộ "Common control" của VB6 vậy.
- Ví dụ như thay vì ta phải nhập : Butttons.Item(2).Caption thì ta có thể gõ tắc Buttons(2).Caption. Đó gọi là gì,và làm thế nào để được như vậy ? Đó gọi là Default (mặc định). Tạo nó rất đơn giản, bạn hãy làm theo những bước sau :
- Mở Class "Buttons". Sau đó vào Menu "Tools"->"Procedure Attributes ...", sẽ hiện lên bảng sau :
p1.JPG
- Sau đó ta bấm vào nút "Advenced >>", phần dưới của cửa sổ hiện ra.
- ở Combobox "Name" ta chọn Property cần làm mặc định. Trong trường hợp này là "item" của Buttons.
- Sau khi chọn Name = Item xong, ta chọn "(Default)" ở mục "Procedure ID". Bấm OK. Bây giờ Property Item đã thành mặc định.

- Vậy là xong phần xương cho UniToolbar rồi đấy.
- Việc tiếp theo là tạo UniToolbar hoàn chỉnh.
- Add một Usercontrol mới và đặt tên là UniToolbar (UT).
- Đầu tiên ta đặt Alignable của UT = True, AutoRedraw = True, ScaleMode = Pixel. Đặt như vậy mới Draw được :) .

- Copy vài hàm API và các hàm tự tạo này vào (dùng để vẽ Toolbar) :

Mã: Chọn tất cả

Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPrivate Declare Function ApiFrameRect Lib "user32" Alias "FrameRect" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As LongPrivate Declare Function ApiDeleteObject Lib "gdi32" Alias "DeleteObject" (ByVal hObject As Long) As LongPrivate Declare Function ApiFillRect Lib "user32" Alias "FillRect" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As LongPrivate Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As LongPrivate Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As LongPrivate Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As LongPrivate Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As LongPrivate Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As LongPrivate Declare Function DrawTextW Lib "user32" (ByVal hdc As Long, ByVal lpStr As Long, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As LongPrivate Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As LongPrivate Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long Private Type RECT    X1 As Long    Y1 As Long    x2 As Long    y2 As LongEnd Type Private Type POINTAPI    X                   As Long    Y                   As LongEnd Type

Mã: Chọn tất cả

Private Function MDMouseOver(ByVal HandleWindow As Long) As Boolean'Hàm này dùng để kiểm tra xem mouse có nằm trong control không.'Hàm trả về True nếu co và ngược lại.Dim PT As POINTAPI     GetCursorPos PT    MDMouseOver = (WindowFromPoint(PT.X, PT.Y) = HandleWindow) End Function Private Sub DrawText(ByVal text As String, ByVal LeftX As Long, _            ByVal TopY As Long, _            ByVal RightX As Long, _            ByVal BottomY As Long)    'Hàm này để vẽ chữ lên Toolbar (có thể vẽ chữ Unicode)    Dim rc As RECT    With rc        .X1 = LeftX        .Y1 = TopY        .x2 = RightX        .y2 = BottomY    End With    DrawTextW hdc, StrPtr(text), -1, rc, &H4 & &H15End Sub'Chuyen doi mau sang dang LongPrivate Function TranslateColor(ByVal clr As OLE_COLOR, _                               Optional hPal As Long = 0) As Long    If OleTranslateColor(clr, hPal, TranslateColor) Then        TranslateColor = -1    End IfEnd Function'Dùng để vẽ viền (borther)Private Sub DrawFrameRect(ByVal LeftX As Long, _            ByVal TopY As Long, _            ByVal RightX As Long, _            ByVal BottomY As Long, _            Optional ByVal clrFill As Long = -1)    Dim rc          As RECT    Dim hbrFill As Long    On Error Resume Next     '--- create brush if neccessary    If clrFill <> -1 Then        hbrFill = CreateSolidBrush(TranslateColor(clrFill))    End If    With rc        .X1 = LeftX        .Y1 = TopY        .x2 = RightX        .y2 = BottomY    End With    Call ApiFrameRect(hdc, rc, hbrFill)    '--- cleanup the brush (if neccessary)    If clrFill <> -1 Then        Call ApiDeleteObject(hbrFill)    End IfEnd Sub'dùng để tô nền cho một vùng.Private Function DrawFillRECT(fColor As OLE_COLOR, cLeft As Long, cTop As Long, cRight As Long, cBottom As Long)   Dim NewBrt As Long, mRECT As RECT   With mRECT      .X1 = cLeft      .Y1 = cTop      .y2 = cBottom      .x2 = cRight   End With   NewBrt = CreateSolidBrush(TranslateColor(fColor))   ApiFillRect hdc, mRECT, NewBrt   ApiDeleteObject NewBrtEnd Function'Dùng để vẽ đường thẳngPrivate Sub DrawALine(X As Long, Y As Long, X1 As Long, Y1 As Long, oColor As OLE_COLOR, Optional iWidth As Long = 1)Dim PT As POINTAPIDim iPen As LongDim iPen1 As Long    iPen = CreatePen(PS_SOLID, iWidth, oColor)    iPen1 = SelectObject(hdc, iPen)        MoveToEx hdc, X, Y, PT    LineTo hdc, X1, Y1     SelectObject hdc, iPen1    ApiDeleteObject iPenEnd Sub
Xong phần API và các hàm vẽ. Bây giờ khởi tạo biến cho UT.

Mã: Chọn tất cả

Dim cx As Long, cy As Long, cW As Long, ch As Long   'các biến này dùng để lưu lại vị trí của Button, lác sau khi dùng sẽ nói rõ.Private m_Buttons As New Buttons    'Tạo mới một Buttons (Chỉ 1 là đủ)Private m_OldCount As Long             'Biến này dùng để lưu lại số lượng Button Event ButtonClick(Index As Long)'Bẩy CLick


Cần phải có một số hàm sau, copy vào :

Mã: Chọn tất cả

Public Sub Refresh()   'Cái này khỏi nói cũng phải biết  ;))     CalculateItem    DrawUniToolbarEnd Sub Private Sub CalculateItem()         'Ta tự tính toán vị trí, chiều dài của Button    Dim i As Long, stxt As String    For i = 1 To m_Buttons.Count         With m_Buttons(i)            stxt = .Caption            If i = 1 Then   'Nếu Button là thứ 1 thì vị trí trái của nó là 2                .Left = 2            Else 'Ngược lại Button lớn hơn 1 thì Left của nó là Right của Button phía trước (Chắc các bạn hiểu được).                .Left = m_Buttons(i - 1).Right            End If             If (stxt <> "-") Then   'Nếu ko phải là separator                .Right = .Left + TextWidth(stxt) + 20              ElseIf (stxt = "-") Then  'Nếu là Separator                 .Right = .Left + 4            End If        End With    Next iEnd Sub Private Function GetCurrentItem(X As Single, Y As Single) As Integer    'Hàm này dùngể kiểm tra xem mouse đang ở Item thứ bao nhiêu    Dim i As Integer    For i = 1 To m_Buttons.Count        If ((X > m_Buttons(i).Right) And (X < ScaleWidth - 11)) Or (X < m_Buttons(1).Left) Then           GetCurrentItem = m_Buttons.Count + 1        ElseIf X > m_Buttons(i).Left And X < m_Buttons(i).Right Then           If (X < m_Buttons(i).Right) Or (X < m_Buttons(1).Left) Then              If (Y > 2) And (Y < ScaleHeight - 2) Then                 GetCurrentItem = i                 Exit Function              Else                 GetCurrentItem = -1              End If           Else             GetCurrentItem = -1           End If        ElseIf (X > ScaleWidth - 11) And (X < ScaleWidth) Then           GetCurrentItem = -10           Exit Function        End If    Next iEnd Function
Tạo một vài Property :

Mã: Chọn tất cả

Public Property Get Font() As Font    Set Font = UserControl.FontEnd Property Public Property Set Font(ByVal New_Font As Font)    Set UserControl.Font = New_Font    PropertyChanged "Font"End Property 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!'MappingInfo=UserControl,UserControl,-1,ForeColorPublic Property Get ForeColor() As OLE_COLOR    ForeColor = UserControl.ForeColorEnd Property Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)    UserControl.ForeColor() = New_ForeColor    PropertyChanged "ForeColor"End Property Public Property Get Buttons() As Buttons   'Property này trả về 1 Buttons cho user.    Set Buttons = m_ButtonsEnd Property
Như vậy là xem như Toolbar đã có xương và có ... "thịt" :))
Bây giờ cho nó bộ não nửa là nó chạy.

Mã: Chọn tất cả

Private Sub DrawUniToolbar(Optional ByVal State As Integer = 0, Optional ByVal bIndex As Long = -1)' Đây là hàm quan trọng nhất, dùng để vẽ Toolbar'State là trạng thái mouse,Bindex là Index của Button đang có mouse    Dim i As Long        'Clear Usercontrol    Cls        'Ve mot duong line phia duoi Toolbar    DrawALine 0, ScaleHeight - 1, ScaleWidth, ScaleHeight - 1, TranslateColor(vbButtonShadow)    For i = 1 To m_Buttons.Count  'vẽ tất cả các button        With m_Buttons(i)   'do ta đã đặt Item là default nên có thể gọi Buttons như vậy.            If (.Caption <> "-") Then  'Nếu caption ko phải là separator                DrawText .Caption, .Left, 2, .Right, ScaleHeight - 2            Else 'ngược lại                DrawALine .Left, 4, .Left, ScaleHeight - 4, TranslateColor(vbButtonShadow)            End If        End With    Next i     If (bIndex > -1) And (bIndex < m_Buttons.Count + 1) Then   'Vẽ Button đang được mouse "ghé thăm"  :-S         With m_Buttons(bIndex)            If State = 2 Then Nếu là mouse move qua thì :                DrawFillRECT &HEDD0BF, .Left, 2, .Right, ScaleHeight - 2    'Tô nền                DrawFrameRect .Left, 2, .Right, ScaleHeight - 2, &HC56A31  'Tô viền                DrawText .Caption, .Left, 2, .Right, ScaleHeight - 2  'Vẽ chữ            ElseIf State = 1 Then  ' ngược lại nếu mouse click thì :                DrawFillRECT &HE2B498, .Left, 2, .Right, ScaleHeight - 2                  DrawFrameRect .Left, 2, .Right, ScaleHeight - 2, &HC56A31                DrawText .Caption, .Left, 2, .Right, ScaleHeight - 2            End If        End With    End IfEnd Sub Private Sub Timer1_Timer()  'Timer dùng để kiễm tra xem mouse đã rời Toolbar chưa, nếu rời rồi thì vẽ lại toolbar và tự động ngừng chạy.    If (MDMouseOver(UserControl.hWnd) = False) Then        Timer1.Enabled = False        Timer1.Interval = 0        DrawUniToolbar 0   End IfEnd Sub Private Sub UserControl_InitProperties()'Khi tạo mới một Usercontrol thì Sub này chạy đầu tiên và chỉ chạy 1 lần khi mới tạo.'Khi mới tạo lần đầu ta add một Button vào.     Buttons.Add    Set UserControl.Font = Ambient.FontEnd Sub Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)    If (Button = 1) Then       For i = 1 To m_Buttons.Count          If (X > m_Buttons(i).Left) And (Y > 2) And (X < m_Buttons(i).Right) And (Y < ScaleHeight - 2) And (m_Buttons(i).Caption <> "-") Then              'Đây là lúc sử dụng các biến lúc nãy đã khai báo.              'Lưu lại vị trí của Button đang mouse down               cx = m_Buttons(i).Left              cy = 2              cW = m_Buttons(i).Right              ch = ScaleHeight - 2              DrawUniToolbar 1, GetCurrentItem(X, Y)  'Vẽ nó khi mouse down          End If       Next i    End IfEnd Sub Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)    Timer1.Enabled = True    Timer1.Interval = 100    If (Button <> 1) Then        On Error Resume Next        If (m_Buttons(GetCurrentItem(X, Y)).Caption <> "-") Then        DrawUniToolbar 2, GetCurrentItem(X, Y)        End If    ElseIf Button = 1 Then        'Kiểm tra xem có phải Button đang down lúc nãy có được mouse quay lại ko, nếu có thì ... :        If Y > cy And Y < ch And X > cx And X < cW And (m_Buttons(i).Caption <> "-") Then            DrawUniToolbar 1, GetCurrentItem(X, Y)        Else            DrawUniToolbar 0, GetCurrentItem(X, Y)        End If    End IfEnd Sub Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)    Dim i As Long    i = GetCurrentItem(X, Y)    If Y > cy And Y < ch And X > cx And X < cW Then   'cũng như Sub trên là kiểm tra xem mouse có nằm trong Button down     'lúc nãy ko, nếu có thì Bẫy sự kiện click         If (m_Buttons(i).Caption <> "-") Then            RaiseEvent ButtonClick(GetCurrentItem(X, Y))        End If    End IfEnd Sub Private Sub UserControl_ReadProperties(PropBag As PropertyBag)    m_OldCount = PropBag.ReadProperty("Count" & i, "")  'đọc số Button được add vào    Khi chạy Buttons sẽ add lại tất cả các Button được lưu vào.    For i = 1 To m_OldCount          'Hàm BinaryToUnicode trong thư viện Supportunicode có đính kèm theo ở phía dưới           m_Buttons.Add BinaryToUnicode(PropBag.ReadProperty("ItemCaption" & i, 0)), _                        PropBag.ReadProperty("ItemKey" & i, ""), _                        BinaryToUnicode(PropBag.ReadProperty("ItemTooltiptext" & i, "")), _                        PropBag.ReadProperty("ItemTag" & i, "")    Next i    Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)    UserControl.ForeColor = PropBag.ReadProperty("ForeColor", vbButtonText)    CalculateItemEnd Sub Private Sub UserControl_Resize()  'Tự vẽ lại Toolbar khi Usercontrol thay đỗi kích thước    DrawUniToolbarEnd Sub Private Sub UserControl_Show()      'Tính toán và vẽ Toolbar lúc mới show hàng  ;;)     CalculateItem    DrawUniToolbarEnd Sub Private Sub UserControl_WriteProperties(PropBag As PropertyBag)    PropBag.WriteProperty "Count", m_Buttons.Count, 0       'Ghi lại số lượng Button, để lúc ReadProperties ta đọc nó    For i = 1 To m_Buttons.Count        'Hàm UnicodeToBinary cũng nằm trong thư viện SupportUnicode.        With m_Buttons(i)            PropBag.WriteProperty "ItemCaption" & i, UnicodeToBinary(.Caption), ""            PropBag.WriteProperty "ItemTooltiptext" & i, UnicodeToBinary(.ToolTipText), ""            PropBag.WriteProperty "ItemKey" & i, .Key, ""            PropBag.WriteProperty "ItemTag" & i, .Tag, ""        End With    Next i    Call PropBag.WriteProperty("Font", UserControl.Font, Ambient.Font)    Call PropBag.WriteProperty("ForeColor", UserControl.ForeColor, &HC56A3112)End Sub 
Vậy là xong Toolbar rồi đấy. Nhưng bây giờ chưa add các Button vào lúc Design time được.
Muốn add button lúc design time thì chỉ có dùng Property Page thôi. Và cách tạo nó thì cực kỳ đơn giản.

Add vào một Property page và thiết kế như trong hình, copy code sau vào :
p2.JPG
p2.JPG (6.37 KiB) Đã xem 12724 lần

Mã: Chọn tất cả

Private Sub cmdAdd_Click()   'Code cho nút "Add"     If Changed = True Then   'Nếu Page có thay đỗi nội dung thì cập nhật ngay        PropertyPage_ApplyChanges       End If       SelectedControls(0).Buttons.Add "Button" & vValue.Value + 1    Changed = True    DoEvents    'Sau khi add button thì gán trị lớn nhất cho vValue (VSCrollbar) và txtIndex (Textbox)    txtIndex.text = SelectedControls(0).Buttons.Count    vValue.Max = SelectedControls(0).Buttons.Count    vValue.Value = vValue.MaxEnd Sub Private Sub cmdRemove_Click()  'Code cho nút "Remove"    If vValue.Max > 1 Then        SelectedControls(0).Buttons.Remove CLng(txtIndex.text)        vValue.Max = SelectedControls(0).Buttons.Count        vValue.Value = vValue.Max        txtIndex.text = vValue.Max    End IfEnd Sub Private Sub PropertyPage_ApplyChanges()    'Code cho nút "Apply"'Gán các giá trị trong Page vào Button    SelectedControls(0).Buttons(vValue.Value).Caption = txtCaption.text    SelectedControls(0).Buttons(vValue.Value).Key = txtKey.text    SelectedControls(0).Buttons(vValue.Value).ToolTipText = txtToolTip.text    SelectedControls(0).Buttons(vValue.Value).Tag = txtTag.text        DoEvents    SelectedControls(0).RefreshEnd Sub Private Sub PropertyPage_SelectionChanged()'Gán giá trị của Button vào Page    vValue.Max = SelectedControls(0).Buttons.Count    txtIndex.text = vValue.Value    txtCaption.text = SelectedControls(0).Buttons(vValue.Value).Caption    txtKey.text = SelectedControls(0).Buttons(vValue.Value).Key    txtToolTip.text = SelectedControls(0).Buttons(vValue.Value).ToolTipText    txtTag.text = SelectedControls(0).Buttons(vValue.Value).TagEnd Sub Private Sub txtCaption_Change()    Changed = TrueEnd Sub Private Sub txtKey_Change()    Changed = TrueEnd Sub Private Sub txtTag_Change()    Changed = TrueEnd Sub Private Sub txtToolTip_Change()    Changed = TrueEnd Sub Private Sub vValue_Change()  'Khi VScrollbar thay đỗi giá trị thì hiển thị dử liệu của Button theo giá trị đó    txtIndex = vValue.Value    txtCaption.text = SelectedControls(0).Buttons(txtIndex.text).Caption    txtKey.text = SelectedControls(0).Buttons(txtIndex.text).Key    txtToolTip.text = (SelectedControls(0).Buttons(txtIndex.text).ToolTipText)    txtTag.text = SelectedControls(0).Buttons(txtIndex.text).Tag        DoEventsEnd Sub 
Kết thúc. Bạn đã có một Unicode Toolbar với giao diện Office XP.
Theo mình thì bạn chịu khó đọc và thực hành thì sẽ hiểu ngay.
Một bài tập cho các bạn : Tạo thêm Icon cho Toolbar, mách các bạn 2 cách :
+ Icon dùng bằng ImageList - Tạo thêm 1 biến (dạng Long) trong Class Button để lưu ImageIndex của ImageList và vẽ lên Toolbar
+ Icon lưu trực tiếp trong Button - Tạo thêm 1 biến (dạng StdPicture) trong Class Button để lưu Picture lại.

Các bạn có thể download mã nguồn của UniToolbar trên ở đây :
UniToolbar.rar
Source code UnicodeToolbar
(14.61 KiB) Đã tải về 1001 lần
Khi khác nếu có thời gian mình sẽ tiếp tục.
dtv.dung
Thành viên chính thức
Thành viên chính thức
Bài viết: 24
Ngày tham gia: Chủ nhật 16/05/2010 6:57 am
Đến từ: Đà Nẵng
Tiếp xúc:

Re: Hướng dẩn cách tạo(viết) ActiveX control (ocx)

Gửi bài by dtv.dung »

Cho mình hỏi 1 phần của cách 1 bạn đã hướng dẫn
download/file.php?id=151&mode=view
Đây là bước quan trọng, bạn phải dò tìm những property , method, event của label và chuyễn qua hết vào bên phải (có thể chọn những thứ khác không phải của label), xong bấm next
thì những property, method, event của label là gì và bạn có thể cho mình xin những property, method, even của những thứ khác được chứ ví dụ như comanbuton...
Từ quá khứ đi đến tương lai đừng nhìn lại
Hình đại diện của thành viên
DQHung
Guru
Guru
Bài viết: 576
Ngày tham gia: Thứ 2 12/02/2007 3:24 pm
Đến từ: Rach Gia - Kien Giang
Been thanked: 40 times
Tiếp xúc:

Re: Hướng dẩn cách tạo(viết) ActiveX control (ocx)

Gửi bài by DQHung »

dtv.dung đã viết:Cho mình hỏi 1 phần của cách 1 bạn đã hướng dẫn
download/file.php?id=151&mode=view
Đây là bước quan trọng, bạn phải dò tìm những property , method, event của label và chuyễn qua hết vào bên phải (có thể chọn những thứ khác không phải của label), xong bấm next
thì những property, method, event của label là gì và bạn có thể cho mình xin những property, method, even của những thứ khác được chứ ví dụ như comanbuton...
Bạn muốn viết control thì bạn phải biết control đó "cần phải có thuộc tính gì" chứ nhỉ ?
Nếu muốn biết các thuộc tính của Command thì cứ mở "Object Browser" lên mà xem.
Đăng trả lời

Quay về