Soyez le premier à donner votre avis sur cette source.
Vue 11 073 fois - Téléchargée 1 292 fois
Option Explicit Public Enum LvImageOption Nop = 0 IndexOnly = 2 ImageAndIndex = 3 End Enum Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type LvSaveOption Appaerence As Boolean Font As Boolean Position As Boolean Images As Long SmallImages As Long End Type Private Type LvSubItem index As Long Caption As String End Type Private Type LvImage ImgData() As Byte End Type Private Type LvFont sName As String Bold As Boolean Italic As Boolean Size As Long Strikethrough As Boolean Underline As Boolean End Type Private Type LvItem Caption As String Key As String SubItemCount As Long SubItems() As LvSubItem index As Long ImageIndex As Long SmallImageIndex As Long End Type Private Type Column index As Long Caption As String width As Single Key As String End Type Private Type LvStruct View As Long ForeColor As Long ExtendedStyle As Long LabelEdit As Long Appearance As Long Arrange As Long BackColor As Long BorderStyle As Long Pos As RECT Font As LvFont ImageList() As LvImage SmallImageList() As LvImage ImageCount As Long SmallImageCount As Long ItemCount As Long ColumCount As Long Items() As LvItem Colums() As Column SaveOption As LvSaveOption End Type Private Type BITMAP bmType As Long bmWidth As Long bmHeight As Long bmWidthBytes As Long bmPlanes As Integer bmBitsPixel As Integer bmBits As Long End Type Private Declare Function PathFileExistsA Lib "shlwapi.dll" (ByVal pszPath As String) As Long Private Declare Function DeleteFileA Lib "KERNEL32" (ByVal lpFileName As String) As Long Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) 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 Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, lParam As Any) As Long Private Type LVITEMA mask As Long iItem As Long iSubItem As Long State As Long stateMask As Long pszText As String cchTextMax As Long iImage As Long lParam As Long iIndent As Long End Type Private Const LVM_FIRST As Long = &H1000& Private Const LVM_SETITEMTEXT As Long = (LVM_FIRST + 46) Private Const LVM_GETITEMTEXT As Long = (LVM_FIRST + 45) Private Const LVM_SETEXTENDEDLISTVIEWSTYLE As Long = (LVM_FIRST + 54) Private Const LVM_GETEXTENDEDLISTVIEWSTYLE As Long = (LVM_FIRST + 55) Private LvStruc As LvStruct Private Lv As ListView Public Property Let SaveAppaerence(ByVal Value As Boolean) LvStruc.SaveOption.Appaerence = Value End Property Public Property Let SaveFont(ByVal Value As Boolean) LvStruc.SaveOption.Font = Value End Property Public Property Let SavePosition(ByVal Value As Boolean) LvStruc.SaveOption.Position = Value End Property Public Property Let SaveImages(ByVal Value As LvImageOption) LvStruc.SaveOption.Images = Value End Property Public Property Let SaveSmallImages(ByVal Value As LvImageOption) LvStruc.SaveOption.SmallImages = Value End Property Public Function LvToFile(LstView As ListView, ByVal sFile As String, Optional ImgList As ImageList, Optional SmallImgList As ImageList) As Long Dim i As Long Dim j As Long Dim Litem As LVITEMA Set Lv = LstView With LvStruc If .SaveOption.Appaerence = True Then GetAppearence If .SaveOption.Font = True Then GetFont If .SaveOption.Position Then GetWindowRect Lv.hwnd, .Pos If .SaveOption.Images = ImageAndIndex Then .ImageCount = GetImgList(ImgList, .ImageList) If .SaveOption.SmallImages = ImageAndIndex Then .SmallImageCount = GetImgList(SmallImgList, .SmallImageList) .ColumCount = Lv.ColumnHeaders.Count .ItemCount = Lv.ListItems.Count ReDim .Colums(.ColumCount) ReDim .Items(.ItemCount) For i = 0 To .ItemCount - 1 .Items(i).Caption = Lv.ListItems(i + 1).Text .Items(i).index = i + 1 .Items(i).SubItemCount = .ColumCount .Items(i).SmallImageIndex = Lv.ListItems(i + 1).SmallIcon .Items(i).ImageIndex = Lv.ListItems(i + 1).Icon If .SaveOption.SmallImages > 0 Then .Items(i).SmallImageIndex = Lv.ListItems(i + 1).SmallIcon If .SaveOption.Images > 0 Then .Items(i).ImageIndex = Lv.ListItems(i + 1).Icon ReDim .Items(i).SubItems(.Items(i).SubItemCount) For j = 0 To .Items(i).SubItemCount - 1 Litem.iItem = i + 1 Litem.iSubItem = j + 1 Litem.cchTextMax = 255 Litem.pszText = String$(255, 0) Call SendMessage(Lv.hwnd, LVM_GETITEMTEXT, i, Litem) .Items(i).SubItems(j).Caption = Left$(Litem.pszText, InStr(1, Litem.pszText, Chr$(0)) - 1) .Items(i).SubItems(j).index = j + 1 Next j Next i For i = 0 To .ColumCount - 1 .Colums(i).Caption = Lv.ColumnHeaders(i + 1).Text .Colums(i).width = Lv.ColumnHeaders(i + 1).width .Colums(i).index = Lv.ColumnHeaders(i + 1).index .Colums(i).Key = Lv.ColumnHeaders(i + 1).Key Next i End With Set Lv = Nothing DeleteFileA sFile Open sFile For Binary As #1 Put #1, , LvStruc Close #1 Erase LvStruc.ImageList Erase LvStruc.SmallImageList Erase LvStruc.Items End Function Public Function FileToLv(LstView As ListView, ByVal sFile As String, Optional ImgList As ImageList, Optional SmallImgList As ImageList, Optional TmpPicBox As PictureBox) As Long Dim i As Long Dim j As Long Dim Lvi As ListItem Dim Litem As LVITEMA If PathFileExistsA(sFile) = 0 Then MsgBox "Error file not found!", vbCritical: Exit Function Set Lv = LstView Open sFile For Binary As #1 Get #1, , LvStruc Close #1 With LvStruc If .SaveOption.Appaerence Then SetAppearence If .SaveOption.Font Then SetFont If .SaveOption.Position = True Then SetWindowPos Lv.hwnd, 0, .Pos.Left, .Pos.Top, .Pos.Right - .Pos.Left, .Pos.Bottom - .Pos.Top, 0 If .SaveOption.Images = ImageAndIndex Then SetImgList .ImageList, ImgList, TmpPicBox If .SaveOption.SmallImages = ImageAndIndex Then If .SaveOption.Images = ImageAndIndex Then If ImgList.Name <> SmallImgList.Name Then SetImgList .SmallImageList, SmallImgList, TmpPicBox End If Else SetImgList .SmallImageList, SmallImgList, TmpPicBox End If End If For i = 0 To .ColumCount - 1 If .ColumCount > Lv.ColumnHeaders.Count Then Lv.ColumnHeaders.Add .Colums(i).index, .Colums(i).Key, .Colums(i).Caption, .Colums(i).width Else Lv.ColumnHeaders(.Colums(i).index).Key = .Colums(i).Key Lv.ColumnHeaders(.Colums(i).index).width = .Colums(i).width Lv.ColumnHeaders(.Colums(i).index).Text = .Colums(i).Caption End If Next i For i = 0 To .ItemCount - 1 Set Lvi = Lv.ListItems.Add(, , .Items(i).Caption) If .SaveOption.Images > 0 Then Lvi.Icon = LvStruc.Items(i).ImageIndex If .SaveOption.SmallImages > 0 Then Lvi.SmallIcon = .Items(i).SmallImageIndex For j = 0 To .Items(i).SubItemCount - 1 Litem.iItem = i + 1 Litem.iSubItem = j + 1 Litem.cchTextMax = Len(.Items(i).SubItems(j).Caption) Litem.pszText = .Items(i).SubItems(j).Caption Call SendMessage(Lv.hwnd, LVM_SETITEMTEXT, i, Litem) Next j Next i End With Erase LvStruc.ImageList Erase LvStruc.SmallImageList Erase LvStruc.Items Set Lvi = Nothing Set Lv = Nothing End Function Private Sub GetAppearence() LvStruc.Appearance = Lv.Appearance LvStruc.Arrange = Lv.Arrange LvStruc.ExtendedStyle = GetListViewExtendedStyle(Lv.hwnd) LvStruc.BackColor = Lv.BackColor LvStruc.BorderStyle = Lv.BorderStyle LvStruc.ForeColor = Lv.ForeColor LvStruc.LabelEdit = Lv.LabelEdit LvStruc.View = Lv.View End Sub Private Sub SetAppearence() Lv.Appearance = LvStruc.Appearance Lv.Arrange = LvStruc.Arrange SetListViewExtendedStyle Lv.hwnd, LvStruc.ExtendedStyle Lv.BackColor = LvStruc.BackColor Lv.BorderStyle = LvStruc.BorderStyle Lv.ForeColor = LvStruc.ForeColor Lv.LabelEdit = LvStruc.LabelEdit Lv.View = LvStruc.View End Sub Private Sub GetFont() LvStruc.Font.Bold = Lv.Font.Bold LvStruc.Font.Italic = Lv.Font.Italic LvStruc.Font.Size = Lv.Font.Size LvStruc.Font.sName = Lv.Font.Name LvStruc.Font.Strikethrough = Lv.Font.Strikethrough LvStruc.Font.Underline = Lv.Font.Underline End Sub Private Sub SetFont() Lv.Font.Bold = LvStruc.Font.Bold Lv.Font.Italic = LvStruc.Font.Italic Lv.Font.Size = LvStruc.Font.Size Lv.Font.Name = LvStruc.Font.sName Lv.Font.Strikethrough = LvStruc.Font.Strikethrough Lv.Font.Underline = LvStruc.Font.Underline End Sub Private Sub SetImgList(LvImglist() As LvImage, ImList As ImageList, TmpPicBox As PictureBox) Dim i As Long TmpPicBox.Picture = TmpPicBox.Image If ImList.ListImages.Count < UBound(LvImglist) Then For i = 0 To UBound(LvImglist) SetBitmapBits TmpPicBox.Picture.Handle, UBound(LvImglist(i).ImgData), LvImglist(i).ImgData(0) ImList.ListImages.Add , , TmpPicBox.Picture Next i End If End Sub Private Function GetImgList(ImgList As ImageList, LvImageList() As LvImage) As Long Dim BMP As BITMAP Dim Size As Long Dim b() As Byte Dim icn As IPictureDisp Dim l As Long Dim i As Long l = ImgList.ListImages.Count ReDim LvImageList(l - 1) For i = 0 To l - 1 Set icn = ImgList.Overlay(i + 1, i + 1) GetObject icn.Handle, Len(BMP), BMP Size = BMP.bmWidth * BMP.bmHeight * BMP.bmBitsPixel \ BMP.bmPlanes ReDim LvImageList(i).ImgData(Size) GetBitmapBits icn.Handle, Size, LvImageList(i).ImgData(0) Next i Set icn = Nothing GetImgList = l End Function Private Function SetListViewExtendedStyle(ByVal LvHandle As Long, ByVal lvMask As Long) Call SendMessage(LvHandle, LVM_SETEXTENDEDLISTVIEWSTYLE, lvMask, ByVal -1) End Function Private Function GetListViewExtendedStyle(ByVal LvHandle As Long) GetListViewExtendedStyle = SendMessage(LvHandle, LVM_GETEXTENDEDLISTVIEWSTYLE, ByVal 0&, ByVal 0&) End Function
29 mai 2007 à 15:24
27 mai 2007 à 19:49
j'ai mis le code a jour, il est maintemant compatible Common Control 5 et 6
j'ai aussi fais un module de classe et mis une verification de la presence du fichier avant le load...
++
25 mai 2007 à 14:37
PCPT> pour les points manquants je l'ai dis dans la description, j'ai mis les principaux mais il est tres facile d'en ajouter...
Pour les params optionel dans le Load c'est fait expres, pour plus de souplesse...
Pour la classe, oui ce serait sans doutes plus pratique, mais j'ai une alergie aux classe lol
Sinon pour les objets j'ai en effet oublié de supprimer un LVI et de mettre un copymem pour detruire la structure je corrigerais ca quand j'aurais une minute ;)
ciberrique> Merci et content que ca te plaise :)
Eb> eh wai en effet le property bag est une solution mais la seule fois ou j'ai voulu l'utiliser ca m'a vite soulé...
Je vais quand meme regarder quand j'aurais le temps
Merci pour vos commentaires
++
25 mai 2007 à 12:45
@+
25 mai 2007 à 09:52
8/10
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.