Public 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
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const SWP_NOACTIVATE = &H10
Public Const SWP_SHOWWINDOW = &H40
Public Const SWP_NOMOVE = 2
Public Const SWP_NOSIZE = 1
Private Sub Form_Load()
Dim R as long
R = SetWindowPos(NomFeuille.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
end sub
Private Sub Form_Activate()
Dim R as long
R = SetWindowPos(NomFeuille.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
end sub
Private sub SuppPriorité()
Dim R as long
R= SetWindowPos(NomFeuille.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End sub
Public Type POINTAPI
x As Long
y As Long
End Type
Public m_CursorPos As POINTAPI
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Sub GetCurseur()
Dim LonCStat As Long
LonCStat = GetCursorPos&(m_CursorPos)
'pour ce servir du résultat, les données doivent êtres transformées en Pixel.
m_CursorPos.x = m_CursorPos.x * Screen.TwipsPixelX
m_CursorPos.y = m_CursorPos.y * Screen.TwipsPixelY
End Sub
Option Explicit
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bDefaut As Byte, ByVal dwFlags As Long) As Long
Private Const GWL_EXSTYLE As Long = (-20)
Private Const LWA_COLORKEY As Long = &H1
Private Const LWA_Defaut As Long = &H2
Private Const WS_EX_LAYERED As Long = &H80000
'
Public Function Transparence(ByVal hWnd As Long, Optional ByVal Coul As Long = vbBlack, _
Optional ByVal PcTransp As Byte = 255, Optional ByVal TrMode As Boolean = True) As Boolean
' Retourne : True s'il n'y a pas eu d'erreur.
' hWnd : hWnd de la fenêtre à rendre transparente
' Coul : Couleur à rendre transparente si TrMode=False
' PcTransp : 0 à 255 >> 0 = transparent -:- 255 = Opaque
Dim VoirStyle As Long
On Error GoTo Sortie
VoirStyle = GetWindowLong(hWnd, GWL_EXSTYLE)
If VoirStyle <> (VoirStyle Or WS_EX_LAYERED) Then
VoirStyle = (VoirStyle Or WS_EX_LAYERED)
Call SetWindowLong(hWnd, GWL_EXSTYLE, VoirStyle)
End If
Transparence = (SetLayeredWindowAttributes(hWnd, Coul, PcTransp, IIf(TrMode, LWA_COLORKEY Or LWA_Defaut, LWA_COLORKEY)) <> 0)
Sortie:
If Not Err.Number = 0 Then Err.Clear
End Function
Public Sub ActiveTransparence(M As Form, d As Boolean, F As Boolean, _
T_Transparence As Integer, Optional Couleur As Long)
Dim B As Boolean
If d And F Then
'Rend la couleur (ici la couleur du fond de la forme) transparente
'au taux de T_Transparence
B = Transparence(M.hWnd, Couleur, T_Transparence, False)
ElseIf d Then
'Rend toute la forme, y compris les composants, transparente
'au taux de T_Transparence
B = Transparence(M.hWnd, 0, T_Transparence, True)
Else
'Restaure la forme opaque.
B = Transparence(M.hWnd, , 255, True)
End If
End Sub
Private Sub Form_Load()
Dim i As Integer
'Ex: tout transparent à 140/255ème
'ActiveTransparence Me, True, False, 140, Me.BackColor
'Ex: Forme transparent, composant visible à 140/255ème
'ActiveTransparence Me, True, True, 140, Me.BackColor
'Exemple d'affichage de la forme par gradation de la transparence
ActiveTransparence Me, True, False, 0
Me.Show
For i = 0 To 255 Step 3
ActiveTransparence Me, True, False, i
Me.Refresh
Next i
End Sub
'1 textBox Name = Text1
'1 CommandButton Name = Applique
' caption = Appliquer
'3 x OptionButton Name = Option1
' index = 0 : caption = Centrer
' index = 1 : caption = Mosaique
' index = 2 : caption = Etirer
Option Explicit
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 SPI_SETDESKWALLPAPER = 20
Const SPIF_UPDATEINIFILE = &H1
Const SPIF_SENDWININICHANGE = &H2
' API pour la base de registre:
' ---------------------------------------------
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal Hkey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal Hkey As Long, _
ByVal lpSubKey As String, phkResult 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, lpData As Any, ByVal cbData _
As Long) As Long
Const HKEY_CURRENT_USER = &H80000001
Const ERROR_SUCCESS = 0&
Const REG_SZ = 1
Dim NomFichier As String
Dim AffiType As Integer
Private Sub Applique_Click()
Dim Txt1 As String, Txt2 As String
Dim R As Long
Dim Hand As Long
' Gestion de l'erreur si pas d'image
On Error Resume Next
NomFichier = Text1.Text
' Mettre les options dans les régistres
Select Case AffiType
Case 0 ' Centrer
Txt1 = "0": Txt2 = "0"
Case 1 ' Mosaïque
Txt1 = "0": Txt2 = "1"
Case 2 ' Etirer
Txt1 = "2": Txt2 = "0"
End Select
R = RegCreateKey(HKEY_CURRENT_USER, "Control Panel\Desktop", Hand)
R = RegSetValueEx(Hand, "WallpaperStyle", 0, REG_SZ, ByVal Txt1, Len(Txt1))
R = RegCloseKey(Hand)
R = RegCreateKey(HKEY_CURRENT_USER, "Control Panel\Desktop", Hand)
R = RegSetValueEx(Hand, "TileWallpaper", 0, REG_SZ, ByVal Txt2, Len(Txt2))
R = RegCloseKey(Hand)
SystemParametersInfo SPI_SETDESKWALLPAPER, 0&, NomFichier, SPIF_UPDATEINIFILE Or _
SPIF_SENDWININICHANGE
End Sub
Private Sub Option1_Click(Index As Integer)
AffiType = Index
End Sub
Dim R as integer
Dim G as integer
Dim B as integer
Sub TrouveRGB(Coul As Long)
R = &HFF& And Coul
G = (&HFF00& And Coul ) \ 256
B = (&HFF0000 And Coul ) \ 65536
End Sub
Function TrouveCoul(R As Long, G As Long, B As Long) As Long
TrouveCoul = R + (G * 256) + (B * 65536)
End Function
Option Explicit
Const PS_SOLID = 0
Const Epp = 10 'épaisseur du trait
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, _
ByVal X As Long, ByVal Y As Long, lpPoint As Any) As Long
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
DeleteObject SelectObject(Me.hdc, CreatePen(PS_SOLID, Epp, RGB(0, 255, 0)))
MoveToEx Me.hdc, X, Y, &H0
End Sub
'Mettre ce code dans Form_MouseUp pour une ligne droite
'sans la ligne >> If Button <> 1 Then Exit Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button <> 1 Then Exit Sub
DeleteObject SelectObject(Me.hdc, CreatePen(PS_SOLID, Epp, RGB(0, 255, 0)))
LineTo Me.hdc, X, Y
Me.Refresh
End Sub
Option Explicit
Public Filtre1 As String
Public Filtre2 As String
Public Filtre3 As String
Public Filtre4 As String
Public Filtre5 As String
Public Filtre6 As String
Public Filtre7 As String
Public Const DLG_FILE_OPEN = 1
Public Const DLG_FILE_SAVE = 2
Public Const DLG_COLOR = 3
Public Const DLG_FONT = 4
Public Const DLG_Print = 5
Public Const DLG_HELP = 6
'File Open/Save Dialog Flags
Public Const OFN_READONLY = &H1&
Public Const OFN_OVERWRITEPROMPT = &H2&
Public Const OFN_HIDEREADONLY = &H4&
Public Const OFN_NOCHANGEDIR = &H8&
Public Const OFN_SHOWHELP = &H10&
Public Const OFN_NOVALIDATE = &H100&
Public Const OFN_ALLOWMULTISELECT = &H200&
Public Const OFN_EXTENSIONDIFFERENT = &H400&
Public Const OFN_PATHMUSTEXIST = &H800&
Public Const OFN_FILEMUSTEXIST = &H1000&
Public Const OFN_CREATEPROMPT = &H2000&
Public Const OFN_SHAREAWARE = &H4000&
Public Const OFN_NOREADONLYRETURN = &H8000&
'Color Dialog Flags
Public Const CC_RGBINIT = &H1&
Public Const CC_FULLOPEN = &H2&
Public Const CC_PREVENTFULLOPEN = &H4&
Public Const CC_SHOWHELP = &H8&
'Fonts Dialog Flags
Public Const CF_SCREENFONTS = &H1&
Public Const CF_PRINTERFONTS = &H2&
Public Const CF_BOTH = &H3&
Public Const CF_SHOWHELP = &H4&
Public Const CF_INITTOLOGFONTSTRUCT = &H40&
Public Const CF_USESTYLE = &H80&
Public Const CF_EFFECTS = &H100&
Public Const CF_APPLY = &H200&
Public Const CF_ANSIONLY = &H400&
Public Const CF_NOVECTORFONTS = &H800&
Public Const CF_NOSIMULATIONS = &H1000&
Public Const CF_LIMITSIZE = &H2000&
Public Const CF_FIXEDPITCHONLY = &H4000&
Public Const CF_WYSIWYG = &H8000& 'must also have CF_SCREENFONTS & CF_PRINTERFONTS
Public Const CF_FORCEFONTEXIST = &H10000
Public Const CF_SCALABLEONLY = &H20000
Public Const CF_TTONLY = &H40000
Public Const CF_NOFACESEL = &H80000
Public Const CF_NOSTYLESEL = &H100000
Public Const CF_NOSIZESEL = &H200000
'Printer Dialog Flags
Public Const PD_ALLPAGES = &H0&
Public Const PD_SELECTION = &H1&
Public Const PD_PAGENUMS = &H2&
Public Const PD_NOSELECTION = &H4&
Public Const PD_NOPAGENUMS = &H8&
Public Const PD_COLLATE = &H10&
Public Const PD_PRINTTOFILE = &H20&
Public Const PD_PRINTSETUP = &H40&
Public Const PD_NOWARNING = &H80&
Public Const PD_RETURNDC = &H100&
Public Const PD_RETURNIC = &H200&
Public Const PD_RETURNDEFAULT = &H400&
Public Const PD_SHOWHELP = &H800&
Public Const PD_USEDEVMODECOPIES = &H40000
Public Const PD_DISABLEPRINTTOFILE = &H80000
Public Const PD_HIDEPRINTTOFILE = &H100000
'Help Constants
Public Const HELP_CONTEXT = &H1 'Display topic in ulTopic
Public Const HELP_QUIT = &H2 'Terminate help
Public Const HELP_INDEX = &H3 'Display index
Public Const HELP_CONTENTS = &H3
Public Const HELP_HELPONHELP = &H4 'Display help on using help
Public Const HELP_SETINDEX = &H5 'Set the current Index for multi index help
Public Const HELP_SETCONTENTS = &H5
Public Const HELP_CONTEXTPOPUP = &H8
Public Const HELP_FORCEFILE = &H9
Public Const HELP_KEY = &H101 'Display topic for keyword in offabData
Public Const HELP_COMMAND = &H102
Public Const HELP_PARTIALKEY = &H105 'call the search engine in winhelp
Function ajoute(a$) As String
If a$ <> "" Then a$ = a$ + "|"
ajoute = a$
End Function
'Lignes d'appel...
'NomFichier = cmd_ouvre()
'Si 1 filtre en plus >> NomFichier = cmd_ouvre("txt") < par ex.
'Si plusieurs filtres, initialiser les filtres Filtre1 à 4
'la routine ajoute le filtre tous (*.*)
Function cmd_Ouvre(Optional Filt1 As String) As String
Dim CTRL$, a$, b$, F1$, F2$, F3$, F4$
CTRL$ = Chr$(13) + Chr$(10)
If Filt1 <> "" Then
a$ = " Fichier (*." & Filt1 & ") | *." & Filt1
End If
If Filtre1 <> "" Then
a$ = ajoute(a$)
a$ = a$ + " Fichier (*." & Filtre1 & ") | *." & Filtre1
Filtre1 = ""
End If
If Filtre2 <> "" Then
a$ = ajoute(a$)
a$ = a$ + " Fichier (*." & Filtre2 & ") | *." & Filtre2
Filtre2 = ""
End If
If Filtre3 <> "" Then
a$ = ajoute(a$)
a$ = a$ + " Fichier (*." & Filtre3 & ") | *." & Filtre3
Filtre3 = ""
End If
If Filtre4 <> "" Then
a$ = ajoute(a$)
a$ = a$ + " Fichier (*." & Filtre4 & ") | *." & Filtre4
Filtre4 = ""
End If
a$ = ajoute(a$)
a$ = a$ + " Tous (*.*) | *.*"
Dialog.CMDialog1.Filter = a$
Dialog.CMDialog1.FilterIndex = 1
Dialog.CMDialog1.FLAGS = CF_EFFECTS Or OFN_HIDEREADONLY Or CF_ANSIONLY
Dialog.CMDialog1.Action = DLG_FILE_OPEN
cmd_Ouvre = Dialog.CMDialog1.FileName
Unload Dialog
End Function
Function cmd_Police()
Dialog.CMDialog1.DialogTitle = "Sélection police"
Dialog.CMDialog1.FLAGS = CF_WYSIWYG + CF_BOTH + CF_SCALABLEONLY
Dialog.CMDialog1.Action = DLG_FONT
Filtre1 = Dialog.CMDialog1.FontName
Filtre4 = Dialog.CMDialog1.FontSize
Filtre5 = Dialog.CMDialog1.FontBold
Filtre6 = Dialog.CMDialog1.FontItalic
cmd_Police = Dialog.CMDialog1.FontName
End Function
Function cmd_Print()
Dialog.CMDialog1.FLAGS = PD_ALLPAGES
Dialog.CMDialog1.Min = 1
Dialog.CMDialog1.Max = 100
Dialog.CMDialog1.FromPage = 1
Dialog.CMDialog1.ToPage = 100
Dialog.CMDialog1.Action = DLG_Print
Unload Dialog
End Function
'Filt1 = extention des fichiers à chercher
'ex: TXT ou EXE
'la routine ajoute le filtre tous (*.*)
Function cmd_SaveAs(Filt1 As String) As String
Filtre1 = "Fichier (*." & Filt1 & ") | *." & Filt1
Filtre2 = "Tous (*.*) | *.*"
Dialog.CMDialog1.Filter = Filtre1 + "|" + Filtre2
Dialog.CMDialog1.FilterIndex = 1
Dialog.CMDialog1.FLAGS = OFN_HIDEREADONLY
Dialog.CMDialog1.Action = DLG_FILE_SAVE
cmd_SaveAs = Dialog.CMDialog1.FileName
Unload Dialog
End Function
Option Explicit
Private Type SHITEMID
cb As Long
abID As Byte
End Type
Private Type ITEMIDLIST
mkid As SHITEMID
End Type
Private Const CSIDL_PERSONAL As Long = &H5
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _
(ByVal hwndOwner As Long, ByVal nFolder As Long, _
pidl As ITEMIDLIST) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long
Public Function Rep_Documents() As String
Dim lRet As Long, IDL As ITEMIDLIST, sPath As String
lRet = SHGetSpecialFolderLocation(100&, CSIDL_PERSONAL, IDL)
If lRet = 0 Then
sPath = String$(512, Chr$(0))
lRet = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath)
Rep_Documents = Left$(sPath, InStr(sPath, Chr$(0)) - 1)
Else
Rep_Documents = vbNullString
End If
End Function
Private Sub CommandButton1_Click()
Cells(5, 2) = Rep_Documents()
End Sub
Dim sPathUser as String
sPathUser = Environ$("USERPROFILE") & "\mes documents\"
MsgBox sPathUser
REGSVR32 LN_BarPr.ocx
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowPlacement Lib "user32" (ByVal hWnd As Long, lpwndpl As WINDOWPLACEMENT) As Long
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type WINDOWPLACEMENT
Length As Long
FLAGS As Long
showCmd As Long
ptMinPosition As POINTAPI
ptMaxPosition As POINTAPI
rcNormalPosition As RECT
End Type
Public WinPlacement As WINDOWPLACEMENT
Sub GetTasckBarPlacement()
Dim TrayHwnd As Long
TrayHwnd = FindWindow("Shell_traywnd", "")
WinPlacement.Length = Len(WinPlacement)
GetWindowPlacement TrayHwnd, WinPlacement
End Sub
'==============================================================
'Sur la forme,
'4 TextBox propriété Tag de 1 à 4
'6 PictureBox propriété Tag de 1 à 6
'==============================================================
Public Class Form1
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
InitPic()
InitText()
End Sub
Sub InitText()
Dim Ctl As Control
Dim Txt As TextBox
Static NbAlea As Integer
NbAlea += 1 : If NbAlea > 4 Then NbAlea = 1
For Each Ctl In Me.Controls 'boucle sur tout les contrôles de la forme
If TypeOf Ctl Is TextBox Then 'Vérifie que c'est un textbox
Txt = Ctl
If Txt.Tag = NbAlea Then
'S'il n'y a que des TextBox sur la form il n'est pas nécessaire
'de passer par une variable buffer
Txt.Text = "c'est le TextBox : " & Txt.Name
Txt.BackColor = Color.Fuchsia
Else
Txt.Text = ""
Txt.BackColor = Color.Empty
End If
End If
Next
End Sub
Sub InitPic()
Dim Pic As Control
Dim Img As PictureBox
Static NbAlea As Integer
NbAlea += 1 : If NbAlea > 6 Then NbAlea = 1
'S'il n'y a que des pictureBox sur la form il n'est pas nécessaire
'de passer par une variable buffer
For Each Pic In Me.Controls 'boucle sur tout les contrôles de la forme
If TypeOf Pic Is PictureBox Then
Img = Pic
If Pic.Tag = NbAlea Then
Img.BackColor = Color.Aquamarine
Img.BorderStyle = BorderStyle.Fixed3D
'Img.Image = System.Drawing.Bitmap.FromFile(My.Application.Info.DirectoryPath & "\bt" & NbAlea & ".bmp")
'Img.SizeMode = PictureBoxSizeMode.StretchImage
Else
Img.BackColor = Color.Chocolate
Img.BorderStyle = BorderStyle.FixedSingle
End If
End If
Next
End Sub
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
InitText()
End Sub
Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
InitPic()
End Sub
End Class
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
Timer1.Interval = 1000
End Sub
Option Explicit
Private Const LB_SETHORIZONTALEXTENT = &H194
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Sub Form_Load()
Dim Lg As Integer, L As Integer, Va As String, i As Integer
'Remplir la list avec des lignes longues pour la démo
For i = 0 To 20
Va = Va & "Test" & i & " "
List1.AddItem Va
L = TextWidth(List1.List(i))
If Lg < TextWidth(List1.List(i)) Then Lg = L
Next
'Adapter les valeurs du scroll horizontal.
If Lg > List1.Width Then
HorizontalSrcoll List1, Lg
End If
End Sub
'Adapter les valeurs du scroll horizontal.
Private Sub HorizontalSrcoll(Lt As Control, Lg As Integer)
Dim Ret As Long
Dim ScrollMax As Long
ScrollMax = (Lg / Screen.TwipsPerPixelX) + 6
Ret = SendMessage(Lt.hwnd, LB_SETHORIZONTALEXTENT, ScrollMax, 0&)
End Sub