156、如何建立可卷动的图形框？
157、如何侦测目前文字框中共有几行？
158、如何判断使用者电脑中系统字型大小？
159、使用 Label
模拟资源管理器左右窗口中的调整杆 ( Splitter )
160、【万用文件搜寻器】---
将 Windows 的【寻找文件】功能套进 VB 中
156、如何建立可卷动的图形框？
在各网站的讨论区中常有人问到这个问题，其实答案就在 Msdn 中！以下资料由 Msdn
节录：
除了图片方块控制项之外，也可用水平、垂直卷轴来建立可卷动的图形框应用程序。当所包含的图形超过控制项范围时，单独一个图片方块控制项无法制作卷动功能─
因为图片方块控制项无法自动新增卷轴。应用程序使用两个图片方块。称第一个为平稳的父图片方块控制项。第二个为子图片方块控制项，它包含在父图片方块中。子图片方块中包含图形影像，可用卷轴控制项在父图片方块中搬动子图片方块。
先建立一个新工程，然后在表单上绘制两个图片方块、一个水平卷轴和一个垂直卷轴。位置随便放，这里，用表单的
Form_Load
事件设定比例模型，在父图片方块中调整子图片方块的大小，水平、垂直卷轴，搜寻并调整它们的大小，然后载入点阵图图形。将下列程序码新增到表单的
Form_Load 事件程序中：
修正：避开 Form_Resize
产生的错误，将程序模组化，并加上范例程序。
Private Sub
init_object()
'初始化两个图片方块的位置。
Picture1.Move 0, 0, ScaleWidth -
VScroll1.Width, ScaleHeight - HScroll1.Height
Picture2.Move 0,
0
'将水平卷轴搜寻。
HScroll1.Top = Picture1.Height
HScroll1.Left =
0
HScroll1.Width = Picture1.Width
'将垂直卷轴搜寻。
VScroll1.Top =
0
VScroll1.Left = Picture1.Width
VScroll1.Height =
Picture1.Height
'设定卷轴的 Max 属性。
HScroll1.Max = Picture2.Width -
Picture1.Width
VScroll1.Max = Picture2.Height -
Picture1.Height
'判断子图片方块是否将充满屏幕。若如此，则无需使用卷轴。
VScroll1.Visible =
(Picture1.Height < Picture2.Height)
HScroll1.Visible =
(Picture1.Width < Picture2.Width)
End Sub
Private Sub
Form_Load()
'设定 ScaleMode 为像素。
Form1.ScaleMode =
vbPixels
Picture1.ScaleMode = vbPixels
'将 Autosize 设定为 True，以使
Picture2 的边界延伸到实际的点阵图大小。
Picture2.AutoSize = True
'将每个图片方块的
BorderStyle 属性设定为 None。
Picture1.BorderStyle =
0
Picture2.BorderStyle = 0
'载入点阵图。 此处请自行更改图片
'Picture2.Picture =
LoadPicture("c:\Windows\ham.bmp")
'初始化各物件
init_object
End
Sub
水平和垂直卷轴的 Change 事件，用在父图片方块中上、下、左、右移动子图片方块。请将下列程序码新增到两个卷轴控制项的
Change 事件中：
Private Sub HScroll1_Change()
Picture2.Left =
-HScroll1.Value
End Sub
Private Sub
VScroll1_Change()
Picture2.Top = -VScroll1.Value
End
Sub
将子图片方块的 Left 和 Top
属性分别设定成水平和垂直卷轴数字的负值，这样，当上、下、左、右卷动时，图形可以正确移动。
执行阶段中，显示的图形如上图所示。
在执行阶段调整表单大小
在上例中，表单的初始大小限制图形的可视大小。在执行阶段中，当使用者调整表单大小时，为了调整图形视域应用程序的大小，可将下列程序码新增到表单的
Form_Resize 事件程序中：
Private Sub
Form_Resize()
'重新初始化各物件
'避开表单最小化的情况
If Me.WindowState <> 1
Then init_object
End Sub
157、如何侦测目前文字框中共有几行？
要判断文字框中目前有几行，可以使用回圈判断共有几个换行字元来取得，但是在这儿我们要使用 API
来做到这个功能！
'请在 Form 中放一个 TextBox 及一个
label，在声明区中加入以下声明：
Private Declare Function SendMessageLong Lib
"user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long,
ByVal wParam As Long, ByVal lParam As Long) As Long
Const
EM_GETLINECOUNT = &HBA
'在 Text1 的 Change 事件中加入以下程序码：
Sub
Text1_Change()
Dim lineCount As Long
On Local Error Resume
Next
'立刻侦测目前文字框中共有几行
lineCount = SendMessageLong(Text1.hwnd,
EM_GETLINECOUNT, 0&, 0&)
Label1 = "文字框中共有 " &
Format$(lineCount, "##,###") & " 行"
End Sub
158、如何判断使用者电脑中系统字型大小？
在【问题】如何算出屏幕的分辨率？我们提到：如果希望使用者在跑我们开发的应用程序时，看到的画面的样子和我们在
Design Time 时一样的话，我们往往需要处理屏幕分辨率的问题。
除了屏幕的分辨率之外，电脑中设定的字型大小是大字型 (
Large Font ) 或小字型 ( Small Font )
或其他大小的自订字型，也是一个影响的因素，要如何侦测电脑中的字型大小呢？
由【控制面板】的【显示器】【设定】页签中，我们可以得知以下讯息：
大字型
( Large Font )：120 dpi
小字型 ( Small Font )：96
dpi
以下之程序可以判断系统是否使用小字型，当然大字型之判断方式也相同：
请在模组中加入以下声明及模组：
Public
Declare Function GetDesktopWindow Lib "user32" () As Long
Public
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal
nIndex As Long) As Long
Public Declare Function ReleaseDC Lib "user32"
(ByVal hwnd As Long, ByVal hdc As Long) As Long
Public Const LOGPIXELSX
= 88
Public Function IsScreenFontSmall() As Boolean
Dim hWndDesk
As Long
Dim hDCDesk As Long
Dim logPix As Long
Dim r As
Long
hWndDesk = GetDesktopWindow()
hDCDesk =
GetDC(hWndDesk)
logPix = GetDeviceCaps(hDCDesk, LOGPIXELSX)
r =
ReleaseDC(hWndDesk, hDCDesk)
IsScreenFontSmall = (logPix = 96)
End
Function
在程序中呼叫 IsScreenFontSmall 若返回值为 True 即为小字型。
159、使用 Label 模拟资源管理器左右窗口中的调整杆 ( Splitter )
要模拟这个功能，有很多种不同的作法，今天我们要使用一个 Label 控制项来分割分别放在左右的 TreeView 及
ListView，整个动作的重点在于，当我们在分隔线上按下鼠标左键时，就准备调整视窗中各控制项的大小，当我们放开鼠标左键时，就停止调整的动作！
'在 Form 中放入一个 Label，一个 TreeView 及 一个 ListView，位置不拘，并加入以下程序码：
Private mbResizing As Boolean '判断是否按下鼠标左键 (准备调整大小)
Private Sub Form_Load()
'设定 TreeView1 为屏幕 1/3,ListView1 为屏幕
2/3
TreeView1.Move 0, 0, Me.ScaleWidth / 3,
Me.ScaleHeight
ListView1.Move (Me.ScaleWidth / 3) + 50, 0,
(Me.ScaleWidth * 2 / 3) - 50, Me.ScaleHeight
Label1.Move Me.ScaleWidth
/ 3, 0, 100, Me.ScaleHeight
Label1.MousePointer = vbSizeWE
End
Sub
Private Sub Form_Resize()
'设定 TreeView1 为屏幕 1/3,ListView1 为屏幕
2/3
TreeView1.Move 0, 0, Me.ScaleWidth / 3,
Me.ScaleHeight
ListView1.Move (Me.ScaleWidth / 3) + 50, 0,
(Me.ScaleWidth * 2 / 3) - 50, Me.ScaleHeight
Label1.Move Me.ScaleWidth
/ 3, 0, 100, Me.ScaleHeight
Label1.MousePointer = vbSizeWE
End
Sub
Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, X As
Single, Y As Single)
'准备调整大小
If Button = vbLeftButton Then
mbResizing = True
End Sub
Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As
Single, Y As Single)
'按下鼠标左键并移动时, 自动调整各控制项大小
If mbResizing
Then
Dim nX As Single
nX = Label1.Left + X
If nX < 500 Then
Exit Sub
If nX > Me.ScaleWidth - 500 Then Exit
Sub
TreeView1.Width = nX
ListView1.Left = nX + 50
ListView1.Width
= Me.ScaleWidth - nX - 50
Label1.Left = nX
End If
End Sub
Private Sub Label1_MouseUp(Button As Integer, Shift As Integer, X As
Single, Y As Single)
'停止调整大小
mbResizing = False
End Sub
160、【万用文件搜寻器】--- 将 Windows 的【寻找文件】功能套进 VB
中
这个 Walkdir 模组可以让您从任何一个目录往下所有目录中找寻符合您要求的所有文件！根据实际测试的结果，搜寻文件的速度和 Windows
的【寻找文件】功能不相上下，有时甚至更快呢！
共有三个参数说明如下：
1、文件类型：可接受万用字符 *，可同时设定多个类型(中间用分号隔开)，例如 ( OLE*.DLL; *.TLB
)
2、开始目录：可以是根目录。
3、字串阵列：用来存放符合的文件名称 (全路径文件名)，是一个动态阵列。
这个模组会使用递回的方式一层一层的搜寻所有的子目录，找出所有符合条件的文件，并将文件名称 (含全路径)
放入字串阵列中，这个阵列的大小会自动根据找到的文件个数而自动调整，最后阵列的大小就是找到的文件个数！
要实际使用这个模组，您必须先在 Form 中放入一个 DirListBox 及一个 FileListBox，分别取名为 Dir1 及
File1，最好将这二个控制项的 Visible 属性设成 False，可以大大加快搜寻的速度。
'以下是使用的范例： ( 要一个 CommandButton 及一个 ListBox )
Private Sub Command1_Click()
ReDim sarray(0) As String
'找寻
Windows 目录下文件类型为 OLE*.DLL 的所有文件
Call DirWalk("OLE*.DLL", "C:\windows",
sarray)
'将阵列的资料放到 List1 中
Dim i As Integer
For i = LBound(sarray)
To UBound(sarray) - 1
List1.AddItem sarray(i)
Next
End Sub
'模组内容如下：
Sub DirWalk(ByVal sPattern As String, ByVal CurrDir As String, sFound()
As String)
Dim i As Integer
Dim sCurrPath As String
Dim sFile As
String
Dim ii As Integer
Dim iFiles As Integer
Dim iLen As
Integer
If Right$(CurrDir, 1) <> "\" Then
Dir1.Path =
CurrDir & "\"
Else
Dir1.Path = CurrDir
End If
For i = 0 To
Dir1.ListCount
If Dir1.List(i) <> "" Then
DoEvents
Call
DirWalk(sPattern, Dir1.List(i), sFound())
Else
If Right$(Dir1.Path,
1) = "\" Then
sCurrPath = Left(Dir1.Path, Len(Dir1.Path) -
1)
Else
sCurrPath = Dir1.Path
End If
File1.Path =
sCurrPath
File1.Pattern = sPattern
If File1.ListCount > 0
Then
'在目录中找到符合的文件
For ii = 0 To File1.ListCount - 1
ReDim
Preserve sFound(UBound(sFound) + 1)
sFound(UBound(sFound) - 1) =
sCurrPath & "\" & File1.List(ii)
Next ii
End If
iLen =
Len(Dir1.Path)
Do While Mid(Dir1.Path, iLen, 1) <> "\"
iLen =
iLen - 1
Loop
Dir1.Path = Mid(Dir1.Path, 1, iLen)
End If
Next
i
End Sub |