Private Declare Function GetDC Lib 'user32.dll' (ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib 'gdi32.dll' (ByVal HDC As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib 'user32.dll' (ByVal hwnd As Long, ByVal HDC As Long) As Long
Private Const LOGPIXELSX As Long = 88
Private Function PointsPerPixel() As Double
Dim HDC As Long
Dim lngPotsPerInch As Long
HDC = GetDC(0)
lngPotsPerInch = GetDeviceCaps(HDC, LOGPIXELSX)
PointsPerPixel = Application.InchesToPoints(1) / lngPotsPerInch
ReleaseDC 0, HDC
End Function
Private Sub Worksheet_SelectionChange(ByVal T As Range)
Dim rng As Range, x As Single, y As Single, DZoom As Single
If T.Column = 2 And T.Count = 1 Then
Set rng = ActiveCell
With ActiveWindow
DZoom = .Zoom / 100
x = .PointsToScreenPixelsX((rng.Left + rng.Width) / PointsPerPixel * DZoom)
y = .PointsToScreenPixelsY((rng.Top) / PointsPerPixel * DZoom)
End With
With 界面
If .Visible = False Then .Show 0
.Move x * PointsPerPixel, y * PointsPerPixel
End With
Set rng = Nothing
Else
Unload 界面
End If
End Sub
Option Explicit
Private Sub CommandButton1_Click()
Dim arr1, x, k, arr2(), kk, y
On Error GoTo 100
arr1 = Sheets('快捷錄入數(shù)據(jù)源').Range('A1').CurrentRegion
For x = 1 To UBound(arr1)
If VBA.InStr(1, arr1(x, 1), Me.TextBox1.Text) <> 0 Then
k = k + 1
End If
Next x
ReDim arr2(1 To k, 1 To UBound(arr1, 2))
For x = 1 To UBound(arr1)
If VBA.InStr(1, arr1(x, 1), Me.TextBox1.Text) <> 0 Then
kk = kk + 1
For y = 1 To UBound(arr1, 2)
arr2(kk, y) = arr1(x, y)
Next y
End If
Next x
With Me.ListBox1
.ColumnCount = UBound(arr1, 2)
.List = arr2
.ColumnWidths = '2厘米;1厘米;1厘米;1厘米'
End With
Exit Sub
100:
MsgBox '搜索不到: ' & Me.TextBox1.Text
Me.TextBox1 = ''
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim a, z
a = Me.ListBox1.ListIndex
For z = 1 To 4
ActiveCell.Offset(0, z - 1) = Me.ListBox1.List(a, z - 1)
Next z
End Sub
