veran hace pocas horas puse un post donde consegui solucionar una duda con la ruta de acseso, pues bien:
ahora resulta que la aplicacion que ando creando (la cual solo cambia el fondo del escritorio por la de una imagen que tenga en el cd ) me cambia solo 2 de las 4 imagenes que le tengo puestas y resulta que las 4 tienen las mismas medidas y son .bmp
el codigo que uso es el siguiente:
Código
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" _ (ByVal uAction As Long, ByVal uParam As Long, _ ByVal lpvParam As String, ByVal fuWinIni As Long) As Long Const SPIF_UPDATEINIFILE = &H1 Const SPI_SETDESKWALLPAPER = 20 Const SPIF_SENDWININICHANGE = &H2 Private Sub Picture1_Click() Dim FileName As String Dim X As Long 'Usa aquí el bitmap que quieres usar FileName = App.Path & "\fondo(1).bmp" X = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, FileName, _ SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE) End Sub Private Sub Picture2_Click() Dim FileName As String Dim X As Long 'Usa aquí el bitmap que quieres usar FileName = App.Path + "\fondo(2).bmp" X = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, FileName, _ SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE) End Sub Private Sub Picture3_Click() Dim FileName As String Dim X As Long 'Usa aquí el bitmap que quieres usar FileName = App.Path + "\fondo(3).bmp" X = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, FileName, _ SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE) End Sub Private Sub Picture4_Click() Dim FileName As String Dim X As Long 'Usa aquí el bitmap que quieres usar FileName = App.Path + "\fondo(4).bmp" X = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, FileName, _ SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE) End Sub son 4 picture box y en cada uno tengo una imagen diferente para cuando quiero cambiar una por otra solo bastaria con hacer click en uno de los picture box y se cambia automaticamente pero solo me funciona con dos de esos picture box espero haberme explicado con claridad amigos espero sus consejos.
Finalmente lo he solucionado
Encontre buscando en la web un codigo que modificando un poco la interface de mi software me ha funcionado perfectamente amigos.
solo elimine los picture box y añadi al proyecto un filelistbox, dos checkbox y algun que otro componente, finalmente modifique un poco mi codigo y voila, el programa me funciona a la perfeccion.
Aqui os pongo el codigo por si alguien mas quiere aprovecharlo, y si quieren el programa para testearlo solo envienme un email a:
pedraosone@yahoo.es y se lo remito encantado.
Código
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long Dim ruta As String Const SPIF_UPDATEINIFILE = 1 Const SPI_SETDESKWALLPAPER = 20 Const SPI_SETDESKPATTERN = 21 Const SPIF_SENDWININICHANGE = &H2 Private Sub Check1_Click() If Check1.Value = Checked Then Image1.Stretch = True Else Image1.Stretch = False End If End Sub Private Sub Check2_Click() Image1.Visible = Check2.Value End Sub Private Sub Command1_Click() Dim ruta As String If Right(File1.Path, 1) <> "" Then ruta = File1.Path & "\" & File1.FileName Else ruta = File1.Path & "\" & File1.FileName End If x = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, _ ruta, SPIF_UPDATEINIFILE Or _ SPIF_SENDWININICHANGE) End Sub Private Sub Command2_Click() Dim x As Long 'Para sacar el papel Tapiz se le envía una cadena vacía en lpvParam x = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, "", SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE) 'MsgBox "El fondo de pantalla ha sido quitado", 64 End Sub Private Sub File1_Click() On Error Resume Next Dim ruta As String If Right(File1.Path, 1) <> "" Then ruta = File1.Path & File1.FileName Else ruta = File1.Path & "\" & File1.FileName End If Image1.Picture = LoadPicture(ruta) Label1.Visible = True Label1.Caption = "Imagen: " + ruta End Sub Private Sub File1_DBLCLICK() On Error Resume Next Dim ruta As String If Right(File1.Path, 1) <> "" Then ruta = File1.Path & File1.FileName Else ruta = File1.Path & "\" & File1.FileName End If x = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, _ ruta, SPIF_UPDATEINIFILE Or _ SPIF_SENDWININICHANGE) Image1.Picture = LoadPicture(ruta) Label1.Visible = True Label1.Caption = "Imagen: " + ruta End Sub Private Sub File1_KeyPress(KeyAscii As Integer) If KeyAscii = 13 Then On Error Resume Next Dim ruta As String If Right(File1.Path, 1) = "\" Then ruta = File1.Path & File1.FileName Else ruta = File1.Path & "\" & File1.FileName End If x = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, _ ruta, SPIF_UPDATEINIFILE Or _ SPIF_SENDWININICHANGE) Image1.Picture = LoadPicture(ruta) Label1.Visible = True Label1.Caption = "Imagen: " + ruta End If End Sub Private Sub Form_KeyPress(KeyAscii As Integer) If KeyAscii = 27 Then End End If End Sub Private Sub Form_Resize() On Error Resume Next Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2 'Centra el formulario completamente End Sub
Espero que os sea tan util como me lo ha sido a mi, gracias.