RESPUESTA A LA PREGUNTA 27414 - VISUAL BASIC mira rapido, debes agregar dos formularios a tu proyecto, uno debe llamarse frmassist y el otro debe llamarse MsgForm, ahora el codigo del formulario llamado frmassist es el siguiente: Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private frm As Object Public Function MsgResults(Results As Integer) frm.Msg Results End Function Public Sub ReturnTo(f As Form) Set frm = f End Sub Private Sub Form_Load() Me.Top = GetSetting("rgOfficeAssistant", "FP", "Top", (Screen.Height - Me.Height) / 2) Me.Left = GetSetting("rgOfficeAssistant", "FP", "Left", (Screen.Width - Me.Width) / 2) End Sub Private Sub Form_Unload(Cancel As Integer) Call SaveSetting("rgOfficeAssistant", "FP", "Top", Me.Top) Call SaveSetting("rgOfficeAssistant", "FP", "Left", Me.Left) MsgForm.Hide MsgForm.Hide Unload MsgForm If ZoomedFromLast = -1 Then rg.frmZoom Me, TopLeft, ZoomFormClosed Else rg.frmZoom Me, ZoomedFromLast, ZoomFormClosed End If End Sub Private Sub imgPic_Click() End Sub Private Sub Timer1_Timer() Dim xCoutner As Integer On Error Resume Next For xcounter = 0 To 1 imgPic.Picture = Image1(xcounter).Picture imgPic.Refresh Call Sleep(100) Next End Sub el codigo del segundo formulario llamado MsgForm es el siguiente: Option Explicit Private BkColor As Variant Private FrColor As Variant Private CurIcon As Long Private ButnTxt() As String Private LastBtnUp As Integer Public Sub A_SetBackColor(sBackColor As OLE_COLOR) BkColor = sBackColor End Sub Public Sub A_SendResultsTo(f As Form) frmAssist.ReturnTo f End Sub Public Sub A_Initialize() Dim xCount As Integer For xCount = 0 To picOptions.Count - 1 picOptions(xCount).BackColor = BkColor picOptions(xCount).ForeColor = msgText.ForeColor picOptions(xCount).FontName = msgText.FontName picOptions(xCount).ForeColor = msgText.ForeColor rg.Draw3dUp picOptions(xCount), ButnTxt(xCount) Next DoEvents Me.Refresh End Sub Private Sub Form_Deactivate() Me.Hide End Sub Private Sub Form_Load() Me.BackColor = BkColor Me.Refresh picIcon.BackColor = BkColor picIcon.Refresh picIcon.BorderStyle = 0 Dim lRet As Long Dim dl As Long Dim MeWidth As Long Dim MeHeight As Long MeWidth = Me.Width / Screen.TwipsPerPixelX MeHeight = Me.Height / Screen.TwipsPerPixelY 'Create Form with Rounded Corners lRet = CreateRoundRectRgn(0, 0, MeWidth, MeHeight, 20, 20) dl = SetWindowRgn(Me.hWnd, lRet, True) End Sub Private Sub Form_LostFocus() Me.Hide End Sub Private Sub Form_Unload(Cancel As Integer) Unload MsgForm End Sub Private Sub msgText_Click() End Sub Private Sub picOptions_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) rg.Draw3dDown picOptions(Index), ButnTxt(Index) End Sub Private Sub picOptions_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) rg.Draw3dUp picOptions(Index), ButnTxt(Index) Me.Hide Me.Hide DoEvents frmAssist.MsgResults Index Unload frmAssist End Sub Public Property Let A_MsgText(ByVal vNewValue As String) msgText = vNewValue End Property Public Property Let A_SystemIcon(vNewValue As SystemIcons) Call rg.picGetSysMsgBoxIcon(picIcon, vNewValue) End Property Public Sub A_AddButton(BtnIndex As Integer, BtnText As String) If BtnIndex = 0 Then ReDim ButnTxt(0) ButnTxt(0) = BtnText Else ReDim Preserve ButnTxt(UBound(ButnTxt) + 1) ButnTxt(UBound(ButnTxt)) = BtnText Load picOptions(BtnIndex) picOptions(BtnIndex).Left = picOptions(BtnIndex - 1).Left + picOptions(BtnIndex - 1).Width + 60 picOptions(BtnIndex).Top = picOptions(BtnIndex - 1).Top picOptions(BtnIndex).Visible = True End If End Sub nota a este segundo formulario debes agregarle un picture box llamado: pcicon y otro llamado picoptions(Este picture box debe ser una matriz de controles osea que debe se picoptions(0)), tambien debes agregar un label que tenga como caption: "What can i do for you?", y ya para terminar agrerga un modulo .Bas que lleva este codigo: 'jose antonio huerta lopez 'ITP instituto tecnologico de puebla Public Enum ZoomDirection ZoomFormOpen = 0 ZoomFormClosed = 1 End Enum Public ZoomedFromLast As ZoomFrom Public Enum ZoomFrom TopLeft = 0 TopCenter = 1 TopRight = 2 MidLeft = 3 MidCenter = 4 MidRight = 5 BtmLeft = 6 BtmCenter = 7 BtmRight = 8 ScreenCenter = 9 ToTaskBarTray = 10 FromTaskBarTray = 11 FromMousePointer = 12 ScreenActiveFrm = 13 End Enum Public Enum ZoomEffects FromCenter = 0 FromLeft = 1 FromRight = 2 FromTopRight = 3 FromBotRight = 4 FromBotLeft = 5 FromTopLeft = 6 Explode = 7 FromTop = 8 FromBottom = 9 End Enum Private Const SWP_NOMOVE = 2 Private Const SWP_NOSIZE = 1 Private Const HWND_TOPMOST = -1 Private Const HWND_NOTOPMOST = -2 'Sound Functions Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long Private Const SND_ASYNC = &H1 ' play asynchronously Private Const SND_NODEFAULT = &H2 ' silence not default, if sound not found Private Const SND_LOOP = &H8 ' loop the sound until next sndPlaySound Private Const SND_RESOURCE = &H40004 ' name is a resource name or atom 'Window Private Declare Function GetClassName Lib "User32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long Private Declare Function GetWindow Lib "User32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long Private Const GW_CHILD = 5 Private Const GW_HWNDNEXT = 2 'Cursor Private Type POINTAPI Y As Long X As Long End Type Private Declare Function GetCursorPos Lib "User32" (lpPoint As POINTAPI) As Long Private Const rgRegSounds = "AppEvents\Schemes\Apps\.Default\" 'Zoom Window Private Const IDANI_OPEN = &H1 Private Const IDANI_CLOSE = &H2 Private Const IDANI_CAPTION = &H3 Private Declare Function GetDesktopWindow Lib "User32" () As Long Private Declare Function GetWindowRect Lib "User32" (ByVal hWnd As Long, lpRect As RECT) As Long Private Declare Function DrawAnimatedRects Lib "User32" (ByVal hWnd As Long, ByVal idAni As Long, lprcFrom As RECT, lprcTo As RECT) As Long Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type 'Registry API Declarations Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As Long, phkResult As Long, lpdwDisposition As Long) As Long Private Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" (ByVal hKey As Long, ByVal lpClass As String, lpcbClass As Long, lpReserved As Long, lpcSubKeys As Long, lpcbMaxSubKeyLen As Long, lpcbMaxClassLen As Long, lpcValues As Long, lpcbMaxValueNameLen As Long, lpcbMaxValueLen As Long, lpcbSecurityDescriptor As Long, lpftLastWriteTime As FILETIME) As Long Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long 'Registry Security Constants Private Const STANDARD_RIGHTS_ALL = &H1F0000 Private Const SYNCHRONIZE = &H100000 Private Const READ_CONTROL = &H20000 Private Const STANDARD_RIGHTS_READ = (READ_CONTROL) Private Const STANDARD_RIGHTS_WRITE = (READ_CONTROL) Private Const KEY_QUERY_VALUE = &H1 Private Const KEY_SET_VALUE = &H2 Private Const KEY_CREATE_SUB_KEY = &H4 Private Const KEY_ENUMERATE_SUB_KEYS = &H8 Private Const KEY_NOTIFY = &H10 Private Const KEY_CREATE_LINK = &H20 Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE)) Private Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE)) Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE)) ' Reg Key ROOT Types Public Enum RegistryRoots HKEY_CLASSES_ROOT = &H80000000 HKEY_CURRENT_CONFIG = &H80000005 HKEY_CURRENT_USER = &H80000001 HKEY_DYN_DATA = &H80000006 HKEY_LOCAL_MACHINE = &H80000002 HKEY_PERFORMANCE_DATA = &H80000004 HKEY_USERS = &H80000003 End Enum ' Registry Data Type Constants Private Const REG_SZ = 1 Private Const REG_OPTION_NON_VOLATILE = 0 ' Error values Private Const ERROR_SUCCESS = 0& Private Const ERROR_NO_MORE_ITEMS = 259& Public Enum SystemSounds rgBuddy_In = 0 rgBuddy_Out = 1 rgClose = 2 rgDrop = 3 rgFilesDone = 4 rgGoodBye = 5 rgMailBeep = 6 rgMaximize = 7 rgMenuCommand = 8 rgMenuPopup = 9 rgMinimize = 10 rgOpen = 11 rgRestoreDown = 12 rgRestoreUp = 13 rgSystemAsterisk = 14 rgSystemExclamation = 15 rgSystemExit = 16 rgSystemHand = 17 rgSystemQuestion = 18 rgSystemStart = 19 rgWelcome = 20 rgYouGotMain = 21 End Enum Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long Private Declare Sub SetWindowPos Lib "User32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Integer, ByVal Y As Integer, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) Private Const WM_NCACTIVATE = &H86 Private Declare Function LoadIcon Lib "User32" Alias "LoadIconA" (ByVal hInstance As Long, ByVal lpIconName As String) As Long Private Declare Function LoadIconBynum& Lib "User32" Alias "LoadIconA" (ByVal hInstance As Long, ByVal lpIconName As Long) Private Declare Function DrawIcon Lib "User32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal hIcon As Long) As Long Private Declare Function DrawIconEx Lib "User32" (ByVal hDC As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long Public Enum SystemIcons IDI_APPLICATION = 32512& IDI_ASTERISK = 32516& IDI_EXCLAMATION = 32515& IDI_HAND = 32513& IDI_QUESTION = 32514& End Enum Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Const COLOR_BTNFACE = 15 Private Const COLOR_ACTIVECAPTION = 2 Private Const COLOR_INACTIVECAPTION = 3 Public Declare Function CreateRectRgn& Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) Public Declare Function CreateRoundRectRgn& Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) Public Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Public Declare Function SetWindowRgn Lib "User32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long Private Declare Function GetSysColor Lib "User32" (ByVal nIndex As Long) As Long Private Declare Function GetSysColorBrush Lib "User32" (ByVal nIndex As Long) As Long Private Const COLOR_APPWORKSPACE = 12 Private Const COLOR_BACKGROUND = 1 Private Declare Function GetDC Lib "User32" (ByVal hWnd As Long) As Long Private Declare Function ReleaseDC Lib "User32" (ByVal hWnd As Long, ByVal hDC As Long) As Long Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long Private Declare Function Rectangle Lib "gdi32" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long 'DrawEdge Routine Private Const BDR_RAISEDOUTER = &H1 Private Const BDR_SUNKENOUTER = &H2 Private Const BDR_RAISEDINNER = &H4 Private Const BDR_SUNKENINNER = &H8 Private Const BDR_OUTER = &H3 Private Const BDR_INNER = &HC Private Const BDR_RAISED = &H5 Private Const BDR_SUNKEN = &HA Private Const EDGE_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER) Private Const EDGE_SUNKEN = (BDR_SUNKENOUTER Or BDR_SUNKENINNER) Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER) Private Const EDGE_BUMP = (BDR_RAISEDOUTER Or BDR_SUNKENINNER) Private Const BF_LEFT = &H1 Private Const BF_TOP = &H2 Private Const BF_RIGHT = &H4 Private Const BF_BOTTOM = &H8 Private Const BF_TOPLEFT = (BF_TOP Or BF_LEFT) Private Const BF_TOPRIGHT = (BF_TOP Or BF_RIGHT) Private Const BF_BOTTOMLEFT = (BF_BOTTOM Or BF_LEFT) Private Const BF_BOTTOMRIGHT = (BF_BOTTOM Or BF_RIGHT) Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM) Private Const BF_DIAGONAL = &H10 ' For diagonal lines, the BF_RECT flags specify the end point of the ' vector bounded by the rectangle parameter. Private Const BF_DIAGONAL_ENDTOPRIGHT = (BF_DIAGONAL Or BF_TOP Or BF_RIGHT) Private Const BF_DIAGONAL_ENDTOPLEFT = (BF_DIAGONAL Or BF_TOP Or BF_LEFT) Private Const BF_DIAGONAL_ENDBOTTOMLEFT = (BF_DIAGONAL Or BF_BOTTOM Or BF_LEFT) Private Const BF_DIAGONAL_ENDBOTTOMRIGHT = (BF_DIAGONAL Or BF_BOTTOM Or BF_RIGHT) Private Const BF_MIDDLE = &H800 ' Fill in the middle Private Const BF_SOFT = &H1000 ' For softer buttons Private Const BF_ADJUST = &H2000 ' Calculate the space left over Private Const BF_FLAT = &H4000 ' For flat rather than 3D borders Private Const BF_MONO = &H8000 ' For monochrome borders Private Declare Function DrawEdge Lib "User32" (ByVal hDC As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Boolean Public Sub Draw3dUp(picBox As PictureBox, strCaption As String) Dim PicRect As RECT With picBox '.ForeColor = picbox.forecolor .Cls .ScaleMode = 3 .BorderStyle = 0 .AutoRedraw = True PicRect.Left = .ScaleLeft PicRect.Top = .ScaleTop PicRect.Right = .ScaleWidth PicRect.Bottom = .ScaleHeight .CurrentX = (.ScaleWidth - .TextWidth(strCaption)) / 2 .CurrentY = (.ScaleHeight - .TextHeight(strCaption)) / 2 End With picBox.Print strCaption DrawEdge picBox.hDC, PicRect, CLng(BDR_RAISEDINNER Or BF_SOFT), BF_RECT If picBox.AutoRedraw Then picBox.Refresh End Sub Public Sub Draw3dDown(picBox As PictureBox, strCaption As String) Dim PicRect As RECT With picBox '.ForeColor = picbox.forecolor .Cls .ScaleMode = 3 .BorderStyle = 0 .AutoRedraw = True PicRect.Left = .ScaleLeft PicRect.Top = .ScaleTop PicRect.Right = .ScaleWidth PicRect.Bottom = .ScaleHeight .CurrentX = (.ScaleWidth - .TextWidth(strCaption)) / 2 .CurrentY = (.ScaleHeight - .TextHeight(strCaption)) / 2 End With picBox.Print strCaption DrawEdge picBox.hDC, PicRect, CLng(BDR_SUNKENOUTER Or BF_SOFT), BF_RECT If picBox.AutoRedraw Then picBox.Refresh End Sub Public Sub frmZoomFromObj(frmParent As Object, f As Form, Optional ZoomEffect As ZoomEffects = 7, _ Optional ShowMsgForm As Boolean = True) Dim xFrom As RECT Dim xTo As RECT Dim ptApi As POINTAPI ZoomedFromLast = -1 Call GetWindowRect(frmParent.hWnd, xFrom) Call GetWindowRect(f.hWnd, xTo) Call DrawAnimatedRects(f.hWnd, IDANI_OPEN Or IDANI_CAPTION, xFrom, xTo) ZoomOpen f, 900, ZoomEffect, ShowMsgForm DoEvents Call regGetSystemWave("", rgRestoreUp) DoEvents End Sub Public Sub frmZoom(f As Form, ScreenPosition As ZoomFrom, Direction As ZoomDirection, _ Optional Cycles As Integer, Optional ZoomEffect As ZoomEffects = 7, _ Optional ShowMsgForm As Boolean = True) Dim xFrom As RECT Dim xTo As RECT Dim ptApi As POINTAPI If Direction = ZoomFormClosed And f.Visible = False Then Exit Sub 'Use the FromMousePointer options for Toolbar Buttons If ScreenPosition = FromMousePointer Then Call GetCursorPos(ptApi) xFrom.Top = ptApi.X xFrom.Left = ptApi.Y xFrom.Right = ptApi.X xFrom.Bottom = ptApi.Y ElseIf ScreenPosition = ScreenActiveFrm Then Call GetWindowRect(Screen.ActiveForm.hWnd, xFrom) xFrom.Right = 1 xFrom.Bottom = 1 Else Call GetWindowRect(GetDesktopWindow(), xFrom) End If ZoomedFromLast = ScreenPosition Select Case ScreenPosition Case 0 'TopLeft = 0 xFrom.Left = 0 xFrom.Top = 0 Case 1 'TopCenter = 1 xFrom.Left = (xFrom.Right - xFrom.Left) / 2 xFrom.Top = 0 Case 2 'TopRight = 2 xFrom.Left = xFrom.Right - 1 xFrom.Top = 0 Case 3 'MidLeft = 3 xFrom.Left = 0 xFrom.Top = (xFrom.Bottom - xFrom.Top) / 2 Case 4 'MidCenter = 4 xFrom.Left = (xFrom.Right - xFrom.Left) / 2 xFrom.Top = (xFrom.Bottom - xFrom.Top) / 2 Case 5 'MidRight = 5 xFrom.Left = xFrom.Right - 1 xFrom.Top = (xFrom.Bottom - xFrom.Top) / 2 Case 6 'BtmLeft = 6 xFrom.Left = 0 xFrom.Top = xFrom.Bottom - 1 Case 7 'BtmCenter = 7 xFrom.Left = (xFrom.Right - xFrom.Left) / 2 xFrom.Top = xFrom.Bottom - 1 Case 8 'BtmRight = 8 xFrom.Left = xFrom.Right - 1 xFrom.Top = xFrom.Bottom - 1 Case 9 'ScreenCenter = 9 xFrom.Left = (xFrom.Right - xFrom.Left) / 2 xFrom.Top = (xFrom.Bottom - xFrom.Top) / 2 Case 10, 11 frmZoomToFromTray f, Direction, ZoomEffect, ShowMsgForm Exit Sub End Select xFrom.Bottom = xFrom.Top + 1 xFrom.Right = xFrom.Left + 1 Call GetWindowRect(f.hWnd, xTo) If Direction = ZoomFormOpen Then Call DrawAnimatedRects(f.hWnd, IDANI_OPEN Or IDANI_CAPTION, xFrom, xTo) If Cycles > 0 Then ZoomOpen f, Cycles, ZoomEffect, ShowMsgForm Else ZoomOpen f, 900, ZoomEffect, ShowMsgForm End If DoEvents Call regGetSystemWave("", rgRestoreUp) DoEvents Else Call DrawAnimatedRects(f.hWnd, IDANI_CLOSE Or IDANI_CAPTION, xTo, xFrom) Call regGetSystemWave("", rgRestoreDown) DoEvents f.Hide DoEvents Unload f End If End Sub Public Sub frmZoomToObj(frmParent As Object, f As Form) Dim xFrom As RECT Dim xTo As RECT Dim ptApi As POINTAPI If f.Visible = False Then Exit Sub Call GetWindowRect(frmParent.hWnd, xTo) Call GetWindowRect(f.hWnd, xFrom) Call DrawAnimatedRects(f.hWnd, IDANI_CLOSE Or IDANI_CAPTION, xFrom, xTo) Call regGetSystemWave("", rgRestoreDown) DoEvents f.Hide Unload f End Sub Public Sub frmZoomToFromTray(f As Form, Direction As ZoomDirection, Optional ZoomEffect As ZoomEffects = 7, _ Optional ShowMsgForm As Boolean = True) Dim TrayhWnd As Long Dim hWnd As Long Dim r Dim sClassName As String * 100 hWnd = FindWindow("Shell_TrayWnd", 0&) hWnd = GetWindow(hWnd, GW_CHILD) Do r = GetClassName(hWnd, sClassName, 100) If Left(sClassName, r) = "TrayNotifyWnd" Then Exit Do End If hWnd = GetWindow(hWnd, GW_HWNDNEXT) Loop While hWnd <> 0 Dim xFrom As RECT Dim xTo As RECT Select Case Direction Case ZoomFormOpen Call GetWindowRect(hWnd, xFrom) xFrom.Left = (xFrom.Right - (xFrom.Right - xFrom.Left) / 2) xFrom.Right = xFrom.Left + 1 Call GetWindowRect(f.hWnd, xTo) Call DrawAnimatedRects(f.hWnd, IDANI_OPEN Or IDANI_CAPTION, xFrom, xTo) ZoomOpen f, 900, ZoomEffect, ShowMsgForm DoEvents Call regGetSystemWave("", rgRestoreUp) DoEvents Case ZoomFormClosed Call GetWindowRect(f.hWnd, xFrom) Call GetWindowRect(hWnd, xTo) xTo.Left = (xTo.Right - (xTo.Right - xTo.Left) / 2) xTo.Right = xTo.Left + 1 Call DrawAnimatedRects(f.hWnd, IDANI_CLOSE Or IDANI_CAPTION, xFrom, xTo) Call regGetSystemWave("", rgRestoreDown) DoEvents f.Hide DoEvents Unload f End Select End Sub Public Function picGetSysMsgBoxIcon(Pic As Object, SysIcon As SystemIcons) Dim hIcon As Long, r As Long hIcon = LoadIconBynum&(0, SysIcon) r = DrawIcon(Pic.hDC, 0, 0, hIcon) Pic.Refresh End Function Public Sub regGetSystemWave(Optional WaveFile As String, Optional SystemSound As SystemSounds) Dim SoundToGet As String If Len(WaveFile) > 0 Then Call sndPlaySound(WaveFile, SND_ASYNC Or SND_NODEFAULT) Else 'Get From System Select Case SystemSound Case 0 SoundToGet = "Buddy In" Case 1 SoundToGet = "Buddy Out" Case 2 SoundToGet = "Close" Case 3 SoundToGet = "Drop" Case 4 SoundToGet = "File's Done" Case 5 SoundToGet = "Goodbye" Case 6 SoundToGet = "MailBeep" Case 7 SoundToGet = "Maximize" Case 8 SoundToGet = "MenuCommand" Case 9 SoundToGet = "MenuPopup" Case 10 SoundToGet = "Minimize" Case 11 SoundToGet = "Open" Case 12 SoundToGet = "RestoreDown" Case 13 SoundToGet = "RestoreUp" Case 14 SoundToGet = "SystemAsterisk" Case 15 SoundToGet = "SystemExclamation" Case 16 SoundToGet = "SystemExit" Case 17 SoundToGet = "SystemHand" Case 18 SoundToGet = "SystemQuestion" Case 19 SoundToGet = "SystemStart" Case 20 SoundToGet = "Welcome" Case 21 SoundToGet = "You've Got Mail" End Select WaveFile = regGetRegistrySetting(HKEY_CURRENT_USER, rgRegSounds & SoundToGet & "\.Current", "", "") Call sndPlaySound(WaveFile, SND_ASYNC Or SND_NODEFAULT) End If End Sub Public Function regGetRegistrySetting(ByVal root As RegistryRoots, ByVal KeyPath As String, ByVal ValueName As String, Optional DefaultData) Dim RegReturnValue As Long Dim hKey As Long Dim RegValType As Long Dim RegTempValue As String Dim RegValueSize As Long RegReturnValue = RegOpenKeyEx(root, KeyPath, 0, KEY_READ, hKey) If (RegReturnValue <> ERROR_SUCCESS) Then GoTo error_handler RegReturnValue = RegQueryValueEx(hKey, ValueName, 0, RegValType, RegTempValue, RegValueSize) If ((RegReturnValue = ERROR_SUCCESS) And (RegValueSize > 0)) Then RegTempValue = Space(RegValueSize - 1) Else RegTempValue = Space(1) End If RegReturnValue = RegQueryValueEx(hKey, ValueName, 0, RegValType, RegTempValue, LenB(RegTempValue)) If (RegReturnValue <> ERROR_SUCCESS) Or (RegValType <> REG_SZ) Then GoTo error_handler regGetRegistrySetting = RegTempValue RegReturnValue = RegCloseKey(hKey) Exit Function error_handler: If Not IsMissing(DefaultData) Then regGetRegistrySetting = DefaultData Else regGetRegistrySetting = "" End If RegReturnValue = RegCloseKey(hKey) End Function Sub ZoomOpen(f As Form, Cycles As Integer, Optional ZoomEffect As ZoomEffects = 7, _ Optional ShowMsgForm As Boolean = True) Dim f_Rect As RECT Dim f_Width As Integer Dim f_Height As Integer Dim I As Integer Dim Left As Integer Dim Top As Integer Dim GrowWidth As Integer Dim GrowHeight As Integer Dim Desktop As Long Dim Brush As Long GetWindowRect f.hWnd, f_Rect f_Width = (f_Rect.Right - f_Rect.Left) f_Height = f_Rect.Bottom - f_Rect.Top Desktop = GetDC(0) Brush = CreateSolidBrush(GetSysColor(COLOR_ACTIVECAPTION)) Call SelectObject(Desktop, CLng(Brush)) For I = 1 To Cycles Select Case ZoomEffect Case 0 'From Middle GrowWidth = f_Width GrowHeight = f_Height * (I / Cycles) Left = f_Rect.Left Top = f_Rect.Top + (f_Height - GrowHeight) / 2 Rectangle Desktop, Left, Top, Left + GrowWidth, Top + GrowHeight Case 1 'From Left GrowWidth = f_Width * (I / Cycles) GrowHeight = f_Height Left = f_Rect.Left Top = f_Rect.Top + (f_Height - GrowHeight) / 2 Rectangle Desktop, Left, Top, Left + GrowWidth, Top + GrowHeight Case 2 'From Right GrowWidth = f_Width * (I / Cycles) GrowHeight = f_Height Left = f_Rect.Right Top = f_Rect.Top Rectangle Desktop, Left, Top, Left - GrowWidth, Top + GrowHeight Case 3 'From Top Right GrowWidth = f_Width * (I / Cycles) GrowHeight = f_Height * (I / Cycles) Left = f_Rect.Right Top = f_Rect.Top Rectangle Desktop, Left, Top, Left - GrowWidth, Top + GrowHeight Case 4 'From Bottom Right GrowWidth = f_Width * (I / Cycles) GrowHeight = f_Height * (I / Cycles) Left = f_Rect.Right Top = f_Rect.Top + (f_Height - GrowHeight) / 2 Rectangle Desktop, Left, Top, Left - GrowWidth, Top + GrowHeight Case 5 'From Bottom Left GrowWidth = f_Width * (I / Cycles) GrowHeight = f_Height * (I / Cycles) Left = f_Rect.Left Top = f_Rect.Top + (f_Height - GrowHeight) / 2 Rectangle Desktop, Left, Top, Left + GrowWidth, Top + GrowHeight Case 6 'From Top Left GrowWidth = f_Width * (I / Cycles) GrowHeight = f_Height * (I / Cycles) Left = f_Rect.Left Top = f_Rect.Top Rectangle Desktop, Left, Top, Left + GrowWidth, Top + GrowHeight Case 7 'Explode GrowWidth = f_Width * (I / Cycles) GrowHeight = f_Height * (I / Cycles) Left = f_Rect.Left + (f_Width - GrowWidth) / 2 Top = f_Rect.Top + (f_Height - GrowHeight) / 2 Rectangle Desktop, Left, Top, Left + GrowWidth, Top + GrowHeight Case 8 'From Top GrowWidth = f_Width GrowHeight = f_Height * (I / Cycles) Left = f_Rect.Left Top = f_Rect.Top Rectangle Desktop, Left, Top, Left + GrowWidth, Top + GrowHeight Case 9 'From bottom GrowWidth = f_Width GrowHeight = f_Height * (I / Cycles) Left = f_Rect.Left Top = f_Rect.Bottom - (f_Height - GrowHeight) / 2 Rectangle Desktop, Left, Top, Left + GrowWidth, f_Rect.Bottom - GrowHeight End Select Next I Call ReleaseDC(0, Desktop) DeleteObject (Brush) DoEvents f.Show DoEvents If ShowMsgForm = True Then 'Normal Position MsgForm.Top = f.Top - MsgForm.Height - 200 MsgForm.Left = f.Left + 100 'If Top is less than Screen top If MsgForm.Top < 0 Then MsgForm.Top = 0 'If Right side is beyond screen width If MsgForm.Left + MsgForm.Width > Screen.Width Then MsgForm.Left = Screen.Width - MsgForm.Width 'If Over the Calling Form If MsgForm.Top + MsgForm.Height > f.Top Then 'If Calling form is on the Left half of screen If f.Left < Screen.Width / 2 Then 'Move to Right MsgForm.Left = f.Left + f.Width + 10 Else 'Move to left MsgForm.Left = f.Left - MsgForm.Width - 10 End If End If If MsgForm.Left < 0 Then MsgForm.Left = 0 If MsgForm.Left + MsgForm.Width > Screen.Width Then MsgForm.Left = f.Left - MsgForm.Width - 200 MsgForm.Show DoEvents End If 'Make Assistant Window Look like it has focus Call SendMessage(f.hWnd, WM_NCACTIVATE, 1, 1) End Sub y ya para madar a llamarlo lo unico que debes hacer es lo siguiente, por ejemplo en un command: primero en el area de declaraciones generales agrega esta funcion Public Sub Msg(Results As Integer) End Sub despues en el codigo del command pon esto: Unload MsgForm If Index <> 1 Then Unload frmAssist With MsgForm .A_SetBackColor vbHighlight .msgText.ForeColor = vbYellow .msgText.FontName = "Arial" .msgText.FontBold = True .msgText.FontItalic = False .msgText.FontSize = 14 .A_SystemIcon = IDI_EXCLAMATION .A_SendResultsTo Me .A_AddButton 0, "Yes" .A_AddButton 1, "No" .A_AddButton 2, "Cancel" .A_MsgText = Text1 .A_Initialize End With puedes manipular los resultados del boton que preciones en la funcion anterior, dependiendo del boton que preciones, date cuenta que dentro de esa funcion evaluaras el valor de A_AddButton, que puede ser 0,1,2 o 3, ok espero no confundirte y haberte ayudado, ahhh!! por cierto el modulo .bas debe llamarse rg Jose Antonio HUerta - jantoniohuerta@mexico.com http://www.lawebdelprogramador.com