Publicité

Pour cette exemple, nous avons créé un nouveau projet contenant une feuille et un module.

La feuille:
Insérez dans cette feuille un objet DriveListBox (nommé Lecteur), un DirListBox (Répertoire), un FileListBox (Fichier) et deux PictureBox.(VisioImg et VisioImgHid).

Les événements:

Au chargement de la feuille:
Private Sub Form_Load()
   ' Initialisation du lecteur par défaut
   Me.Lecteur.Drive = "c:\"

   ' Définition des formats d'images acceptés
   Me.Fichier.Pattern = "*.jpg;*.jpeg;*.gif;*.wmf;*.bmp"

   ' Définition des propriétés de l'objet VisioImg
   ' L'objet se redessine automatiquement,
   ' mais sa taille ne s'adapte pas automatiquement à l'image,
   ' les dimension sont données en pixel
   Me.VisioImg.AutoRedraw = True
   Me.VisioImg.AutoSize = False
   Me.VisioImg.ScaleMode = 3
   ' Définition des propriétés de l'objet VisioImgHid
   ' L'objet se redessine automatiquement,
   ' mais sa taille s'adapte automatiquement à l'image,
   ' l'objet n'est pas visible
   ' les dimension sont données en pixel
   Me.VisioImgHid.AutoRedraw = True
   Me.VisioImgHid.AutoSize = True
   Me.VisioImgHid.Visible = False
   Me.VisioImgHid.ScaleMode = 3

   ' Mémorisation des dimension d'origine dans des variables globales
   OnStartWidth = Me.VisioImg.ScaleWidth
   OnStartHeight = Me.VisioImg.ScaleHeight

   ' StatusB est une barre de status (label) utilisée pour diffuser des commentaires
   Me.StatusB.ForeColor = &H0&
   Me.StatusB.Caption = " Choisissez une image."
End Sub

Lors d'un changement de lecteur:
Private Sub Lecteur_Change()
   Dim OldPath As String
   Dim NouvLecteur As String

   ' En cas d'erreur de lecture, se rendre au label ErrLect
   On Error GoTo ErrLect
   OldPath = Me.Repertoire.Path
   NouvLecteur = Me.Lecteur.Drive

   ' Modification du chemin de parcours du répertoire
   Me.Repertoire.Path = NouvLecteur
   Me.Repertoire.Refresh
   ' Sorie de la routine
   Exit Sub
ErrLect:
   ' Il y a eu une erreur, récupération de l'nacien chemin et de l'ancien lecteur
   ' Affichage de l'erreur
   Me.Lecteur.Drive = Left(OldPath, 2)
   Me.Repertoire.Path = OldPath
   MsgBox "Le lecteur " & NouvLecteur & " n'est pas prêt !", vbOKOnly, "Erreur"
End Sub

Lors d'un changemant de répertoire:
Private Sub Repertoire_Change()
   ' Modification du chemin de listage des fichiers
   Me.Fichier.Path = Me.Repertoire.Path
   Me.Fichier.Refresh
End Sub

Lors du choix d'un fichier:
Private Sub Fichier_Click()
   ' Modification des commentaires et du pointer de souris
   Me.StatusB.ForeColor = &H0&
   Me.StatusB.Caption = " Chargemant en cours...       Récupération du chemin du fichier."
   Me.MousePointer = 11

   ' Masque l'image le temps du traitemant
   Me.VisioImg.Visible = False
   ' Récupération du chemin et du nom du fichier
   ImgSrc = Dir_AddSep(Me.Fichier.Path) & Me.Fichier.filename
   
   Me.StatusB.Caption = " Chargemant en cours...       " & ImgSrc
   DoEvents
   ' Mise à zerro de l'image principale et chargement de l'image secondaire
   Me.VisioImg.Picture = LoadPicture()
   Me.VisioImgHid.Picture = LoadPicture(ImgSrc)
   DoEvents

   ' Copie l'image secondaire vers l'image principale avec mise à l'échelle
   If CopieImage(Me.VisioImg, Me.VisioImgHid, OnStartHeight, OnStartWidth) Then
      ' La copie à réussie, affichage de l'image
      Me.VisioImg.Visible = True
      Me.StatusB.Caption = " Choisissez une nouvelle image.       Image courante : " & ImgSrc
   Else
      ' La copie à échouée, affichage de l'erreur
      Me.StatusB.ForeColor = &HFF&
      Me.StatusB.Caption = " Erreur lors de l'affichage de l'image !       Choisissez une autre image."
   End If
   DoEvents

   ' Initialisation de l'image secondaire, affichage du pointeur par défault
   Me.VisioImgHid.Picture = LoadPicture()
   Me.MousePointer = 0
   DoEvents
End Sub

Le module:

' Déclaration des API nécessaires au traitemant de l'image
Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

' Déclaration des constantes
Global Const gstrSEP_DIR$ = "\"                   ' Séparateur de dossier
Public Const gstrSEP_URL$ = "://"                ' Séparateur qui suit HPPT dans les adresses URL
Public Const gstrSEP_URLDIR$ = "/"                ' Séparateur séparant les dossiers dans les adresses URL.
Public Const SRCCOPY = &HCC0020

' Déclaration des variables globales
Global OnStartWidth As Long
Global OnStartHeight As Long
Global ImgSrc As String

Function CopieImage(CtrlDest As Object, CtrlSrc As Object, MaxHeight As Long, MaxWidth As Long) As Boolean
   ' Fonction de copie de l'image avec mise à l'échelle
   Dim SrcHeight As Long
   Dim SrcWidth As Long
   Dim DestHeight As Long
   Dim DestWidth As Long
   Dim I As Long
   Dim J As Long
   Dim CopieStep As Double
   Dim XRDC As Long
   Dim XBB As Long

   CopieImage = True
   ' En cas d'erreur se rendre au label ErrCopieImage
   On Error GoTo ErrCopieImage
      ' récupération des dimension de l'image secondaire
      SrcHeight = CtrlSrc.ScaleHeight
      SrcWidth = CtrlSrc.ScaleWidth

      If (SrcWidth > MaxWidth) Then
         ' Si la largeur est trop grande pour la taille de la fenêtre
         ' On fixe de nouvelles dimensions à l'image
         DestHeight = CLng(MaxWidth * SrcHeight / SrcWidth)
         DestWidth = MaxWidth

         If (DestHeight > MaxHeight) Then
            ' Si après modifcation, la hauteur est trop grande
            ' On fixe de nouvelles dimensions à l'image
            DestWidth = CLng(MaxHeight * SrcWidth / SrcHeight)
            DestHeight = MaxHeight
         End If
      ElseIf (SrcHeight > MaxHeight) Then
         ' Si la largeur est correcte, mais pas la hauteur
         ' On fixe de nouvelles dimensions à l'image
         DestWidth = CLng(MaxHeight * SrcWidth / SrcHeight)
         DestHeight = MaxHeight
      Else
         ' Sinon, on concerve la taille d'origine de l'image
         DestHeight = SrcHeight
         DestWidth = SrcWidth
      End If

      ' Redimentionnement de l'image principale
      CtrlDest.ScaleHeight = DestHeight
      CtrlDest.ScaleWidth = DestWidth

      ' Détermine le pas pour la mise à l'échelle
      CopieStep = SrcWidth / DestWidth

      ' Pour chaque ligne de l'image principale
      For I = 0 To DestHeight
         ' Pour chaque colonne de chaque ligne de l'image principale
         '    soit chaque pixel de l'image principale
         For J = 0 To DestWidth
            ' Copier dans l'image principale à la position (J;I), un pixel
            ' à partir du pixel à la position (J x CopieStep;I x CopieStep), de l'image secondaire
            XBB = BitBlt(CtrlDest.hdc, J, I, 1, 1, CtrlSrc.hdc, CLng(J * CopieStep), CLng(I * CopieStep), SRCCOPY)
         Next J
      Next I
      XRDC = ReleaseDC(CtrlSrc.hWnd, CtrlDest.hdc)
      CtrlDest.Refresh
      
   On Error GoTo 0
   Exit Function
ErrCopieImage:
   ' La copie à échouée
   CopieImage = False
End Function

Function Dir_AddSep(ByVal strPathName As String) As String
' Ajoute un séparateur de chemin de dossier (barre oblique inverse) à la fin de la ligne, sauf s'il y en a déjà un.

   If Right(Trim(strPathName), Len(gstrSEP_URLDIR)) <> gstrSEP_URLDIR And _
      Right(Trim(strPathName), Len(gstrSEP_DIR)) <> gstrSEP_DIR Then
      Dir_AddSep = RTrim$(strPathName) & gstrSEP_DIR
   Else
    Dir_AddSep = strPathName
   End If
End Function

Télécharger le source