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

Có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

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 idea
y use un picture para pintarlo ya que si utilizaba estas apis

Código:

brocha = CreateSolidBrush(vbred)
SelectObject Me.hdc, brocha
Rectangle Me.hdc, 0, 0, 100, 100

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 asigne


Saludos

Iniciado por Dessa

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"

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.

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:

Có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

...Pero estamos en la misma que la de Leandro, el área se pinta de color blanco, ni idea por que

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

Iniciado por 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

Si lo que buscabas era simplemente deshabilitar el boton y el comando cerrar de la ventana ahi te sobra codigo:

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

Salu2...

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

Có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

Saludos

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

Có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

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 lParam

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

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

y en un formulario con dos slider y 4 Labels (despues vos acomodalo a tus nesesidades)

Có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

Saludos

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