The Agent Control DLL is developed on Microsoft Visual
Basic 6.0.
It is an ActiveX DLL project that consists of form named wndMsgBox, modules modAgent and modMsgBox, class module clsAgent and user-control ambCmdButton.
Form wndMsgBox
consists of form with following objects: image (named iSign), two labels (named lTitle and lPrompt),
image list (named ilSigns),
agent control (name MSAgentCtrl)
and five user-controls command buttons (named Button(ID)). Form wndMsgBox is
a agent message window (like standard Windows message box). Notice to set
forms BorderStyle=0, AutoRedraw=True and DrawWidth=2. Also set ScaleMode=3. Here is the source-code of
the form:
Option
Explicit
Private ambMove As
Boolean
Private ambPrevX As Integer
Private ambPrevY As Integer
Private
Sub Button_Click(Index As Integer)
On
Error Resume Next
Select Case LCase$(Button(Index).Caption)
Case "ok"
ambResult = vbOK
Case "cancel"
ambResult = vbCancel
Case "abort"
ambResult = vbAbort
Case "retry"
ambResult = vbRetry
Case "ignore"
ambResult = vbIgnore
Case "yes"
ambResult = vbYes
Case "no"
ambResult = vbNo
End Select
Me.Hide
End Sub
Private
Sub Form_Load()
On
Error Resume Next
TopMost Me.hwnd, True
ambMove = False
End Sub
Private
Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As
Single)
If
Button = 1 And y < 50 Then
Move_MouseDown x, y
End If
End Sub
Private
Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As
Single)
Move_MouseMove
x, y
End Sub
Private
Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Move_MouseUp
End Sub
Private
Sub Move_MouseDown(x As Single, y As Single)
On
Error Resume Next
ambMove = True
ambPrevX = x
ambPrevY = y
End Sub
Private
Sub Move_MouseMove(x As Single, y As Single)
On
Error Resume Next
If
ambMove = True Then
Me.Left = (Me.Left + (x - ambPrevX) *
Screen.TwipsPerPixelX)
Me.Top = (Me.Top + (y - ambPrevY) *
Screen.TwipsPerPixelY)
End If
End Sub
Private
Sub Move_MouseUp()
On
Error Resume Next
ambMove = False
End Sub
Private
Sub lPrompt_Click()
End Sub
Private
Sub MSAgentCtrl_Command(ByVal UserInput As Object)
On
Error Resume Next
If UserInput.Name =
"AdvCharOptions" Then
MSAgentCtrl.PropertySheet.Visible =
True
End If
End Sub
Private
Sub MSAgentCtrl_DragComplete(ByVal CharacterID As String, ByVal Button As
Integer, ByVal Shift As Integer, ByVal x As Integer, ByVal y As Integer)
On
Error Resume Next
Agent.pX = Agent.cChar.Left
Agent.pY = Agent.cChar.Top
End Sub
Module modAgent
contents public variables for the class module clsAgent. This was necessary because Visual Basic doesnt
allow to put public variables in class module. Here is the source-code of the
module:
Option Explicit
Type dAgent
' Character:
cChar As IAgentCtlCharacterEx
cLanguage As Long
cLoaded As Boolean
cName As String
cFileName As String
' Position:
pX As Integer
pY As Integer
End Type
Public Agent As dAgent
' This variable contents
message box result:
' 0 result is not
received yet;
' 1 button OK clicked;
' 2 button CANCEL
clicked;
' 3 button ABORT clicked;
' 4 button RETRY clicked;
' 5 button IGNORE
clicked;
' 6 button YES clicked;
' 7 button NO clicked.
Public ambResult As Integer
' Language constants:
Const ENGLISH = &H409
Module modMsgBox
contents API, variable definitions and functions used to create agent message
box. Here is the source-code of the module:
Option Explicit
Public Type dRECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public RECT As dRECT
' This function is used with
function "CompactText":
Public Declare Function DrawText Lib "user32" Alias
"DrawTextA" (ByVal hDc As Long, _
ByVal lpStr As String, ByVal nCount As Long, lpRect As dRECT, ByVal
wFormat As Long) As Long
' These fuctions are used
when creating round corners of the form:
Public Declare Function SetWindowRgn Lib "user32" (ByVal
hwnd As Long, ByVal hRgn As Long, _
ByVal
bRedraw As Long) As Long
Public Declare Function RoundRect Lib "gdi32" (ByVal hDc
As Long, ByVal nLeftRect As Long, _
ByVal
nTopRect As Long, ByVal nRightRect As Long, ByVal nBottomRect As Long,_
ByVal
nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function CreateRoundRectRgn Lib "gdi32"
(ByVal nLeftRect As Long,_
ByVal nTopRect As Long, ByVal nRightRect As
Long, ByVal nBottomRect As Long, _
ByVal nWidth As Long, ByVal nHeight As
Long) As Long
' This function is used with
statement "Top-Most":
Public Declare Function SetWindowPos& Lib "user32"
(ByVal hwnd As Long, _
ByVal hWndInsertAfter As Long, ByVal x As
Long, ByVal y As Long, ByVal cx As Long,_
ByVal cy As Long, ByVal wFlags As Long)
Public Const HWND_TOPMOST =
-1
Public Const HWND_NOTOPMOST =
-2
Public Function CompactText(ByVal sText As String, ByVal lMaxPixels As
Long, ByVal hDc As Long) As String
RECT.Right = lMaxPixels
DrawText hDc, sText, -1, RECT,
&H8000& Or &H10000
CompactText = sText
End Function
Public Sub TopMost(FrmHwnd As Long, Value As Boolean)
On Error Resume Next
If Value = True Then
' Sets form to stay in the
top-most position:
SetWindowPos FrmHwnd,
HWND_TOPMOST, 0, 0, 0, 0, 3
Else
' Sets form to stay in no-top-most
position:
SetWindowPos FrmHwnd,
HWND_NOTOPMOST, 0, 0, 0, 0, 3
End If
End Sub
Class module clsAgent
contents all DLL function definitions. Here is the source-code of the class
module:
Public Function Create(FILE_NAME As String, LANGUAGE As Long, POSITION_X As Integer, POSITION_Y As Integer)
On Error Resume Next
' Load agent message box:
Load wndMsgBox
Dim msaObj As Agent
Set msaObj = wndMsgBox.MSAgentCtrl
With Agent
' Unload previous character
(if it is loaded):
Set .cChar = Nothing
msaObj.Characters.Unload
"CharacterID"
' Load the character:
On Error GoTo ErrHandler
.cFileName = FILE_NAME
msaObj.Characters.Load
"CharacterID", .cFileName
' Load successful, continue
with initializing:
Set .cChar =
msaObj.Characters("CharacterID")
.cName = .cChar.Name
Select Case LANGUAGE
Case ENGLISH
.cLanguage = ENGLISH
Case Else
.cLanguage = ENGLISH
End Select
.cLoaded = True
' Set character position:
.cChar.Left = POSITION_X
.cChar.Top = POSITION_Y
' Show the character:
.cChar.Show
' Update the X,Y position
fields with the character's current position:
.pX = .cChar.Left
.pY = .cChar.Top
' Update the state of the
balloon style options:
' Call SetBalloonStyleOptions
' Initialize the pop-up menu
commands:
.cChar.Commands.RemoveAll
.cChar.Commands.Add
"AdvCharOptions", "&Options "
' Update the state of the
controls to match the character's settings:
' Call EnableControls
End With
Exit Function
ErrHandler:
MsgBox "There was an
error opening the file " & Chr$(34) & Agent.cFileName &
Chr$(34) & "!", vbExclamation, "Agent Control DLL:
Error"
Destroy
End Function
Public Function Destroy()
On Error Resume Next
With Agent
' Unload agent message box
and free resources associated with it:
Unload wndMsgBox
Set wndMsgBox = Nothing
' Clear MS Agent object:
Set .cChar = Nothing
msaObj.Characters.Unload
"CharacterID"
' Clear all associated
variables:
.cFileName = ""
.cLoaded = False
.cName = ""
.pX = 0
.pY = 0
End With
End Function
Public Function Animate(ANIMATION_NAME As String)
On Error Resume Next
With Agent
.cChar.Stop
.cChar.Play ANIMATION_NAME
End With
End Function
Public Function Listen()
On Error Resume Next
With Agent
.cChar.Listen True
End With
End Function
Public Function Move(DEST_X As Integer, DEST_Y As Integer, MOVE_SPEED As
Integer)
On Error Resume Next
With Agent
.cChar.MoveTo DEST_X, DEST_Y,
MOVE_SPEED
.pX = .cChar.Left
.pY = .cChar.Top
End With
End Function
Public Function Speak(TEXT_TO_SPEAK As String)
On Error Resume Next
' Check if there is text to speak:
If Len(TEXT_TO_SPEAK) = 0 Then Exit Function
With Agent
.cChar.Speak TEXT_TO_SPEAK
End With
End Function
Public Function Think(TEXT_TO_THINK As String)
On Error Resume Next
' Check if there is text to think:
If Len(TEXT_TO_THINK) = 0 Then Exit Function
With Agent
.cChar.Think TEXT_TO_THINK
End With
End Function
Public Function Message(PROMPT As String, ATTRIBUTES As VbMsgBoxStyle,
TITLE As String) As Integer
On Error Resume Next
If Agent.cLoaded = False Then
Message = -1
Exit Function
End If
With wndMsgBox
' Get two properties (Signs
and Buttons) out of one property (ATTRIBUTES):
Dim ambButtons As Integer
Dim ambSign As Integer
ambButtons = -1
ambSign = -1
If ATTRIBUTES = 0 Then
ambSign = 4 ' (INFORMATION)
ambButtons = 0 ' (OK)
End If
If ATTRIBUTES >= 16 And
ATTRIBUTES < 22 Then
ambSign = 1 ' (CRITICAL)
ambButtons = ATTRIBUTES -
16 ' (0-5 ?)
End If
If ATTRIBUTES >= 32 And
ATTRIBUTES < 38 Then
ambSign = 2 ' (QUESTION)
ambButtons = ATTRIBUTES -
32 ' (0-5 ?)
End If
If ATTRIBUTES >= 48 And
ATTRIBUTES < 54 Then
ambSign = 3 ' (EXCLAMATION)
ambButtons = ATTRIBUTES -
48 ' (0-5 ?)
End If
If ATTRIBUTES >= 64 And
ATTRIBUTES < 70 Then
ambSign = 4 ' (INFORMATION)
ambButtons = ATTRIBUTES -
64 ' (0-5 ?)
End If
If ambSign = -1 Or ambButtons
= -1 Then
ambSign = 4 ' (INFORMATION)
ambButtons = 0 ' (OK)
End If
.ScaleMode = vbPixels
' Setup form's position on
screen:
If Agent.cChar.Left < 300
Then Agent.cChar.Left = 300
.Left = (Agent.cChar.Left -
300) * Screen.TwipsPerPixelX
.Top = (Agent.cChar.Top) *
Screen.TwipsPerPixelY
' Print property PROMPT on
the "wndMsgBox" form:
.lPrompt.Caption = PROMPT
' Print compact property
TITLE on the "wndMsgBox" form:
.lTitle.Caption = CompactText(TITLE, .lTitle.Width, .hDc)
' Show image indicated with
property ATTRIBUTES:
.iSign.Picture =
.ilSigns.ListImages.Item(ambSign).Picture
' Hide all buttons to prevent
situation when visible is too much buttons:
Dim Index As Integer
For Index = 0 To 4
.Button(Index).Visible =
False
Next Index
' Show buttons indicated with
property ATTRIBUTES:
Select Case ambButtons
Case 0
.Button(2).Caption =
"OK"
.Button(2).Visible = True
Case 1
.Button(1).Caption =
"OK"
.Button(3).Caption =
"Cancel"
.Button(1).Visible =
True
.Button(3).Visible =
True
Case 2
.Button(0).Caption =
"Abort"
.Button(2).Caption =
"Retry"
.Button(4).Caption =
"Ignore"
.Button(0).Visible =
True
.Button(2).Visible =
True
.Button(4).Visible =
True
Case 3
.Button(0).Caption =
"Yes"
.Button(2).Caption =
"No"
.Button(4).Caption =
"Cancel"
.Button(0).Visible =
True
.Button(2).Visible =
True
.Button(4).Visible =
True
Case 4
.Button(1).Caption =
"Yes"
.Button(3).Caption = "No"
.Button(1).Visible =
True
.Button(3).Visible =
True
Case 5
.Button(1).Caption =
"Retry"
.Button(3).Caption =
"Cancel"
.Button(1).Visible =
True
.Button(3).Visible =
True
End Select
' Round "wndMsgBox"
form corners and draw border:
Dim hRgn As Long
hRgn = CreateRoundRectRgn(0,
0, .ScaleWidth, .ScaleHeight, 32, 32)
SetWindowRgn .hwnd, hRgn,
True
RoundRect .hDc, 0, 0,
.ScaleWidth, .ScaleHeight, 34, 34
' Wait until all events are
completed:
DoEvents
Animate "suggest"
' Show message
("wndMsgBox"):
.Show
End With
ambResult = 0
Do
DoEvents
If ambResult <> 0 Then Exit
Do
Loop
Message = ambResult
End Function
User-control ambCmdButton
consists of following objects: picture clip (named pcButtons), label (named lblCaption) and timer (named tTimer). Here is the source-code of the form:
Option Explicit
Private Declare Function GetCursorPos Lib "user32"
(lpPoint As dPOINTAPI) As Long
Private Declare Function
ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As
dPOINTAPI) As Long
Private LockDrawing As Boolean
Private UserCtrlFont As Font
Private Type dPOINTAPI
x As Long
y As Long
End Type
Private POINTAPI As dPOINTAPI
Event Click()
Event KeyDown(KeyCode As
Integer, Shift As Integer)
Event KeyPress(KeyAscii As
Integer)
Event KeyUp(KeyCode As
Integer, Shift As Integer)
Event MouseOut()
Event MouseDown(Button As
Integer, Shift As Integer, x As Single, y As Single)
Event MouseMove(Button As Integer,
Shift As Integer, x As Single, y As Single)
Event MouseUp(Button As
Integer, Shift As Integer, x As Single, y As Single)
Private Sub lblCaption_Change()
UserControl_Resize
End Sub
Private Sub lblCaption_Click()
UserControl_Click
End Sub
Private Sub lblCaption_MouseDown(Button As Integer, Shift As Integer, x
As Single, y As Single)
UserControl_MouseDown Button,
Shift, x, y
End Sub
Private Sub lblCaption_MouseMove(Button As Integer, Shift As Integer, x
As Single, y As Single)
UserControl_MouseMove Button,
Shift, x, y
End Sub
Private Sub lblCaption_MouseUp(Button As Integer, Shift As Integer, x As
Single, y As Single)
UserControl_MouseUp Button,
Shift, x, y
End Sub
Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)
RaiseEvent Click
End Sub
Private Sub UserControl_Click()
RaiseEvent Click
End Sub
Private Sub UserControl_Initialize()
DrawButton 0
End Sub
Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
RaiseEvent KeyDown(KeyCode,
Shift)
End Sub
Private Sub UserControl_KeyPress(KeyAscii As Integer)
RaiseEvent KeyPress(KeyAscii)
End Sub
Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
RaiseEvent KeyUp(KeyCode,
Shift)
End Sub
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x
As Single, y As Single)
RaiseEvent MouseDown(Button,
Shift, x, y)
DrawButton 2
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x
As Single, y As Single)
RaiseEvent MouseMove(Button,
Shift, x, y)
If LockDrawing = True Then
Exit Sub
tTimer.Enabled = True
If x >= 0 And y >= 0
And x <= UserControl.ScaleWidth And y <= UserControl.ScaleHeight Then
DrawButton 1
LockDrawing = True
End If
End Sub
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x
As Single, y As Single)
RaiseEvent MouseUp(Button,
Shift, x, y)
DrawButton 1
End Sub
Private Sub UserControl_Resize()
DrawButton 0
lblCaption.Top = (UserControl.ScaleHeight
- lblCaption.Height) / 2
lblCaption.Left =
(UserControl.ScaleWidth - lblCaption.Width) / 2
End Sub
Private Sub UserControl_Show()
LockDrawing = False
DrawButton 0
End Sub
Private Sub UserControl_Terminate()
LockDrawing = False
DrawButton 0
End Sub
Private Sub tTimer_Timer()
GetCursorPos POINTAPI
ScreenToClient UserControl.hwnd, POINTAPI
If POINTAPI.x < UserControl.ScaleLeft Or _
POINTAPI.y < UserControl.ScaleTop
Or _
POINTAPI.x >
(UserControl.ScaleLeft + UserControl.ScaleWidth) Or _
POINTAPI.y >
(UserControl.ScaleTop + UserControl.ScaleHeight) Then
tTimer.Enabled = False
RaiseEvent MouseOut
DrawButton 0
LockDrawing = False
End If
End Sub
Public Sub DrawButton(Button As Integer)
With UserControl
.ScaleMode = vbPixels
Dim BRX, BRY, BW, BH As
Integer
BRX = .ScaleWidth - 3
BRY = .ScaleHeight - 3
BW = .ScaleWidth - 6
BH = .ScaleHeight - 6
UserControl.PaintPicture
pcButtons.GraphicCell(Button), 0, 0, 3, 3, 0, 0, 3, 3
UserControl.PaintPicture
pcButtons.GraphicCell(Button), BRX, 0, 3, 3, 15, 0, 3, 3
UserControl.PaintPicture
pcButtons.GraphicCell(Button), BRX, BRY, 3, 3, 15, 18, 3, 3
UserControl.PaintPicture
pcButtons.GraphicCell(Button), 0, BRY, 3, 3, 0, 18, 3, 3
UserControl.PaintPicture
pcButtons.GraphicCell(Button), 3, 0, BW, 3, 3, 0, 12, 3
UserControl.PaintPicture pcButtons.GraphicCell(Button),
BRX, 3, 3, BH, 15, 3, 3, 15
UserControl.PaintPicture
pcButtons.GraphicCell(Button), 0, 3, 3, BH, 0, 3, 3, 15
UserControl.PaintPicture
pcButtons.GraphicCell(Button), 3, BRY, BW, 3, 3, 18, 12, 3
UserControl.PaintPicture
pcButtons.GraphicCell(Button), 3, 3, BW, BH, 3, 3, 12, 15
End With
End Sub
Public Property Get Caption() As String
Caption = lblCaption.Caption
End Property
Public Property Let Caption(ByVal NewCaption As String)
lblCaption.Caption = NewCaption
PropertyChanged
"Caption"
End Property
Public Property Set Font(ByVal vNewFont As Font)
Set UserCtrlFont = vNewFont
Set UserControl.Font =
vNewFont
Set lblCaption.Font =
UserCtrlFont
Call UserControl_Resize
PropertyChanged
"Font"
End Property
Public Property Get Font() As Font
Set Font = UserCtrlFont
End Property
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
Caption =
PropBag.ReadProperty("Caption", Ambient.DisplayName)
Set Font = PropBag.ReadProperty("Font",
UserControl.Ambient.Font)
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call
PropBag.WriteProperty("Caption", lblCaption.Caption,
Ambient.DisplayName)
Call
PropBag.WriteProperty("Font", UserCtrlFont, UserControl.Ambient.Font)
End Sub
Private Sub UserControl_InitProperties()
Caption = Ambient.DisplayName
Set Font =
UserControl.Ambient.Font
End Sub