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
Versión para imprimir
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...
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...
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...
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.Cita:
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...
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:Cita:
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
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
Están bien declaradas como long, ya que la que devuelve el dato es GlobalAlloc y mixerSetControlDetails, y estas devuelven un Long
saludos
Gracias Luciano , la duda era la constante, pero aparentemente va bien
SALU2 D DESSA
http://www.howtogetridofacentreatments.com the only acne treatment that has ever worked for me! they offer a risk free trial, i have such smooth skin now!