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
扫一扫
2783
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
