form1.frm

来自「很好的教程原代码！」· FRM 代码 · 共 786 行 · 第 1/2 页

Private Sub Check6_Click()
    Dim rStyle As Long
    Dim r As Long
    rStyle = SendMessageLong(ListView1.hwnd, LVM_GETEXTENDEDLISTVIEWSTYLE, 0&, 0&)
    If Check6.Value = 0 Then
        rStyle = rStyle Xor LVS_EX_TRACKSELECT
    ElseIf Check6.Value = 1 Then
        rStyle = rStyle Or LVS_EX_TRACKSELECT
    End If
    r = SendMessageLong(ListView1.hwnd, LVM_SETEXTENDEDLISTVIEWSTYLE, 0&, rStyle)
End Sub

Private Sub chkHeaderFont_Click(Index As Integer)
    SetHeaderFontStyle
End Sub

Private Sub Command1_Click()
    If Check5.Enabled Then
        ShowHeaderIcon 1, 0, imgPosition, HDF_IMAGE
        Check5.Enabled = False
    Else
        Dim r As Long
        Dim colNo As Long
        Dim hHeader As Long
        Dim HD As HD_ITEM
        hHeader = SendMessageLong(ListView1.hwnd, LVM_GETHEADER, 0, 0)
        For colNo = 0 To ListView1.ColumnHeaders.Count - 1
            With HD
                .mask = HDI_FORMAT
                .fmt = HDF_LEFT Or HDF_STRING
                .pszText = ListView1.ColumnHeaders(colNo + 1).Text
            End With
            r = SendMessageAny(hHeader, HDM_SETITEM, colNo, HD)
        Next colNo
        Check5.Enabled = True
    End If
End Sub

Private Sub Command2_Click()
    SetHeaderFontStyle
End Sub

Private Sub Form_Load()
    Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
    With Combo1
        .AddItem "All Files and Folders (*.*)"
        .AddItem "Applications (*.exe)"
        .AddItem "Device Drivers (*.drv)"
        .AddItem "Documents (*.doc)"
        .AddItem "Dynamic Link Libraries (*.dll)"
        .AddItem "Rich Text Format Documents (*.rtf)"
        .AddItem "System Files (*.sys)"
        .AddItem "Visual Basic Modules (*.bas)"
        .AddItem "Visual Basic Forms (*.frm)"
        .AddItem "Visual Basic 3 Projects (*.mak)"
        .AddItem "Visual Basic 4 Projects (*.vbp)"
        .AddItem "Postscript Printer Font Metrics (*.pfm)"
        .AddItem "Text Files (*.txt)"
        .AddItem "True Type Fonts (*.ttf)"
        .AddItem "Windows Help Files (*.hlp)"
        .AddItem "Windows Shortcuts (*.lnk)"
        .ListIndex = 0
    End With
    With ListView1
      .SortKey = 0
      .SmallIcons = ImageList1
    End With
    UpdateFrequency = 25
    prevOrder = 0
End Sub

Private Sub cmdSelect_Click(Index As Integer)
    Select Case Index
        Case 0: fPath$ = vbGetBrowseDirectory$()
                If fPath$ > "" Then vbGetFileList
        Case 1: If fPath$ > "" Then vbGetFileList
        Case 2: Unload Me
                Set Form1 = Nothing
    End Select
End Sub

Private Sub Combo1_Click()
    If fPath > "" Then
        cmdselect(1).Enabled = True
    End If
End Sub

Private Function ValidateDir(tmpPath As String) As String
    If Right$(tmpPath, 1) = "\" Then
        ValidateDir = tmpPath
    Else
        ValidateDir = tmpPath & "\"
    End If
End Function


Private Function vbGetBrowseDirectory() As String
    Dim bi As BROWSEINFO
    Dim IDL As ITEMIDLIST
    Dim r As Long
    Dim pidl As Long
    Dim tmpPath As String
    Dim pos As Integer
    bi.hOwner = Form1.hwnd
    bi.pidlRoot = 0&
    bi.lpszTitle = "请选择路径： " & vbGetComboTargetType$() & "."
    bi.ulFlags = BIF_RETURNONLYFSDIRS
   '获取文件夹
    pidl = SHBrowseForFolder(bi)
    tmpPath = Space$(512)
    r = SHGetPathFromIDList(ByVal pidl, ByVal tmpPath)
    If r Then
          pos = InStr(tmpPath, Chr$(0))
          tmpPath = Left(tmpPath, pos - 1)
          vbGetBrowseDirectory = ValidateDir(tmpPath)
    Else: vbGetBrowseDirectory = ""
    End If
End Function

Private Function vbGetComboFileSpec$()
    Dim pos As Integer
    Dim lpos As Integer
    Dim item As String
    item = Combo1.List(Combo1.ListIndex)
    pos = InStr(item, "(") + 1
    lpos = InStr(item, ")") - pos
    vbGetComboFileSpec$ = Mid$(item, pos, lpos)
End Function

Private Function vbGetComboTargetType() As String
    Dim pos As Integer
    Dim item As String
    item = Combo1.List(Combo1.ListIndex)
    pos = InStr(item, "(") - 2
    vbGetComboTargetType = Left$(item, pos)
End Function

Private Function StripNulls(item As String) As String
    Dim pos As Integer
    pos = InStr(item, Chr$(0))
    If pos Then item = Left$(item, pos - 1)
    StripNulls = item
End Function
Private Sub vbGetFileList()
  Dim r As Long
    Dim hFile As Long
    Dim fName As String
    Dim fExt As String
    Dim counter As Integer
    Dim WFD As WIN32_FIND_DATA
    Me.MousePointer = vbArrowHourglass
    DoEvents
    fExt = vbGetComboFileSpec()
    If fPath > "" And fExt > "" Then
      fName = fPath & fExt
      displayname = fName
      DoEvents
      ListView1.ListItems.Clear
      DoEvents
      If InitializeImageList() Then
          ListView1.ListItems.Clear
          DoEvents
          hFile& = FindFirstFile(fName, WFD)
            If hFile& > 0 Then
              counter = 1
              vbAddFileItemView WFD
                While FindNextFile(hFile, WFD)
                  counter = counter + 1
                  vbAddFileItemView WFD
                  If counter = UpdateFrequency Then
                      r = UpdateWindow(ListView1.hwnd)
                      counter = 0
                  End If
                Wend
             End If
          FindClose hFile
        End If
    End If
    lbIconCount = "共有 " & _
                  ImageList1.ListImages.Count - 1 & " 个图标."
    lbItemCount = ListView1.ListItems.Count & " 个文件"
    cmdselect(1).Enabled = False
    DOSExeIconLoaded = False
    Me.MousePointer = vbDefault
End Sub
Private Sub vbAddFileItemView(WFD As WIN32_FIND_DATA)
    Dim sFileName As String
    Dim ListImgKey As String
    Dim fType As String
    sFileName = StripNulls(WFD.cFileName)
    If sFileName <> "." And sFileName <> ".." Then
        Dim r As Long
        Dim hInfo As Long
        Dim tExeType As Long
        Dim itmX As ListItem
        Dim hImgSmall As Long
        Dim hExeType As Long
        Dim imgX As ListImage
        On Local Error GoTo AddFileItemViewError
        hImgSmall& = SHGetFileInfo(fPath & sFileName, _
                       0&, shinfo, Len(shinfo), _
                       BASIC_SHGFI_FLAGS Or SHGFI_SMALLICON)
        fType$ = LCase$(StripNulls(shinfo.szTypeName))
        ListImgKey = fType
        If fType = "application" Or fType = "shortcut" Then
        If fType = "application" Then
          tExeType = SHGetFileInfo(fPath & sFileName, _
                          0&, shinfo, Len(shinfo), SHGFI_EXETYPE)
          hExeType = GetHiWord(tExeType)
        End If
        If hExeType > 0 Or fType = "shortcut" Then
              r = vbAddFileItemIcon(hImgSmall)
              Set imgX = ImageList1.ListImages.Add(, sFileName, pixSmall.Picture)
              ListImgKey = sFileName
        Else: ListImgKey = "DOSExeIcon"
              If DOSExeIconLoaded = False Then
                r = vbAddFileItemIcon(hImgSmall)
                Set imgX = ImageList1.ListImages.Add(, ListImgKey, pixSmall.Picture)
                DOSExeIconLoaded = True
        End If
        End If
      End If
      Set itmX = ListView1.ListItems.Add(, , LCase$(sFileName))
      itmX.SmallIcon = ImageList1.ListImages(ListImgKey).Key
      itmX.SubItems(1) = vbGetFileSizeKBStr(WFD.nFileSizeHigh + WFD.nFileSizeLow)
      itmX.SubItems(2) = fType
      itmX.SubItems(3) = vbGetFileDate(WFD.ftCreationTime)
      Set itmX = Nothing
      Set imgX = Nothing
  End If
  Exit Sub
AddFileItemViewError:
    If vbAddFileItemIcon(hImgSmall) Then
      Set imgX = ImageList1.ListImages.Add(, fType, pixSmall.Picture)
    End If
    Resume
End Sub
Private Function vbGetFileDate(CT As FILETIME) As String
    Dim ST As SYSTEMTIME
    Dim r As Long
    Dim ds As Single
    r = FileTimeToSystemTime(CT, ST)
        If r Then
          ds = DateSerial(ST.wYear, ST.wMonth, ST.wDay)
          vbGetFileDate$ = Format$(ds, "Short Date")
    Else: vbGetFileDate$ = ""
  End If
End Function
Private Function vbGetFileSizeKBStr(fsize As Long) As String
    vbGetFileSizeKBStr = Format$(((fsize) / 1000) + 0.5, "#,###,###") & "kb"
End Function

Private Sub Form_Unload(Cancel As Integer)
 If hHeaderFont > 0 Then
   Dim r As Long
   r = DeleteObject(hHeaderFont)
End If
End Sub

Private Sub ListView1_ColumnClick(ByVal ColumnHeader As ColumnHeader)
    Dim currSortKey As Integer
    ListView1.SortKey = ColumnHeader.Index - 1
    currSortKey = ListView1.SortKey
    ListView1.SortOrder = Abs(Not ListView1.SortOrder = 1)
    ListView1.Sorted = True
    mnuOrder(prevOrder).Checked = False
    mnuSortAZ.Checked = ListView1.SortOrder = 0
    mnuSortZA.Checked = mnuSortAZ.Checked = False
    If currSortKey > -1 Then
      mnuOrder(currSortKey).Checked = True
      prevOrder% = currSortKey
    End If
End Sub
Private Sub ListView1_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single)
    If Button = 2 Then PopupMenu mnuOptions
End Sub
Private Sub mnuOrder_Click(Index As Integer)
    mnuOrder(prevOrder).Checked = False
    mnuOrder(Index).Checked = True
    prevOrder = Index
    ListView1.SortKey = Index
    ListView1.SortOrder = 0
    ListView1.Sorted = True
    mnuSortAZ.Checked = ListView1.SortOrder = 0
    mnuSortZA.Checked = mnuSortAZ.Checked = False
End Sub
Private Sub mnuSortAZ_Click()
    ListView1.SortOrder = 0
    ListView1.Sorted = True
    mnuSortAZ.Checked = ListView1.SortOrder = 0
    mnuSortZA.Checked = mnuSortAZ.Checked = False
End Sub
Private Sub mnuSortZA_Click()
    ListView1.SortOrder = 1
    ListView1.Sorted = True
    mnuSortAZ.Checked = ListView1.SortOrder = 0
    mnuSortZA.Checked = mnuSortAZ.Checked = False
End Sub
Private Sub mnuView_Click(Index As Integer)
    mnuView(ListView1.View - 2).Checked = False
    mnuView(Index).Checked = True
    ListView1.View = Index + 2
    ListView1.Sorted = True
End Sub

Function GetHiWord(dw As Long) As Integer
  If dw And &H80000000 Then
          GetHiWord = (dw \ 65535) - 1
  Else: GetHiWord = dw \ 65535
  End If
End Function
Private Function InitializeImageList() As Boolean
    On Local Error GoTo InitializeError
      Set ListView1.SmallIcons = Nothing
      ImageList1.ListImages.Clear
      ImageList1.ListImages.Add , "dummy", pixDummy.Picture
      Set ListView1.SmallIcons = ImageList1
      InitializeImageList = True
      Exit Function
InitializeError:
      InitializeImageList = False
End Function
Private Function vbAddFileItemIcon(hImgSmall&) As Long
    Dim r As Long
    pixSmall.Picture = LoadPicture()
    r& = ImageList_Draw(hImgSmall&, shinfo.iIcon, pixSmall.hdc, 0, 0, ILD_TRANSPARENT)
    pixSmall.Picture = pixSmall.Image
    vbAddFileItemIcon& = hImgSmall&
End Function
Public Sub ShowHeaderIcon(colNo As Long, imgIconNo As Long, _
    justify As Long, showImage As Long)
    Dim r As Long
    Dim hHeader As Long
    Dim HD As HD_ITEM
    hHeader = SendMessageLong(ListView1.hwnd, LVM_GETHEADER, 0, 0)
    With HD
      .mask = HDI_IMAGE Or HDI_FORMAT
      .fmt = HDF_LEFT Or HDF_STRING Or justify Or showImage
      .pszText = ListView1.ColumnHeaders(colNo + 1).Text
      If showImage Then .iImage = imgIconNo
   End With
   '修改标题
   r = SendMessageAny(hHeader, HDM_SETITEM, colNo, HD)
End Sub

Private Sub SetHeaderFontStyle()
   Dim LF As LOGFONT
   Dim r As Long
   Dim hCurrFont As Long
   Dim hOldFont As Long
   Dim hHeader As Long
  '获取Windows句柄
   hHeader = SendMessageLong(ListView1.hwnd, LVM_GETHEADER, 0, 0)
  '获取字体返回的句柄
   hCurrFont = SendMessageLong(hHeader, WM_GETFONT, 0, 0)
   r = GetObject(hCurrFont, Len(LF), LF)
   If r > 0 Then
     '设置字体
      If chkHeaderFont(optBold).Value = 1 Then
        LF.lfWeight = FW_BOLD
      Else: LF.lfWeight = FW_NORMAL
      End If
      LF.lfItalic = chkHeaderFont(optItalic).Value = 1
      LF.lfUnderline = chkHeaderFont(optUnderlined).Value = 1
      LF.lfStrikeOut = chkHeaderFont(optStrikeout).Value = 1
      r = DeleteObject(hHeaderFont)
      hHeaderFont = CreateFontIndirect(LF)
      hOldFont = SelectObject(hHeader, hHeaderFont)
      r = SendMessageLong(hHeader, WM_SETFONT, hHeaderFont, True)
      End If
End Sub
Private Sub chkOne_Click()
   Dim rStyle As Long
   Dim r As Long
   '获取当前ListView控件类型
    rStyle = SendMessageLong(ListView1.hwnd, LVM_GETEXTENDEDLISTVIEWSTYLE, 0&, 0&)
   '设置扩展类型
    rStyle = rStyle Or LVS_EX_ONECLICKACTIVATE
   '设置ListView类型
    r = SendMessageLong(ListView1.hwnd, LVM_SETEXTENDEDLISTVIEWSTYLE, 0&, rStyle)
End Sub
Private Sub chkTwo_Click()
    Dim rStyle As Long
    Dim r As Long
   '获取当前ListView控件类型
    rStyle = SendMessageLong(ListView1.hwnd, LVM_GETEXTENDEDLISTVIEWSTYLE, 0&, 0&)
   '设置扩展类型
    rStyle = rStyle Or LVS_EX_TWOCLICKACTIVATE
   '设置ListView类型
    r = SendMessageLong(ListView1.hwnd, LVM_SETEXTENDEDLISTVIEWSTYLE, 0&, rStyle)
End Sub