整理机器时发现，偶在以前参与的一些贴子！特此放上来！

TreeView中如何选中一个父节点同时选中所有的子节点和孙节点。。。
'----------------------------------------------------------------------------
'
'Author:lihonggen0
'Date:2003-1-20
'功能：选择Treeview节点下所有节点
'----------------------------------------------------------------------------

Private Sub Form_Load()
    TreeView1.Checkboxes = True
    TreeView1.Nodes.Add , "R", "root", "root"
    TreeView1.Nodes.Add "root", tvwChild, "key1", "aa"
    TreeView1.Nodes.Add "key1", tvwChild, "key11", "ccc"

    TreeView1.Nodes.Add "root", tvwChild, "key2", "bb"
    TreeView1.Nodes.Add "key2", tvwChild, "key21", "ddd"
    TreeView1.Nodes.Add "key2", tvwChild, "key211", "eee"
    For I = 1 To TreeView1.Nodes.Count
        TreeView1.Nodes(I).Expanded = True
    Next
End Sub
 
Private Sub CheckChild(ByVal Node As MSComctlLib.Node, ByVal bCheck As Boolean, Optional ByVal bNext As Boolean = True, Optional ByVal bChild As Boolean = True)
     If Not Node Is Nothing Then
        Node.Checked = bCheck
        If Node.Children And bChild Then
                Call CheckChild(Node.Child, bCheck, True, True)        '对子节点
        End If
        If bNext Then
            Call CheckChild(Node.Next, bCheck, True, bChild)          '对同一层节点
        End If
     End If
End Sub

Private Sub TreeView1_NodeCheck(ByVal Node As MSComctlLib.Node)
    Call CheckChild(Node, Node.Checked, False, True)                    '处理子节点
End Sub
我恰好刚写了一个，用递归。

Private Sub trvRules_NodeCheck(ByVal Node As MSComctlLib.Node)
    Dim i As Long
    Dim NodX As Node
    Set NodX = Node
   
    '这里是处理如果该节点的子节点被选掉，则该父节点以至于上溯到根节点都被选掉
    Do While NodX.Root <> NodX
        If NodX.Checked = False And NodX.Root <> NodX Then NodX.Parent.Checked = False
        Set NodX = NodX.Parent
    Loop
    '使用递归，把该节点的字节点都选中
    If Node.Children > 0 Then
        For i = Node.Child.FirstSibling.Index To Node.Child.LastSibling.Index
            trvRules.Nodes.Item(i).Checked = Node.Checked
            Call trvRules_NodeCheck(trvRules.Nodes.Item(i))
        Next i
    End If
    Set NodX = Nothing
End Sub

可能有些细节要改改。

请教：怎样把flexGrid中的数据导入excel中

'********************************************************* 
'*  名称：OutDataToExcel 
'*  功能：将MsFlexGrid控件中显示的内容输出到Excel表格中进行打印 
'********************************************************* 
Public  Sub  OutDataToExcel(Flex  As  MSFlexGrid)        '导出至Excel 
       Dim  s  As  String 
       Dim  i  As  Integer 
       Dim  j  As  Integer 
       Dim  k  As  Integer 
       On  Error  GoTo  Ert 
       Me.MousePointer  =  11 
       Dim  Excelapp  As  Excel.Application 
       Set  Excelapp  =  New  Excel.Application 
       On  Error  Resume  Next 
       DoEvents 
       Excelapp.SheetsInNewWorkbook  =  1 
       Excelapp.Workbooks.Add 
       Excelapp.ActiveSheet.Cells(1,  3)  =  s 
       Excelapp.Range("C1").Select 
       Excelapp.Selection.Font.FontStyle  =  "Bold" 
       Excelapp.Selection.Font.Size  =  16 
       With  Flex 
               k  =  .Rows 
               For  i  =  0  To  k  -  1 
                       For  j  =  0  To  .Cols  -  1 
                             DoEvents 
                             Excelapp.ActiveSheet.Cells(3  +  i,  j  +  1)  =  "'"  &  .TextMatrix(i,  j) 
                       Next  j 
               Next  i 
       End  With 
       Me.MousePointer  =  0 
       Excelapp.Visible  =  True 
       Excelapp.Sheets.PrintPreview               
Ert: 
       If  Not  (Excelapp  Is  Nothing)  Then 
               Excelapp.Quit 
       End  If 
End  Sub 

请问高手门，怎样从用SQL语句返回表中的有那些子段名
Rs_Colums.Open "select top 1 * from table", Cn, adOpenStatic, adLockReadOnly
                For I = 0 To Rs_Colums.Fields.Count - 1   ' 循环所有列
                    Debug.Print Rs_Colums.Fields(I).Name   '字段名
                    Debug.Print Rs_Colums.Fields(I).DefinedSize  '宽度
                Next
                Rs_Colums.Close

SQL SERVER:
可以这样得到表中的所有字段名

SELECT SYSCOLUMNS.name FROM SYSCOLUMNS  LEFT OUTER JOIN SYSOBJECTS  ON SYSCOLUMNS.id = SYSOBJECTS.id WHERE SYSOBJECTS.xtype = 'u' and SYSOBJECTS.name='表名'

急，如何在win2000中添加用户？


Private Sub Form_Load()

Set wsh3 = CreateObject("WScript.Shell")
wsh3.Run "net user lihonggen /add", 4, True

End Sub

怎么把一个目录下的所有文件的文件名导出，最好列到execl表里！！！

'----------------------------------------------------------------------------
'
'Author:lihonggen0
'Date:2003-6-18
'功能：把一个目录下的所有文件的文件名导出c:/file.txt
'----------------------------------------------------------------------------

Private Function AutoListFiles(ByVal sDirName As String, ByVal FileFilter As String) As Boolean
    On Error GoTo RF_ERROR
    Dim sName As String, sFile As String, sExt As String
    Dim sDirList() As String, iDirNum As Integer, I As Integer
    '首先枚举所有文件
    sFile = Dir(sDirName + FileFilter, vbNormal + vbArchive + vbHidden)
    Do While Len(sFile) > 0
        sFile = UCase(Trim(sFile))
        Debug.Print sFile
      
        Open "c:/file.txt" For Append As #1
        Print #1, , sFile
        Close #1

        sFile = Dir '下一个文件
    Loop
   
RF_EXIT:
    AutoListFiles = True
    Exit Function
RF_ERROR:
    MsgBox Err.Description, vbCritical, ""
    Resume RF_EXIT
End Function

Private Sub Command1_Click()
Dim bln   As Boolean

bln = AutoListFiles("f:/", "*.*")
End Sub

'----------------------------------------------------------------------------
'
'Author:lihonggen0
'Date:2003-6-20
'功能：把一个目录下的所有文件的文件名导出到execl表
'----------------------------------------------------------------------------

Private Function AutoListFiles(ByVal sDirName As String, ByVal FileFilter As String) As Boolean

    On Error GoTo RF_ERROR
   
   
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet

    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets(1)

       
    Dim sName As String, sFile As String, sExt As String
    Dim sDirList() As String, iDirNum As Integer, I As Integer
   
    '首先枚举所有文件
    sFile = Dir(sDirName + FileFilter, vbNormal + vbArchive + vbHidden)
    I = 1
    Do While Len(sFile) > 0
        sFile = UCase(Trim(sFile))
        Debug.Print sFile
        xlSheet.Cells(I, 2).Value = sFile
        I = I + 1

        sFile = Dir '下一个文件
    Loop
        xlApp.Application.Visible = True
        '交还控制给Excel
    Set xlApp = Nothing
RF_EXIT:
    AutoListFiles = True
    Set xlApp = Nothing
    Exit Function
RF_ERROR:
    MsgBox Err.Description, vbCritical, ""
    Resume RF_EXIT
End Function

Private Sub Command1_Click()
Dim bln   As Boolean
'将F:/盘根目录下的所有文件和目录列出来
bln = AutoListFiles("f:/", "*.*")
End Sub

能否在DATAGRID控件中加入CHECKBOX控件?
'----------------------------------------------------------------------------
'
'Auth:lihonggen0
'Date:2003-6-18
'功能：DataGrid1上附加COMBO和CheckBox
'在form上添加一个DataGrid1、一个COMBO和一个CheckBox控件放到屏幕上任何位置都可以
'----------------------------------------------------------------------------

Private Sub DataGrid1_RowColChange(LastRow As Variant, ByVal LastCol As Integer)
    Select Case DataGrid1.Col
        Case 1
            Check1.Visible = False
            Combo1.Visible = True
            Combo1.Width = DataGrid1.Columns(DataGrid1.Col).Width + 50
            Combo1.Left = DataGrid1.Left + DataGrid1.Columns(DataGrid1.Col).Left
            Combo1.Top = DataGrid1.Top + DataGrid1.Row * (DataGrid1.RowHeight) + (DataGrid1.HeadLines) * 195
            Combo1.SetFocus
            If DataGrid1.Columns(DataGrid1.Col).Text <> "" Then
                Combo1.Text = DataGrid1.Columns(DataGrid1.Col).Text
            End If
        Case 2
            Check1.Visible = True
            Check1.Width = DataGrid1.Columns(DataGrid1.Col).Width + 50
            Check1.Left = DataGrid1.Left + DataGrid1.Columns(DataGrid1.Col).Left
            Check1.Top = DataGrid1.Top + DataGrid1.Row * (DataGrid1.RowHeight) + (DataGrid1.HeadLines) * 195
            Check1.SetFocus
            Combo1.Visible = False
        Case Else
            Combo1.Visible = False
            Check1.Visible = False
    End Select

End Sub

Private Sub Form_Load()
'工程--->引用--->Microsoft ActiveX Data Object 2.x（版本号）

    Dim CN   As New ADODB.Connection                '定义数据库的连接
    Dim Rs   As New ADODB.Recordset
    CN.ConnectionString = "Provider=sqloledb;Data Source=pmserver;Initial Catalog=northwind;User Id=sa;Password=sa;"

    CN.Open
    Rs.CursorLocation = adUseClient
    Rs.Open "select * from employees", CN, adOpenDynamic, adLockOptimistic

   Set DataGrid1.DataSource = Rs
End Sub

[求助]请教VB高手：怎样用VB将DataGrid控件中的查询结果存入Excel表中
下面给出一个实例：

首先建立一个窗体（FORM1）在窗体中加入一个DATA控件和一按钮，

引用Microsoft Excel类型库:

从"工程"菜单中选择"引用"栏;

选择Microsoft Excel X.0 Object Library;

选择"确定"。

在FORM的LOAD事件中加入：
　　Data1.DatabaseName = 数据库名称
　　Data1.RecordSource = 表名
　　Data1.Refresh

在按钮的CLICK事件中加入
　　Dim Irow, Icol As Integer
　　Dim Irowcount, Icolcount As Integer
　　Dim Fieldlen() "存字段长度值
　　Dim xlApp As Excel.Application
　　Dim xlBook As Excel.Workbook
　　Dim xlSheet As Excel.Worksheet

　　Set xlApp = CreateObject("Excel.Application")
　　Set xlBook = xlApp.Workbooks.Add
　　Set xlSheet = xlBook.Worksheets(1)

　　With Data1.Recordset
　　.MoveLast

　　If .RecordCount < 1 Then
　　　　MsgBox ("Error 没有记录!")
　　　　Exit Sub
　　End If

　　Irowcount = .RecordCount "记录总数
　　Icolcount = .Fields.Count "字段总数

　　ReDim Fieldlen(Icolcount)
　　.MoveFirst

 

　　For Irow = 1 To Irowcount + 1
　　　For Icol = 1 To Icolcount
　　Select Case Irow
　　Case 1 "在Excel中的第一行加标题
　　xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1).Name
　　Case 2 "将数组FIELDLEN()存为第一条记录的字段长

　　If IsNull(.Fields(Icol - 1)) = True Then
　　　　Fieldlen(Icol) = LenB(.Fields(Icol - 1).Name)
　　　　　"如果字段值为NULL,则将数组Filelen(Icol)的值设为标题名的宽度
　　Else
　　　　Fieldlen(Icol) = LenB(.Fields(Icol - 1))
　　End If

　　xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
　　　"Excel列宽等于字段长
　　xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1)
　　　"向Excel的CellS中写入字段值
　　Case Else
　　Fieldlen1 = LenB(.Fields(Icol - 1))

　　If Fieldlen(Icol) < Fieldlen1 Then
　　xlSheet.Columns(Icol).ColumnWidth = Fieldlen1
　　　"表格列宽等于较长字段长
　　Fieldlen(Icol) = Fieldlen1
　　　"数组Fieldlen(Icol)中存放最大字段长度值
　　Else
　　　xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
　　End If

　　xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1)
　　End Select
　　Next
　　If Irow <> 1 Then
　　If Not .EOF Then .MoveNext
　　End If
　　Next
　　With xlSheet
　　.Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Name = "黑体"
　　　"设标题为黑体字
　　.Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Bold = True
　　　"标题字体加粗
　　.Range(.Cells(1, 1), .Cells(Irow, Icol - 1)).Borders.LineStyle = xlContinuous
　　　"设表格边框样式
　　End With
　　xlApp.Visible = True "显示表格
　　xlBook.Save "保存
　　Set xlApp = Nothing "交还控制给Excel
　　End With
制作一个进度条，平面型的，怎么实现
------------------------------------------------------------------
个人专栏：http://www.csdn.net/develop/author/netauthor/lihonggen0/
------------------------------------------------------------------
在窗体上添加一个command ，一个pictrue box

 

Dim tenth As Long
'条件编译
#If Win32 Then
Private 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
#Else
Private Declare Function BitBlt Lib "GDI" (ByVal hDestDC As _
Integer, ByVal x As Integer, ByVal y As Integer, ByVal nWidth _
As Integer, ByVal nHeight As Integer, ByVal hSrcDC As Integer, _
ByVal xSrc As Integer, ByVal ySrc As Integer, ByVal dwRop As _
Long) As Integer
#End If
Sub UpdateStatus(FileBytes As Long)
'--------------------------------------------------------------------
' 更新Picture1 status bar
'--------------------------------------------------------------------
Static progress As Long
Dim r As Long
Const SRCCOPY = &HCC0020
Dim Txt$
progress = progress + FileBytes
If progress > Picture1.ScaleWidth Then
progress = Picture1.ScaleWidth
End If
Txt$ = Format$(CLng((progress / Picture1.ScaleWidth) * 100)) + "%"
Picture1.Cls
Picture1.CurrentX = _
(Picture1.ScaleWidth - Picture1.TextWidth(Txt$)) / 2
Picture1.CurrentY = _
(Picture1.ScaleHeight - Picture1.TextHeight(Txt$)) / 2
Picture1.Print Txt$
Picture1.Line (0, 0)-(progress, Picture1.ScaleHeight), _
Picture1.ForeColor, BF
r = BitBlt(Picture1.hDC, 0, 0, Picture1.ScaleWidth, _
Picture1.ScaleHeight, Picture1.hDC, 0, 0, SRCCOPY)
End Sub
Private Sub Command1_Click()
Picture1.ScaleWidth = 109
tenth = 10
For i = 1 To 11
Call UpdateStatus(tenth)
x = Timer
While Timer < x + 0.75
DoEvents
Wend
Next
End Sub
Private Sub Form_Load()
Picture1.FontBold = True
Picture1.AutoRedraw = True
Picture1.BackColor = vbWhite
Picture1.DrawMode = 10
Picture1.FillStyle = 0
Picture1.ForeColor = vbBlue
End Sub
怎样将 listview 中的项 拖到 treeview 中?
'--------------------------------------------------------------
'请大家提问前多搜索以前的贴子
'Author:lihonggen0
'http://www.csdn.net/develop/author/netauthor/lihonggen0/
'本实例要在窗体上加一个listview和一treeview
'--------------------------------------------------------------
Option Explicit

Private Sub Form_Load()
TreeView1.Nodes.Add , , "aa", "aa"
TreeView1.Nodes.Add , , "bb", "bb"
ListView1.ListItems.Add , , "cc"
ListView1.ListItems.Add , , "dd"
ListView1.OLEDragMode = ccOLEDragAutomatic
ListView1.LabelEdit = lvwManual
End Sub
Private Sub ListView1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbLeftButton Then
  ListView1.DragIcon = ListView1.SelectedItem.CreateDragImage
  ListView1.Drag vbBeginDrag
End If
End Sub
Private Sub TreeView1_DragDrop(Source As Control, x As Single, y As Single)
If Not TreeView1.DropHighlight Is Nothing Then
  TreeView1.Nodes.Add TreeView1.DropHighlight.Key, tvwChild, GetNextKey() & ListView1.SelectedItem.Text, ListView1.SelectedItem.Text
  TreeView1.DropHighlight.Expanded = True
End If
End Sub
Private Sub TreeView1_DragOver(Source As Control, x As Single, y As Single, State As Integer)
Set TreeView1.DropHighlight = TreeView1.HitTest(x, y)
End Sub
Private Function GetNextKey() As String
Dim sNewKey As String
Dim iHold As Integer
Dim i As Integer
On Error GoTo myerr
iHold = Val(TreeView1.Nodes(1).Key)
For i = 1 To TreeView1.Nodes.Count
    If Val(TreeView1.Nodes(i).Key) > iHold Then
      iHold = Val(TreeView1.Nodes(i).Key)
    End If
Next
iHold = iHold + 1
sNewKey = CStr(iHold) & "_"
GetNextKey = sNewKey
Exit Function
myerr:
GetNextKey = "1_"
End Function
怎样确定一个数据库中的各张表？
'----------------------------------------------------------------------------
'
'Author:lihonggen0
'Date:2003-6-19
'功能：获取access库中表的个数及表的名称
'用ado怎样实现
'工程--->引用--->Microsoft ActiveX Data Object 2.x（版本号）
'----------------------------------------------------------------------------
Private Sub Form_Load()
Dim adoCN   As New ADODB.Connection                '定义数据库的连接
Dim strCnn   As New ADODB.Recordset
Dim I As Integer
   str1 = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:/Northwind.MDB;Persist Security Info=False"
   adoCN.Open str1
        
   Set rstSchema = adoCN.OpenSchema(adSchemaTables)
    
   Do Until rstSchema.EOF
        If rstSchema!TABLE_TYPE = "TABLE" Then
           out = out & "Table  name:  " & _
               rstSchema!TABLE_NAME & vbCr & _
               "Table  type:  " & rstSchema!TABLE_TYPE & vbCr
            I = I + 1
        End If
        rstSchema.MoveNext
   Loop
   MsgBox I
   rstSchema.Close
    
   adoCN.Close
Debug.Print out
End Sub
'----------------------------------------------------------------------------
'
'Author:lihonggen0
'Date:2003-6-19
'功能：获取access库中表的个数及表的名称
'用ado怎样实现
'工程--->引用--->Microsoft ActiveX Data Object 2.x（版本号）
'----------------------------------------------------------------------------
Private Sub Form_Load()
Dim adoCN   As New ADODB.Connection                '定义数据库的连接
Dim strCnn   As New ADODB.Recordset
Dim I As Integer
   str1 = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:/Northwind.MDB;Persist Security Info=False"
   adoCN.Open str1
        
   Set rstSchema = adoCN.OpenSchema(adSchemaTables)
    
   Do Until rstSchema.EOF
        If rstSchema!TABLE_TYPE = "TABLE" Then
           out = out & "Table  name:  " & _
               rstSchema!TABLE_NAME & vbCr & _
               "Table  type:  " & rstSchema!TABLE_TYPE & vbCr
            I = I + 1
        End If
        rstSchema.MoveNext
   Loop
   MsgBox I
   rstSchema.Close
    
   adoCN.Close
Debug.Print out
End Sub

如何让对话框(CommonDialog)显示在屏幕中心?

VB中的CommonDialog可实现Open、Print等功能，但其位置无法调整到父窗口中心或屏幕中心，请问有何办法修改这些对话框的位置？

回答:

    如果是在C++或Delphi中，可以使用钩子(hook)函数，然后在钩子函数中设置对话框的位置。不过在VB中使用钩子(hook)函数就麻烦了，这是VB的弱项。不过VB也有自己的办法。要想解决这个问题，首先要找出CommonDialog是如何设置其对话框位置。首先在一个Form中放置一个CommonDialog控件，然后不断移动Form在屏幕的位置，并激活CommonDialog。你会发现CommonDialog总是出现在Form的左上角，当Form出现在屏幕的左侧或上部时，这一点非常明显。但当Form出现在屏幕下方或右侧时，CommonDialog会稍微做调整，以确保整个对话框都能显示在屏幕范围内。如果你的Form比较靠近屏幕中心，那么CommonDialog自然也会出现在屏幕中心。利用这一特点，我们可以建立一个空窗体，称为MyCDForm，然后在其上放置一个CommonDialog控件。这个MyCDForm只用来放置CommonDialog控件，没有其他用途。然后输入下面这个函数。
    Private Function ChooseFile(argLeft As Single, argTop As Single) As Boolean
     ' 设置为没有文件被选择
     ChooseFile = False
     ' 移动MyCDForm位置
     MyCDForm.Left = argLeft
     MyCDForm.Top = argTop
     ' 设置CommonDialog控件
     MyCDForm!CommonDialog1.CancelError = True
     On Error GoTo OpenError
     ' 显示CommonDialog
     MyCDForm!CommonDialog1.ShowOpen
     ' 卸载MyCDForm
     Unload MyCDForm
     ChooseFile = True
     Exit Function
    OpenError:
     ' 用户按下Cancel键
     Unload MyCDForm
     Exit Function
    End Function
    当你的程序需要调用Open对话框时，使用ChooseFile就可以了。argLeft和argTop是Open对话框在屏幕上出现的位置的左上角的坐标。从这个函数可以看出，实际上我们是将MyCDForm的位置该为argLeft和argTop，而利用Open对话框的位置总是出现在其父窗口的左上角这一特性来改变Open对话框的屏幕位置。类似地，你也可以显示其他的对话框。如果你想让对话框出现在屏幕中央，则argLeft = (Screen.Width - 对话框宽度) / 2，argTop = (Screen.Height - 对话框高度) / 2。对于屏幕大小为800*600个像素，显示Open对话框的情况，这两个值大致均为1500。
    如果在VB中也希望通过Hook技术进行设置，可以参考例子http://www.china-askpro.com/download/f_51.zip。
如何响应右上角的关闭事件？
Private Sub Form_Unload(Cancel As Integer)
    If MsgBox("您是否要退出系统 ？", 4 + 32 + 256, cProgramName) = vbYes Then
        Cancel = False
        End
    Else
        Cancel = True
    End If
End Sub

实现屏幕变暗的效果（向关闭Windows时的效果)
利用VB产生屏幕变暗的效果.

 

1、在Form1中加入两个CommandButton和一个PictureBox.
2、在Form1的代码窗口中添加以下代码：
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As
Long
Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
Private Declare Function PatBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As
Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As
Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long)
As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As
Long, ByVal bErase As Long) As Long

Private bybits(1 To 16) As Byte
Private hBitmap As Long, hBrush As Long
Private hDesktopWnd As Long

Private Sub Command1_Click()
Dim rop As Long, res As Long
Dim hdc5 As Long, width5 As Long, height5 As Long

hdc5 = GetDC(0)
width5 = Screen.Width / Screen.TwipsPerPixelX
height5 = Screen.Height / Screen.TwipsPerPixelY

rop = &HA000C9
Call SelectObject(hdc5, hBrush)
res = PatBlt(hdc5, 0, 0, width5, height5, rop)
Call DeleteObject(hBrush)

res = ReleaseDC(0, hdc5)
End Sub

Private Sub Command2_Click()
Dim aa As Long

aa = InvalidateRect(0, 0, 1)
End Sub

Private Sub Form_Load()
Dim ary
Dim i As Long
ary = Array(&H55, &H0, &HAA, &H0, _
&H55, &H0, &HAA, &H0, _
&H55, &H0, &HAA, &H0, _
&H55, &H0, &HAA, &H0)
For i = 1 To 16
bybits(i) = ary(i - 1)
Next i
hBitmap = CreateBitmap(8, 8, 1, 1, bybits(1))
hBrush = CreatePatternBrush(hBitmap)
Picture1.ForeColor = RGB(0, 0, 0)
Picture1.BackColor = RGB(255, 255, 255)
Picture1.ScaleMode = 3
End Sub
运行程序，按Command1就可以使屏幕暗下来，按Command2恢复。
------------------------------------
二十八、关闭键盘和鼠标事件

　　编程时，如希望把键盘和鼠标暂时屏蔽掉，可使用下列语句：

　　private declare function enablewindow lib″user32″ (byval hwnd as long, byval fenable as long) as long

　　sub form－load()

　　call enablewindow(form.hwnd, 0)

　　′拒绝接受键盘和鼠标事件

　　……

　　call enablewindow(form.hwnd, 1)

　　′允许接受键盘和鼠标事件

　　end sub

------------------------------------
二十九、关闭程序

　　也许大家会说关闭程序不是很简单吗，用end语句即可。事实上，用end语句关闭程序并不是一个很好的方法，end语句虽然可以结束程序，但并不能把窗体完全从内存中移走，造成的结果是窗体还占用着部分windows资源；完全释放所占资源的方法还是使用unload语句,然后使用 set form = nothing 语句。如果程序中窗体较多，可以使用下面的方法一次将所有窗体移走：

　　sub unloadallforms()

　　dim form as form

　　for each form in forms

　　 unload form

　　 set form = nothing

　　next form

　　end sub

上面这个函数采用窗体对象的方法，不需要一个一个地使用unload语句，在程序结束按钮中调用它即可。

------------------------------------
三十、避免打开文件可能产生的冲突

　　我们常用 open ... ... as ＃1之类的语句打开文件，比如，

　　open "myfile.txt" for append as ＃1

　　 print ＃1,"a line of text"

　　 close ＃1

　　如果程序中需要打开的文件较多，可能会因文件号产生冲突，在别的窗体中使用的文件号如果还没关闭而又在其他窗体使用就会发生错误。要避免此类可能发生的错误，最好在使用文件号之前确保它没有被使用。vb提供了一个函数freefile()可解决这个问题，它返回当前已使用文件号的下一个文件号，可保证不会发生冲突。我们将上面的代码改写如下：

　　intfile=freefile()

　　 open ″myfile.txt″ for append as ＃intfile

　　 print ＃intfile,″a line of text″

　　 close ＃intfile

------------------------------------
三十一、使用name命令移动文件

　　name命令大家也许只认为它是用来改变文件名字的，事实上它还可以用来移动文件，比如： name “c:/myfile.txt" as “c:/dos/file.txt" ,这个语句不但改变了文件的名字，而且还将文件从c:/移到了c:/dos路径下。需要说明的是，它只适用于文件新、老路径在同一个驱动器上的情况，只能用来移动文件，不能移动目录或文件夹，文件名字中不能包括统配符。
------------------------------------
三十二、制作一个倒计时时钟

　　制作倒计时时钟的方法很简单，首先设定一个初始时间，然后用初始时间减去当前时间即可。例子，倒计时一小时的时钟可这样编写代码：

　　dim txt as string

　　′将当前时间加上一小时作为结束时间

　　endtime = dateadd(″h″, 1, now)

　　′倒计时，用一标签显示剩余时间

　　txt = format＄(alarmtime － now, ″hh:mm:ss″)

　　label1.caption = txt
------------------------------------
三十三、实现标签文字竖排

　　通常情况下标签文字都是横排的，但我们可以使其竖排，竖排的方法是每个字符后加上回车换行键，直接在标签的标题中输入也可以，但比较麻烦，不如利用一个小程序来完成，其中使用了mid＄函数，对英文按字母排列，对汉字串按单个汉字排列：

　　dim s as string

　　dim ss as string

　　 for i = 1 to len(label1)

　　 s = mid＄(label1,i,1) ＆ vbcrlf

　　 ss=ss＋s

　　 next

　　label1 = ss

------------------------------------
三十四、实现无标题窗口

　　无标题窗口一般用来制作程序启动封面等，要使窗口无标题必须将窗体的四个属性按如下值设定：

　　 caption =

　　 controlbox = false

　　 minbox = false

　　 maxbox = false

------------------------------------
三十五、用api函数播放midi文件

　　midi音乐文件一般比较小，常可用于背景音乐，播放midi音乐文件可以使用mci控件，但对于一个软件来说，为了播放一个背景音乐文件添加一个mci控件似乎有点大才小用，其实利用api函数可非常简单地完成此项功能。例子如下：

　　在总体声明部分中声明api函数mcisendstring如下：

　　private declare function mcisendstring lib ″winmm.dll″ alias _

　　″mcisendstringa″ (byval lpstrcommand as string, byval _

　　lpstrreturnstring as any, byval ureturnlength as long, byval _

　　hwndcallback as long) as long

　　在窗体中添加一命令按钮，双击写如下代码：

　　private sub command1_click()

　　dim ret as integer

　　′打开midi文件和序列设备

　　ret = mcisendstring(″open c:/win95/media/canyon.mid type sequencer _

　　 alias canyon", 0＆, 0, 0)

　　′播放midi文件

　　ret = mcisendstring(″play canyon wait″, 0＆, 0, 0)

　　′ 关闭midi文件和序列设备

　　ret = mcisendstring(″close canyon″, 0＆, 0, 0)
   end sub
读写ini文件的四个函数

Public Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long
Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
'读ini字符串
Public Function GetIniS(ByVal SectionName As String, ByVal KeyWord As String, ByVal DefString As String, ByVal FileName As String) As String
    Dim ResultString As String * 144, Temp As Integer
    Dim s As String, i As Integer
    Temp% = GetPrivateProfileString(SectionName, KeyWord, "", ResultString, 144, FileName)
    '检 索 关 键 词 的 值
    If Temp% > 0 Then '关 键 词 的 值 不 为 空
        s = ""
        For i = 1 To 144
            If Asc(Mid$(ResultString, i, 1)) = 0 Then
                Exit For
            Else
                s = s & Mid$(ResultString, i, 1)
            End If
        Next
    Else
        Temp% = WritePrivateProfileString(SectionName, KeyWord, DefString, FileName)
        '将 缺 省 值 写 入 INI 文 件
        s = DefString
    End If
    GetIniS = s
End Function
'读ini数值
Public Function GetIniN(ByVal SectionName As String, ByVal KeyWord As String, ByVal DefValue As Integer, ByVal FileName As String) As Integer
    Dim d As Long, s As String
    d = DefValue
    GetIniN = GetPrivateProfileInt(SectionName, KeyWord, DefValue, FileName)
    If d <> DefValue Then
        s = "" & d
        d = WritePrivateProfileString(SectionName, KeyWord, s, FileName)
    End If
End Function
'写ini字符串
Public Sub SetIniS(ByVal SectionName As String, ByVal KeyWord As String, ByVal ValStr As String, ByVal FileName As String)
    Dim res%
    res% = WritePrivateProfileString(SectionName, KeyWord, ValStr, FileName)
End Sub
'写ini数值
Public Sub SetIniN(ByVal SectionName As String, ByVal KeyWord As String, ByVal ValInt As Integer, ByVal FileName As String)
    Dim res%, s$
    s$ = Str$(ValInt)
    res% = WritePrivateProfileString(SectionName, KeyWord, s$, FileName)
End Sub
如何用VB开发像VB菜单式的菜单（即：菜单项前带图标的菜单）？
创建位图菜单
 
在通常的程序中菜单总是以文本的方式存在，有时候显得非常单调乏味。如果能够在菜单中加入位图图形，将会极大地增加用户的使用兴趣。本文介绍了如何使用位图制作菜单选项。

创建位图菜单

----创建位图菜单其实非常简单，它需要用到Windows应用程序编程接口（API）的一些菜单函数和位图函数，你需要将这些函数的声明包含在你的应用程序的标准模块中，具体的内容请参见样例程序。步骤如下：

使用函数GetSubMenu来提取子菜单项的句柄，并通过使用函数CreateCompatibleDC来创建一个兼容的设备环境描述表；

在一个循环过程中通过使用CreateCompatibleBitmap函数，SelectObject函数以及BitBlt函数来分别将针对各个菜单项所载入的位图选入到兼容设备环境中；

通过ModifyMenu函数绘制真正的位图菜单选项；

使用DeleteDC函数来释放设备环境，以便其他的程序可以使用它们。

----提取位图可以有多种方法，在本样例程序中在窗体上设置了四个图形框控件，使用它们载入4个预设的图标来作为菜单选项位图的源文件，当然你也可以使用其他的方法，例如使用LoadPicture函数来从磁盘装载位图。

样例程序

在Visual Basic中开始一个新的工程，采用缺省的方法建立Form1。

创建一个新的模块，采用缺省的方法建立Module1.Bas。

将如下的声明语句和常量添加到Module1.Bas模块中：

 

Option Explicit
Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long,
  ByVal nPos As Long) As Long
Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long,
  ByVal nPos As Long) As Long
Declare Function ModifyMenu Lib "user32" Alias "ModifyMenuA"
(ByVal hMenu As Long,ByVal nPosition As Long, ByVal wFlags As Long,
  ByVal wIDNewItem As Long, ByVal lpString As Any) As Long
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function CreateCompatibleBitmap Lib "gdi32"
(ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long,
ByVal hObject 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
Public Const SRCCOPY = &HCC0020

Public Const MF_BYPOSITION = &H400&
Public Const MF_BITMAP = &H4&

 

注意上面的声明语句需要书写在一行内。

在Form1上添加4个图形框控件，将它们的Name属性设置为Picture1，将它们的Index属性依次设置为0，1，2，3，将它们的AutoRedrew属性设置为True，将它们的AutoResize属性设置为Ture，以及将它们的Visable属性设置为False。

将上面的4个图形框控件的Picture属性依次设置为Face1.ico，Face2.ico，Face3.ico，Face4.ico。

在Form1上添加第一个菜单项，将它的标题设置为“[&F]文件”，名称设置为mnuFile。在其下添加一个子菜单项，将它的标题设置为“[&E]退出”，名称设置为mnuExit。

在Form1上添加第二个菜单项，将它的标题设置为“[&A]脸谱”，名称设置为mnuFace。在其下添加4个子菜单项，分别将改4个子菜单项的名称设置为“[N]正常”，“[&S]微笑”，“ [&L]大笑”，以及“[&O]悲伤”。将它们的名称设置为“mnuFaceSel”，并相应将这4个子菜单项的索引设置为0，1，2，3。

将如下的代码添加到Form1的Form_Load事件中：

 

Private Sub Form_Load()
    Dim nLoopCtr As Integer
    Dim lResult As Long
    Dim hTempDC As Long
    Dim nWidth As Integer
    Dim nHeight As Integer
    Dim lTempID As Long
    Dim hMenuID As Long
    Dim lItemCount As Long
    Dim hBitmap As Long
   
    nWidth = Picture1(nLoopCtr).Width / Screen.TwipsPerPixelX
    nHeight = Picture1(nLoopCtr).Height / Screen.TwipsPerPixelY
    hMenuID = GetSubMenu(GetMenu((Me.hwnd)), 1)
   
    hTempDC = CreateCompatibleDC(Picture1(nLoopCtr).hdc)
   
    For nLoopCtr = 0 To 3
        hBitmap = CreateCompatibleBitmap(Picture1(nLoopCtr).hdc, nWidth,
                  nHeight)
       
        lTempID = SelectObject(hTempDC, hBitmap)
       
        lResult = BitBlt(hTempDC, 0, 0, nWidth, nHeight, (Picture1(nLoopCtr).
                  hdc), 0, 0, SRCCOPY)
       
        lTempID = SelectObject(hTempDC, lTempID)
       
        mnuFaceSel(nLoopCtr).Caption = ""
       
        lResult = ModifyMenu(hMenuID, nLoopCtr, MF_BYPOSITION Or MF_BITMAP,
                  GetMenuItemID(hMenuID, nLoopCtr), hBitmap)
       
    Next nLoopCtr
   
    lResult = DeleteDC(hTempDC)
End Sub

将如下的代码添加到“退出”子菜单的单击事件中：

Private Sub mnuExit_Click(Index As Integer)
    Select Case Index
        Case 0
            Unload Me
    End Select
End Sub

 

运行该样例程序，单击“脸谱”菜单，则会看到由4个脸谱图标所形成的位图子菜单项，如图1所示。单击“文件”/“退出”菜单可退出应用程序。
 
'API函数声明
Option Explicit
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) _
As Long '取得窗口的菜单句柄,hwnd是窗口的句柄
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As _
Long, ByVal nPos As Long) As Long '取得子菜单句柄，nPos是菜单的位置
Private Declare Function SetMenuItemBitmaps Lib "user32" (ByVal _
hMenu As Long, ByVal nPos As Long, ByVal wFlags As Long, ByVal _
hBitUnchecked As Long, ByVal hBitChecked As Long) As Long
'为菜单设置相应的图形
Const MF_BITMAP = &H400&
'用image或picture或imagelist控件装入图形（必须是bmp格式）,16*16左右
'建好菜单
Private Sub Form_Load()
Dim hMenu, hSubMenu1, hSubMenu2 As Long
hMenu = GetMenu(Me.hwnd)
hSubMenu1 = GetSubMenu(hMenu, 0) '取得第一项菜单的子菜单句柄
SetMenuItemBitmaps hSubMenu1, 0, MF_BITMAP, imagelist1.listimages(1) _
.Picture, imagelist1.listimages(1).Picture
'为hSubMenu1的第一项设置图形,假设用imagelist控件装入图形
SetMenuItemBitmaps hSubMenu1, 1, MF_BITMAP, imagelist1.listimages(2) _
.Picture, imagelist1.listimages(2).Picture
'设置第二项，同样你还可以设置第xx项。
hSubMenu2 = GetSubMenu(hMenu, 1) '取得第二项菜单的子菜单句柄
 
'也可用SetMenuItemBitmaps来设置它的图形，只更改hSubMenu1为hSubMenu2
'即可
End Sub
怎样：把界面上控件MS Chart中的统计图形 ，存为一个图形文件
On Error GoTo saverr
  Dim strsavefile As String
  With dlgChart ' CommonDialog object
    .Filter = "Pictures (*.bmp)|*.bmp"
    .DefaultExt = "bmp"
    .CancelError = True
    .ShowSave
    strsavefile = .FileName
    If strsavefile = "" Then Exit Sub
  End With
  MSChart1.EditCopy
  SavePicture Clipboard.GetData, strsavefile
  Exit Sub
saverr:
就可以了，
如何在treeview中判断某个节点是否存在？
Private Function IsExistNode(Key As String) As Boolean
    On Error GoTo Err
    Dim nodeX As Node
   
    Set nodeX = TreeView.Nodes(Key)
    IsExistNode = True
Err:
    IsExistNode = False
End Function

Private Sub Command1_Click()
    MsgBox IsExistNode("keystr")
End Sub

Private Sub Form_Load()
    TreeView1.Nodes.Add , , "key", "aaa"
End Sub