form1.frm

这里有很多很实用的VB编程案例,方便大家学习VB.

      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 Check1_Click()
    Dim rStyle As Long
    Dim r As Long
    rStyle = SendMessageLong(ListView1.hwnd, LVM_GETEXTENDEDLISTVIEWSTYLE, 0&, 0&)
    If Check1.Value = 0 Then
        rStyle = rStyle Xor LVS_EX_HEADERDRAGDROP
    ElseIf Check1.Value = 1 Then
        rStyle = rStyle Or LVS_EX_HEADERDRAGDROP
    End If
    r = SendMessageLong(ListView1.hwnd, LVM_SETEXTENDEDLISTVIEWSTYLE, 0&, rStyle)
End Sub

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

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

Private Sub Check4_Click()
   Dim r As Long
   Dim style As Long
   Dim hHeader As Long

   hHeader = SendMessageLong(ListView1.hwnd, LVM_GETHEADER, 0, ByVal 0&)
   style = GetWindowLong(hHeader, GWL_STYLE)
   style = style Xor HDS_BUTTONS
   If style Then
      r = SetWindowLong(hHeader, GWL_STYLE, style)
      r = SetWindowPos(ListView1.hwnd, Form1.hwnd, 0, 0, 0, 0, SWP_FLAGS)
   End If
End Sub

Private Sub Check5_Click()
   If Check5 Then
     imgPosition = HDF_BITMAP_ON_RIGHT
   Else: imgPosition = HDF_BITMAP
   End If
End Sub

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 Form_Load()
    Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
    With Combo1
        .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 4 Projects (*.vbp)"
        .AddItem "Text Files (*.txt)"
        .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()
  cmdselect(1).Enabled = fPath > ""
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


Private Sub chkOne_Click()
   Dim rStyle As Long
   Dim r As Long
    rStyle = SendMessageLong(ListView1.hwnd, LVM_GETEXTENDEDLISTVIEWSTYLE, 0&, 0&)
    rStyle = rStyle Or LVS_EX_ONECLICKACTIVATE
    r = SendMessageLong(ListView1.hwnd, LVM_SETEXTENDEDLISTVIEWSTYLE, 0&, rStyle)
End Sub
Private Sub chkTwo_Click()
    Dim rStyle As Long
    Dim r As Long
    rStyle = SendMessageLong(ListView1.hwnd, LVM_GETEXTENDEDLISTVIEWSTYLE, 0&, 0&)
    rStyle = rStyle Or LVS_EX_TWOCLICKACTIVATE
    r = SendMessageLong(ListView1.hwnd, LVM_SETEXTENDEDLISTVIEWSTYLE, 0&, rStyle)
End Sub