Buenas, teniendo el Handlle de una ventana de una aplicación "externa" , se puede modificar la propiedad Height dela ventanacon SendMessage o alguna otra función Api ???
"GRASSIAS" y SALU2 D DESSA
Buenas, teniendo el Handlle de una ventana de una aplicación "externa" , se puede modificar la propiedad Height dela ventanacon SendMessage o alguna otra función Api ???
"GRASSIAS" y SALU2 D DESSA
Utiliza la funcion SetWindowPos() del API de Windows.
Salu2...
Cada vez que se alinean los planetas me paso de visita por el foro
dx_lib32: Programa juegos en Visual Basic 6.0 y Visual Basic .NET con la potencia de DirectX 8.1
Version 2.2.0 final publicada
Buenísimo EX3, Buenísimo (cx-cy), y para los controles (Text o Button) ???
SALUDOS D DESSA (1000 Gracias) * (1000)
Edited by: Dessa
Lo mismo, pero pasando un valor 0 en hwndinsertAfter y 0 en wFlags
SetWindowPos Command1.hWnd, vbNull, 0, 0, 100, 100, 0
nota: los valores son en pixeles
saludos
-----------
Buenísimo Luciano,gracias, alguna idea paracambiar Backcolor o Forecolor deventana o controles ???
SALUDOS D DESSA (1.000 Gracias) * (1.000)
Edited by: Dessa
Creo que también se hace con SnedMesage. Pero no se bien que mensajes y valores pasar. En la guia de recursos hay un ejemplo para cambiar el Backcolor de un Progress, probalo, solo cambia el hwnd por tu ventana-control .. a ver si funka
saludos
Usando las siguientes 2 lineas (sacadas del topic "Progressbar estilo XP" que Anibal publicó en "Guía de recursos" ) he podido cambiar el back y forecolor de una barra de progreso en una aplicación "externa" :
srgb = SendMessage(Hndl, &H409, 0, ByVal RGB(255, 255, 255))
srgb = SendMessage(Hndl, &H2001, 0, ByVal RGB(0, 0, 0))
El tema es que solamente me sirve para barras de progreso, como tengo que hacer para conocer el wMsg para cambiar el back y forecolor de otros controles, por ejemplo texbox o principalmente el backcolor de un formulario ???
"Grassias" & SALU2 D DESSA
En la MSDN si buscas encontraras todas las constantes de mensajes de Windows, su uso y funciones a las que estan asociadas.
Salu2...
Cada vez que se alinean los planetas me paso de visita por el foro
dx_lib32: Programa juegos en Visual Basic 6.0 y Visual Basic .NET con la potencia de DirectX 8.1
Version 2.2.0 final publicada
Otro sitio donde puedes buscar las constantes de mensajes seria en el Visor de API que trae consigo Visual Basic o que puedes descargar de aqui una version mejorada y con mas entradas añadidas y documentadas. Basandote en las constantes que estas usando en tu programa podras encontrar otras relacionadas, el resto es cuestion de ir probando.
Salu2...
Cada vez que se alinean los planetas me paso de visita por el foro
dx_lib32: Programa juegos en Visual Basic 6.0 y Visual Basic .NET con la potencia de DirectX 8.1
Version 2.2.0 final publicada
EX3: me ayudamucho tu nuevo dato, pero no me ayudarias conalgo decódigo, para cambiar el backcolor de una ventana en una aplicación "externa"
Gracias
Hola estoy casi seguro que con SendMessage no podrias cambiarle el backcolor ya que si capturas los mensages recividos en un formulario (CallWindowProc) notaras (con un timer cambiar el backcolor) no llega ningun mensage, yo supongo que la unica forma seria pintar dicha ventana lo cual no garantiza un buen trabajo ya que dependiendo de algunas ventanas se pintan bien y otras no y lo que es peor como saver cuando esta ventana se refrescara , por ende no creo que encuentres una forma muy efectiva para hacerlo con culquier ventana permanentemente
yo te paso un ejemplo de como masomenos me salio algo
pero bien notaras que cuando pases una ventana o minimizes la calculadora se despinta el color quizas con alguna api se podria fijar pero no tengo ni ideaCódigo:Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, lprcUpdate As Any, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Const WM_PAINT As Long = &HF& Private Const RDW_INVALIDATE = &H1 Private Sub Command1_Click() Dim Handle As Long Handle = FindWindow(vbNullString, "Calculadora") Pintar Handle, vbRed End Sub Private Sub Pintar(Handle As Long, Color As Long) If Handle = 0 Then Exit Sub Dim APic As PictureBox Set APic = Me.Controls.Add("VB.PictureBox", "APic1") APic.Width = Screen.Width APic.Height = Screen.Height APic.BackColor = Color SendMessage APic.hwnd, WM_PAINT, GetDC(Handle), CLng(0) 'si es un formulario de visual la linea Redrawwindow no nesesario RedrawWindow Handle, ByVal 0&, ByVal 0&, RDW_INVALIDATE Me.Controls.Remove "APic1" End Sub Private Sub Form_Load() Shell "calc" End Sub
y use un picture para pintarlo ya que si utilizaba estas apis
nose porque carajo si la ventana es ajena a nuestra aplicacion se pinta un rectangulo blanco y no con el color rojo en este caso le asigneCódigo:brocha = CreateSolidBrush(vbred) SelectObject Me.hdc, brocha Rectangle Me.hdc, 0, 0, 100, 100
Saludos
Me temo que poco podria ayudarte en este tema ya que lo mas que llegue ha trabajar con SendMessage() ha sido para hacer modificaciones y acceder a la informacion de un TextBox de mi propia aplicacion, tal informacion como obtener numero de lineas que contiene y numero de linea donde se encuentra el cursor.Iniciado por Dessa
A parte de la respuesta de Leandro, que segun he leido por encima se acerca a lo que te voy a contar, en el enlace de la MSDN que te pase antes, si buscas funciones por categorias, en la seccion referente a las funciones de gestion y mantenimiento de ventanas en Windows, creo recordar que habia funciones para manipular las propiedades de estas, y muchos controles de Windows en el fondo son ventanas realmente que estan asociadas a una principal, muchos de estos controles tienen su propio hWnd, por lo tanto se puede acceder externamente a sus propiedades.
Salu2...
Cada vez que se alinean los planetas me paso de visita por el foro
dx_lib32: Programa juegos en Visual Basic 6.0 y Visual Basic .NET con la potencia de DirectX 8.1
Version 2.2.0 final publicada
Leandro: quisiera probar con tu segundo ejemplo pero en lugar de CreateSolidBrush usar una existente (GetStockObject), como obtengo el hdc del la ventana externa ?
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject 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 Const BLACK_BRUSH = 4
Private Sub Command1_Click()
SelectObject Me.hdc, GetStockObject(BLACK_BRUSH)
Rectangle Me.hdc, 0, 0, 100, 100
End Sub
Private Sub Command2_Click()
SelectObject Me.hdc, GetStockObject(vbRed)
Rectangle Me.hdc, 0, 0, 100, 100
End Sub
Gracias y salu2 d Dessa
Hola
para capturar el Hdc es con GetDc
HAciendo lo que queres sería asi:
...Pero estamos en la misma que la de Leandro, el área se pinta de color blanco, ni idea por queCódigo:Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject 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 Sub Command1_Click() Dim Handle As Long Handle = FindWindow(vbNullString, "Calculadora") Pintar Handle, vbRed End Sub Private Sub Pintar(Handle As Long, Color As Long) If Handle = 0 Then Exit Sub SelectObject GetDC(Handle), GetStockObject(4) Rectangle GetDC(Handle), 0, 0, 100, 100 End Sub Private Sub Form_Load() Shell "calc" End Sub
saludos
Finalmente retomé el primer ejemplo de Leandro, ya que la ventana de aplicación externa a la que me refiero se "pinta" perfectamete y llamando a "pintar" desde mi aplicación con un Timer-control (interval=5) se comporta exelente (probé con poca RAM y el color siguió "Firme", me faltaría probar con un cpu de pocos Mhz. )
La "futrillita del postre" sería poder quitar o deshabilitar de la barra de título el botón ("X") que cierra, esta ventana no cuenta con "control-box" solo el botón cerrar. Probé con RemoveMenu y con GetSystemMenu, pero nada , ya que al no contar con el menú del controlbox no tengo "número" a quien remover:
RemoveMenu hWndMenu, 6, MF_BYPOSITION Or MF_REMOVE
GRACIAS + SALU2 D DESSA
Buenas, pude quitar el botón "cerrar" en una ventana de una aplicación externa con el siguiente código que publico a continuación , solo hay que cambiar el Me.hwnd por el Handdle de la ventana en que se quiere quitar dicho botón:
Option Explicit
Private Declare Function GetSystemMenu _
Lib "user32" ( _
ByVal hwnd As Long, _
ByVal bRevert As Long) As Long
Private Declare Function DeleteMenu _
Lib "user32" ( _
ByVal hMenu As Long, _
ByVal nPosition As Long, _
ByVal wFlags As Long) As Long
Private Declare Function GetWindowRect _
Lib "user32" ( _
ByVal hwnd As Long, lpRect As RECT) As Long
Private 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) As Long
Const vbhNull As Long = 0
Const SWP_FRAMECHANGED As Long = &H20&
Const SC_CLOSE As Long = &HF060&
Const MF_BYCOMMAND As Long = &H0&
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Sub quitarcerrar(ByVal hwnd As Long, _
Optional ByVal NoCloseButton As Boolean)
Dim rec As RECT
Dim hMenu As Long
GetWindowRect hwnd, rec
hMenu = GetSystemMenu(hwnd, vbhNull)
DeleteMenu hMenu, SC_CLOSE, MF_BYCOMMAND
If NoCloseButton Then
DeleteMenu hMenu, SC_CLOSE, MF_BYCOMMAND
End If
SetWindowPos hwnd, vbhNull, rec.Left, rec.Top, _
rec.Right - rec.Left, _
rec.Bottom - rec.Top, SWP_FRAMECHANGED
End Sub
Private Sub Form_Load()
Command1.Caption = "QUITAR"
Command2.Caption = "CERRAR"
End Sub
Private Sub Command1_Click()
quitarcerrar (Me.hwnd)
End Sub
Private Sub Command2_Click()
End
End Sub
Gracias a EX3, LUCIANO y LEANNDRO POR LA AYUDA
SALU2 D DESSA
Si lo que buscabas era simplemente deshabilitar el boton y el comando cerrar de la ventana ahi te sobra codigo:Iniciado por Dessa
Salu2...Código:Option Explicit Private Declare Function GetSystemMenu Lib "user32.dll" (ByVal hwnd As Long, ByVal bRevert As Long) As Long Private Declare Function RemoveMenu Lib "user32.dll" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long Private Const MF_BYPOSITION = &H400 Private Sub Form_Load() Call RemoveMenu(GetSystemMenu(Me.hwnd, 0), 6, MF_BYPOSITION) End Sub
Cada vez que se alinean los planetas me paso de visita por el foro
dx_lib32: Programa juegos en Visual Basic 6.0 y Visual Basic .NET con la potencia de DirectX 8.1
Version 2.2.0 final publicada
EX3: Ya lo había intentado de la manera que mencionas (Tal como lo había publicadado en post del día 26/12/2006) te recuerdo que es una ventana externa a mi aplicación con controlbox = false y borderstyle = fixed tool (solamente el boton "x" de cerrar y sin ícono) pero al volber a intentar pero esta vez con posición 1 (uno) si funcionó, por lo tanto gracias nuevamente porque pude ahorrar código.
remo = RemoveMenu(GetSystemMenu(Hndl, 0), 1, MF_BYPOSITION)
Como tendría que hacer si en lugar de remover el botón quisiera darle un click (cerrar la ventana) recuerdo nuevamente que es una ventana externa a mi aplicación. El Hndl de dicha ventana ya lo tengo, pero como llego al Hndl del botón de la barra de título ???
GRACIAS & SALU2 D DESSA
hola con sendmensage
SaludosCódigo: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 Const WM_SYSCOMMAND = &H112 Const SC_CLOSE = &HF060& Private Sub Command1_Click() Dim Handle As Long Handle = Me.hwnd 'aqui pontes el hwnd de la ventana que quieres SendMessage Handle, WM_SYSCOMMAND, SC_CLOSE, CLng(0) End Sub
Hola, se puede mandar un sendmensagge a un control "SLIDER" de una aplicación externa ( tengo que llevarlo a cero ). el Handlle lo tengo, me faltaría el Wmsg:
Hndl = FindWindow(CLASENOMBRE, vbNullString) ' parent de Combinaciones de sucesos
Hndl = FindWindowEx(Hndl, 0, vbNullString, "Combinaciones de sucesos") ' parent de Slider1
Hndl = FindWindowEx(Hndl, 0, "msctls_trackbar32", "Slider1")
Call SendMessage(Hndl, WM_LBUTTONDOWN, 0, 0)
Call SendMessage(Hndl, WM_LBUTTONUP, 0, 0)
El click responde pero necesito deslizar hasta vaolr 0 (cero)
GRACIAS + SALU2 D DESSA
hola te paso un ejemplo y todas las constantes
Nota: siempre hay que tener cuidado como esta declarada el api SendMessage ya que yo me comi muchas veses este garron de que no me funcionaba , y es porque los mensages pueden estar declados de diferentes formas por ejemplo en el ultimo lParamCódigo:Private Declare Function SendMessage Lib "user32" _ Alias "SendMessageA" _ (ByVal hwnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) _ As Long 'TBM_SETPOS Private Const CCM_FIRST = &H2000 ' Common control shared messages Private Const CCM_SETUNICODEFORMAT = (CCM_FIRST + 5) Private Const CCM_GETUNICODEFORMAT = (CCM_FIRST + 6) Private Const WM_USER = &H400& Private Const TBM_GETPOS = (WM_USER) Private Const TBM_GETRANGEMIN = (WM_USER + 1) Private Const TBM_GETRANGEMAX = (WM_USER + 2) Private Const TBM_GETTIC = (WM_USER + 3) Private Const TBM_SETTIC = (WM_USER + 4) Private Const TBM_SETPOS = (WM_USER + 5) Private Const TBM_SETRANGE = (WM_USER + 6) Private Const TBM_SETRANGEMIN = (WM_USER + 7) Private Const TBM_SETRANGEMAX = (WM_USER + 8) Private Const TBM_CLEARTICS = (WM_USER + 9) Private Const TBM_SETSEL = (WM_USER + 10) Private Const TBM_SETSELSTART = (WM_USER + 11) Private Const TBM_SETSELEND = (WM_USER + 12) Private Const TBM_GETPTICS = (WM_USER + 14) Private Const TBM_GETTICPOS = (WM_USER + 15) Private Const TBM_GETNUMTICS = (WM_USER + 16) Private Const TBM_GETSELSTART = (WM_USER + 17) Private Const TBM_GETSELEND = (WM_USER + 18) Private Const TBM_CLEARSEL = (WM_USER + 19) Private Const TBM_SETTICFREQ = (WM_USER + 20) Private Const TBM_SETPAGESIZE = (WM_USER + 21) Private Const TBM_GETPAGESIZE = (WM_USER + 22) Private Const TBM_SETLINESIZE = (WM_USER + 23) Private Const TBM_GETLINESIZE = (WM_USER + 24) Private Const TBM_GETTHUMBRECT = (WM_USER + 25) Private Const TBM_GETCHANNELRECT = (WM_USER + 26) Private Const TBM_SETTHUMBLENGTH = (WM_USER + 27) Private Const TBM_GETTHUMBLENGTH = (WM_USER + 28) Private Const TBM_SETTOOLTIPS = (WM_USER + 29) Private Const TBM_GETTOOLTIPS = (WM_USER + 30) Private Const TBM_SETTIPSIDE = (WM_USER + 31) Private Const TBM_SETBUDDY = (WM_USER + 32) Private Const TBM_GETBUDDY = (WM_USER + 33) Private Const TBM_SETUNICODEFORMAT = CCM_SETUNICODEFORMAT Private Const TBM_GETUNICODEFORMAT = CCM_GETUNICODEFORMAT Private Sub Command1_Click() 'nos devuelve la posicion Dim lResult As Long lResult = SendMessage(Slider1.hwnd, TBM_GETPOS, 0, 0) MsgBox lResult End Sub Private Sub Command2_Click() Dim Posicion As Long Posicion = 0 ' aca podemos asignar la posicion en que queremos Call SendMessage(Slider1.hwnd, TBM_SETPOS, -1, Posicion) End Sub
lParam as Long
lParam as String
lParam as Any
lParam as Integer
en este caso deven ser todos de tipo Long
---
voy a poner en la guia de recursos una lista que encontrede constantes bien ordenadas que esta muy buena
SaludosEdited by: Leandro
LEANDRO: Gracias por el ejemplo (funciona perfecto corre el el slider a cero) pero al aceptar no se fijan los cambios (vuelve a su posición original),
Hndl = FindWindow(CLASENOMBRE, vbNullString)
Hndl = FindWindowEx(Hndl, 0, vbNullString, "Combinaciones de sucesos")
Hndl = FindWindowEx(Hndl, 0, "msctls_trackbar32", "Slider1")
Dim Posicion As Long: Posicion = 0
Call SendMessage(Hndl, TBM_SETPOS, -1, ByVal Posicion)
Hndl = FindWindow(CLASENOMBRE, vbNullString) 'parent de aceptar
Hndl = FindWindowEx(Hndl, 0, "button", "Aceptar")
Call SendMessage(Hndl, WM_LBUTTONDOWN, 0, 0)
Call SendMessage(Hndl, WM_LBUTTONUP, 0, 0)
Lo que tengo que hacer es bajar o silenciar el sonido de windows desde el código (no encuentro la opción en el registro que sería mas directo)
Lo mas cerca que estube es hacer un click en el boton silencio de las propiedades de sonido y multimedia del panel de control
Hndl = FindWindow(CLASENOMBRE, vbNullString)
Hndl = FindWindowEx(Hndl, 0, vbNullString, "Combinaciones de sucesos")
Hndl = FindWindowEx(Hndl, 0, "button", "Silencio")
Call SendMessage(Hndl, WM_LBUTTONDOWN, 0, 0)
Call SendMessage(Hndl, WM_LBUTTONUP, 0, 0)
Hndl = FindWindow(CLASENOMBRE, vbNullString) 'parent de aceptar
Hndl = FindWindowEx(Hndl, 0, "button", "Aceptar")
Call SendMessage(Hndl, WM_LBUTTONDOWN, 0, 0)
Call SendMessage(Hndl, WM_LBUTTONUP, 0, 0)
Esto sí fija los cambios, pero no encuentro manera de saber cuando hacer el click y cuando no hacerlo, ya que boton de silencio es igual cuando está habilitado y cuando no.
Conclusión: hace 10 dias que estoy peliando para deshabilitar por unos segundos el sonido de supermierda.
Nota: Muy buenas las constantes que publicaste en la guia de recursos y como buscarlas
GRACIAS + SALU2 D DESSA
Hola jeje uviera sido mas facil si empezabas por ay, para modificar el volumen de windows , existen formas mucho mas eficientes para eso, que es trabajando directamente con el api winmm.dll , te voy a pasar un codigo que modifica el bolumen del MasterGeneral del audio y el del microfono (despues si queres tengo otro code para los demas midi linea de audio etc., pero te paso este que esta un poco mas simple)
en un modulo bas
y en un formulario con dos slider y 4 Labels (despues vos acomodalo a tus nesesidades)Código:Public Const MMSYSERR_NOERROR = 0 Public Const MAXPNAMELEN = 32 Public Const MIXER_LONG_NAME_CHARS = 64 Public Const MIXER_SHORT_NAME_CHARS = 16 Public Const MIXER_GETLINEINFOF_COMPONENTTYPE = &H3& Public Const MIXER_GETCONTROLDETAILSF_VALUE = &H0& Public Const MIXER_GETLINECONTROLSF_ONEBYTYPE = &H2& Public Const MIXERLINE_COMPONENTTYPE_DST_FIRST = &H0& Public Const MIXERLINE_COMPONENTTYPE_SRC_FIRST = &H1000& Public Const MIXERLINE_COMPONENTTYPE_DST_SPEAKERS = _ (MIXERLINE_COMPONENTTYPE_DST_FIRST + 4) Public Const MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE = _ (MIXERLINE_COMPONENTTYPE_SRC_FIRST + 3) Public Const MIXERLINE_COMPONENTTYPE_SRC_LINE = _ (MIXERLINE_COMPONENTTYPE_SRC_FIRST + 2) Public Const MIXERCONTROL_CT_CLASS_FADER = &H50000000 Public Const MIXERCONTROL_CT_UNITS_UNSIGNED = &H30000 Public Const MIXERCONTROL_CONTROLTYPE_FADER = _ (MIXERCONTROL_CT_CLASS_FADER Or _ MIXERCONTROL_CT_UNITS_UNSIGNED) Public Const MIXERCONTROL_CONTROLTYPE_VOLUME = _ (MIXERCONTROL_CONTROLTYPE_FADER + 1) Declare Function mixerClose Lib "winmm.dll" (ByVal hmx As Long) As Long Declare Function mixerGetControlDetails Lib "winmm.dll" _ Alias "mixerGetControlDetailsA" (ByVal hmxobj As Long, _ pmxcd As MIXERCONTROLDETAILS, ByVal fdwDetails As Long) As Long Declare Function mixerGetDevCaps Lib "winmm.dll" Alias "mixerGetDevCapsA" _ (ByVal uMxId As Long, ByVal pmxcaps As MIXERCAPS, _ ByVal cbmxcaps As Long) As Long Declare Function mixerGetID Lib "winmm.dll" _ (ByVal hmxobj As Long, pumxID As Long, ByVal fdwId As Long) As Long Declare Function mixerGetLineControls Lib "winmm.dll" _ Alias "mixerGetLineControlsA" (ByVal hmxobj As Long, _ pmxlc As MIXERLINECONTROLS, ByVal fdwControls As Long) As Long Declare Function mixerGetLineInfo Lib "winmm.dll" Alias "mixerGetLineInfoA" _ (ByVal hmxobj As Long, pmxl As MIXERLINE, _ ByVal fdwInfo As Long) As Long Declare Function mixerGetNumDevs Lib "winmm.dll" () As Long Declare Function mixerMessage Lib "winmm.dll" _ (ByVal hmx As Long, ByVal uMsg As Long, ByVal dwParam1 As Long, _ ByVal dwParam2 As Long) As Long Declare Function mixerOpen Lib "winmm.dll" (phmx As Long, ByVal uMxId As Long, _ ByVal dwCallback As Long, ByVal dwInstance As Long, _ ByVal fdwOpen As Long) As Long Declare Function mixerSetControlDetails Lib "winmm.dll" _ (ByVal hmxobj As Long, pmxcd As MIXERCONTROLDETAILS, _ ByVal fdwDetails As Long) As Long Declare Sub CopyStructFromPtr Lib "kernel32" Alias "RtlMoveMemory" _ (struct As Any, ByVal ptr As Long, ByVal cb As Long) Declare Sub CopyPtrFromStruct Lib "kernel32" Alias "RtlMoveMemory" _ (ByVal ptr As Long, struct As Any, ByVal cb As Long) Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, _ ByVal dwBytes As Long) As Long Declare Function GlobalLock Lib "kernel32" (ByVal hmem As Long) As Long Declare Function GlobalFree Lib "kernel32" (ByVal hmem As Long) As Long Type MIXERCAPS wMid As Integer ' id del fabricante wPid As Integer ' id del producto vDriverVersion As Long ' version del driver szPname As String * MAXPNAMELEN ' nombre del producto fdwSupport As Long ' bits de soporte cDestinations As Long ' numero de destinos End Type Type MIXERCONTROL cbStruct As Long ' tamaño en bytes del MIXERCONTROL dwControlID As Long ' id de control único del mixer dwControlType As Long ' MIXERCONTROL_CONTROLTYPE_xxx fdwControl As Long ' MIXERCONTROL_CONTROLF_xxx cMultipleItems As Long szShortName As String * MIXER_SHORT_NAME_CHARS ' nombre corto delControl szName As String * MIXER_LONG_NAME_CHARS ' nombre largo del control lMinimum As Long ' valor mínimo lMaximum As Long ' valor máximo reserved(10) As Long ' espacio reservado End Type Type MIXERCONTROLDETAILS cbStruct As Long ' tamaño en bytes de MIXERCONTROLDETAILS dwControlID As Long ' id del control cChannels As Long ' número de canales en el array paDetails item As Long ' hwndOwner o cMultipleItems cbDetails As Long ' tamaño de la estructura details_XX paDetails As Long ' puntero al array des estructuras details_XX End Type Type MIXERCONTROLDETAILS_UNSIGNED dwValue As Long ' valor del control End Type Type MIXERLINE cbStruct As Long ' tamaño de la estructura dwDestination As Long ' índice de destino (empieza en cero) dwSource As Long ' índice de origen (empieza en cero) dwLineID As Long ' id de línea único para el mixer fdwLine As Long ' estado/información de la línea dwUser As Long ' información específica del driver dwComponentType As Long ' component type line connects to cChannels As Long ' nº de canales de línea soportados cConnections As Long ' nº de conexiones posibles cControls As Long ' nº de controles en esta línea szShortName As String * MIXER_SHORT_NAME_CHARS szName As String * MIXER_LONG_NAME_CHARS dwType As Long dwDeviceID As Long wMid As Integer wPid As Integer vDriverVersion As Long szPname As String * MAXPNAMELEN End Type Type MIXERLINECONTROLS cbStruct As Long ' tamaño en bytes de MIXERLINECONTROLS dwLineID As Long ' id de línea (de MIXERLINE.dwLineID) ' MIXER_GETLINECONTROLSF_ONEBYID o dwControl As Long ' MIXER_GETLINECONTROLSF_ONEBYTYPE cControls As Long ' nº de controles pmxctrl en el array cbmxctrl As Long ' tamaño en bytes de un MIXERCONTROL pamxctrl As Long ' puntero al primer array MIXERCONTROL End Type Function GetVolumeControl(ByVal hmixer As Long, _ ByVal componentType As Long, _ ByVal ctrlType As Long, _ ByRef mxc As MIXERCONTROL) As Boolean ' Esta función intenta obtener un control mixer. ' Devuelve True si lo consigue Dim mxlc As MIXERLINECONTROLS Dim mxl As MIXERLINE Dim hmem As Long Dim rc As Long mxl.cbStruct = Len(mxl) mxl.dwComponentType = componentType ' Obtener una línea correspondiente al tipo de componente rc = mixerGetLineInfo(hmixer, mxl, MIXER_GETLINEINFOF_COMPONENTTYPE) If (MMSYSERR_NOERROR = rc) Then mxlc.cbStruct = Len(mxlc) mxlc.dwLineID = mxl.dwLineID mxlc.dwControl = ctrlType mxlc.cControls = 1 mxlc.cbmxctrl = Len(mxc) ' reservar un buffer para el control hmem = GlobalAlloc(&H40, Len(mxc)) mxlc.pamxctrl = GlobalLock(hmem) mxc.cbStruct = Len(mxc) ' Obtener el control rc = mixerGetLineControls(hmixer, mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE) If (MMSYSERR_NOERROR = rc) Then GetVolumeControl = True ' Copiar el control en la estructura de destino CopyStructFromPtr mxc, mxlc.pamxctrl, Len(mxc) Else GetVolumeControl = False End If GlobalFree (hmem) Exit Function End If GetVolumeControl = False End Function Function SetVolumeControl(ByVal hmixer As Long, mxc As MIXERCONTROL, _ ByVal volume As Long) As Boolean ' Esta función modifica el valor del volumen de un control ' Devuelve True si lo consigue Dim mxcd As MIXERCONTROLDETAILS Dim vol As MIXERCONTROLDETAILS_UNSIGNED mxcd.item = 0 mxcd.dwControlID = mxc.dwControlID mxcd.cbStruct = Len(mxcd) mxcd.cbDetails = Len(vol) ' Reservar espacio para el buffer del valor del control hmem = GlobalAlloc(&H40, Len(vol)) mxcd.paDetails = GlobalLock(hmem) mxcd.cChannels = 1 vol.dwValue = volume ' Copiar los datos en el buffer del valor del control CopyPtrFromStruct mxcd.paDetails, vol, Len(vol) ' Modificar el valor del control rc = mixerSetControlDetails(hmixer, mxcd, MIXER_SETCONTROLDETAILSF_VALUE) GlobalFree (hmem) If (MMSYSERR_NOERROR = rc) Then SetVolumeControl = True Else SetVolumeControl = False End If End Function
SaludosCódigo:Option Explicit Dim hmixer As Long ' handle del mixer Dim volCtrl As MIXERCONTROL ' control del volumen del waveout Dim micCtrl As MIXERCONTROL ' control del volumen del micrófono Dim rc As Long ' return code Dim ok As Boolean ' return code booleano Private Sub Form_Load() ' Abrir el mixer con deviceID 0. rc = mixerOpen(hmixer, 0, 0, 0, 0) If ((MMSYSERR_NOERROR <> rc)) Then MsgBox "Couldn't open the mixer." Exit Sub End If ' Obtener el control de volumen waveout ok = GetVolumeControl(hmixer, _ MIXERLINE_COMPONENTTYPE_DST_SPEAKERS, _ MIXERCONTROL_CONTROLTYPE_VOLUME, _ volCtrl) If (ok = True) Then ' Si todo fue bien los valores máximos y mínimo están especificados ' en lMaximum y lMinimum Label1.Caption = volCtrl.lMinimum & " a " & volCtrl.lMaximum End If ' Obtener el control de volumen del micrófono ok = GetVolumeControl(hmixer, _ MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE, _ MIXERCONTROL_CONTROLTYPE_VOLUME, _ micCtrl) If (ok = True) Then Label2.Caption = micCtrl.lMinimum & " a " & micCtrl.lMaximum End If End Sub Private Sub Slider1_Change() Dim vol As Long vol = Slider1.Value SetVolumeControl hmixer, volCtrl, vol * 6553 End Sub Private Sub Slider2_Change() Dim vol As Long vol = Slider2.Value SetVolumeControl hmixer, micCtrl, vol * 6553 End Sub
GRACIAS LEANDRO, VA PERFECTO,
Si agrego Option Explicit al módulo me dá como variables sin declarar en SetVolumeControl a hmem y rc (las declaré como Long ) y la constante MIXER_SETCONTROLDETAILSF_VALUE a la que declaré:
Public Const MIXER_SETCONTROLDETAILSF_VALUE = 0
GRACIAS + SALU2 D DESSA
Edited by: Dessa
LEANDRO: cuando puedas pasame code para los demas midi linea de audio
GRACIAS + SALU2 D DESSA