Soyez le premier à donner votre avis sur cette source.
Vue 5 989 fois - Téléchargée 590 fois
#### FRMMAIN #### Option Explicit Dim intLauch As Integer Private Sub Form_Load() ' Initialisation du titre de la fenetre lblTitre.Caption = " Le " & Date & " à " & Time ' Charge le pense bete ChargePenseBete ' Initialise la variable blnShow blnShow = False App.TaskVisible = False intLauch = 0 End Sub Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Static rec As Boolean, msg As Long 'Se produit lorsque l'utilisateur agit avec la souris sur 'l'icône placée dans le système tray msg = X / Screen.TwipsPerPixelX If rec = False Then rec = True Select Case msg Case DOUBLE_CLICK_GAUCHE: Case BOUTON_GAUCHE_POUSSE: Case BOUTON_GAUCHE_LEVE: ' Verifie si la fenetre est visible ou non If blnShow = False Then ' Affiche la fenetre Timer2.Enabled = True Else lblFerme_Click (0) End If Case DOUBLE_CLICK_DROIT: Case BOUTON_DROIT_POUSSE: Case BOUTON_DROIT_LEVE: PopupMenu frmMenu.menu, , , , frmMenu.mnuAffiche End Select rec = False End If End Sub Private Sub lblFerme_Click(Index As Integer) If Index = 0 Then ' Enregistre le pense bete EnregPenseBete ' Cache la fenetre Timer2.Enabled = True ElseIf Index = 1 Then MsgBox A_PROPOS, vbInformation, "A propos" End If End Sub Private Sub lblFerme_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) ' Si le bouton est appuyer il devient Rouge lblFerme(Index).ForeColor = vbRed End Sub Private Sub lblFerme_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) ' Si le bouton est relacher il devient Noir lblFerme(Index).ForeColor = vbBlack End Sub Private Sub lblTitre_DblClick() lblFerme_Click (0) End Sub Private Sub Timer1_Timer() ' Affiche l'heure et la date dans la barre de titre lblTitre.Caption = " Le " & Date & " à " & Time End Sub Private Sub Timer2_Timer() If intLauch = 0 Then Me.Top = Screen.Height - Me.Height + Me.Height Me.Show intLauch = 1 End If If blnShow = False Then If Me.Top >= Screen.Height - Me.Height - 399 Then Me.Move Me.Left, Me.Top - 82 Else Timer2.Enabled = False blnShow = True frmMenu.mnuAffiche.Caption = MNUAFFICHE_CAPTION_CACHE End If Else If Me.Top <= Screen.Height - Me.Height + Me.Height Then Me.Move Me.Left, Me.Top + 82 Else Timer2.Enabled = False blnShow = False frmMenu.mnuAffiche.Caption = MNUAFFICHE_CAPTION_AFFICHE End If End If End Sub #### FRMMENU #### Private Sub mnuAffiche_Click() ' Verifie sur la fenetre et visible ou pas If blnShow = False Then frmMain.Timer2.Enabled = True Else EnregPenseBete frmMain.Timer2.Enabled = True End If End Sub Private Sub mnuFerme_Click() ' Ferme complement l'application EnregPenseBete EnleveDuSystray End End Sub Private Sub mnuLoad_Click() Dim strm As TextStream On Error Resume Next CD.DialogTitle = "Ouvrir un Fichier Texte" CD.Filter = "Fichier Texte (*.txt)|*.txt" CD.ShowOpen ' Si l'utilisateur a bien choisi un fichier, ' ouverture et lecture de celui-ci If CD.FileName <> "" Then Set strm = fso.OpenTextFile(CD.FileName) ' Ouverture With strm frmMain.Text1.Text = .ReadAll ' Lit et inscrit dans txtSaisie .Close ' Fermeture End With End If EnregPenseBete End Sub Private Sub mnuSave_Click() Dim strm As TextStream Dim fnew As String ' Les erreurs seront ignorées On Error Resume Next CD.Filter = "Fichier Texte (*.txt)|*.txt" CD.ShowSave If CD.FileName <> "" Then With fso ' Crée le nouveau fichier fnew = .BuildPath(.GetParentFolderName(CD.FileName), _ CD.FileTitle) Set strm = .CreateTextFile(fnew, True) End With End If With strm ' Ecrit le texte dans le fichier .Write frmMain.Text1.Text .Close End With End Sub #### MODULE1 #### Option Explicit ' Déclarations d'API Public Declare Sub 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) Public Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As IconeTray) As Boolean Public Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long ' Types Public Type IconeTray cbSize As Long ' Taille de l'icone (en octets) hWnd As Long ' Handle de la fenêtre qui va recevoir les messages envoyés lors des évènements sur l'icone (clique-droite, double-clique...) uID As Long ' Identificateur de l'icône uFlags As Long uCallbackMessage As Long ' Messages à renvoyer hIcon As Long ' Handle de l'icône qui apparaitra dans le systray szTip As String * 64 ' Texte à mettre dans l'info bulle de l'icone End Type Public ISystray As IconeTray ' Constantes Public Const HWND_TOPMOST = -&H1 ' Affiche en 1er plan Public Const HWND_NOTOPMOST = -&H2 ' Affiche pas en 1er plan Public Const SWP_NOSIZE = &H1 Public Const SWP_NOMOVE = &H2 Public Const AJOUT = &H0 Public Const MODIF = &H1 Public Const SUPPRIME = &H2 Public Const MOUSEMOVE = &H200 Public Const MESSAGE = &H1 Public Const Icone = &H2 Public Const TIP = &H4 Public Const DOUBLE_CLICK_GAUCHE = &H203 Public Const BOUTON_GAUCHE_POUSSE = &H201 Public Const BOUTON_GAUCHE_LEVE = &H202 Public Const DOUBLE_CLICK_DROIT = &H206 Public Const BOUTON_DROIT_POUSSE = &H204 Public Const BOUTON_DROIT_LEVE = &H205 Public Const MNUAFFICHE_CAPTION_CACHE = "Cacher le Pense Bête" Public Const MNUAFFICHE_CAPTION_AFFICHE = "Afficher le Pense Bête" Public Const A_PROPOS = "Pense Bete" & vbCrLf & "Editeur : Julien" ' Variables ' Pour activer la référence "FileSystemObject" : ' Projet / Référence... / Cocher "Microsoft Scripting Runtime" Public fso As New FileSystemObject Public blnShow As Boolean Sub Main() ' Met la fenetre au 1er plan SetWindowPos frmMain.hWnd, HWND_TOPMOST, 0&, 0&, 0&, 0&, (SWP_NOSIZE Or SWP_NOMOVE) MetDansLeSystray ' Initialise la taille et la position de la fenetre With frmMain .Width = .Text1.Width .Height = .Text1.Height + .Picture1.Height .Top = Screen.Height - .Height - 400 .Left = Screen.Width - .Width End With ' Cache la fenetre frmMain.Hide End Sub Public Function MetDansLeSystray() ' Initialisation de ISystray ISystray.cbSize = Len(ISystray) ISystray.hWnd = frmMain.hWnd ISystray.uID = 1& ISystray.uFlags = Icone Or TIP Or MESSAGE ISystray.uCallbackMessage = MOUSEMOVE ISystray.hIcon = frmMain.Icon ISystray.szTip = "Pense Bête" & Chr$(0) ' Appel de l'api pour que l'icone se mette dans le systray Shell_NotifyIcon AJOUT, ISystray End Function Public Function EnleveDuSystray() ' Preparation de ISystray ISystray.cbSize = Len(ISystray) ISystray.hWnd = frmMain.hWnd ISystray.uID = 1& ' Retire l'icone du systray Shell_NotifyIcon SUPPRIME, ISystray End Function Public Function SystemDirectory() As String ' Retourne le chemin du répertoire système (ex: C:/WINDOWS/System32/) Dim stTmp As String, lgTmp As Long stTmp = Space$(250) lgTmp = 251 GetSystemDirectory stTmp, lgTmp SystemDirectory = Split(stTmp, Chr$(0))(0) End Function Public Function EnregPenseBete() Dim strm As TextStream Dim fnew As String ' Les erreurs seront ignorées On Error Resume Next ' Cree un nouveau fichier dans le dossier system pour ne pas le perdre With fso fnew = .BuildPath(SystemDirectory, "PenseBete.dat") Set strm = .CreateTextFile(fnew, True) End With ' Ecrit la valeur de Text1 With strm .Write (frmMain.Text1.Text) .Close End With End Function Public Function ChargePenseBete() Dim strm As TextStream ' Les erreurs seront ignorées On Error Resume Next ' Ouvre le fichier Set strm = fso.OpenTextFile(SystemDirectory & "\PenseBete.dat") ' Affecte la valeur du fichier a Text1 With strm frmMain.Text1.Text = .ReadAll .Close End With End Function
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.