Форумы HiProg.com - MS ACCESS, VBA, VB

ник: Силblч
нашел у себя, но это VB

Attribute VB_Name = "riched_hook" Option Explicit Public Const WH_KEYBOARD = 2 Public Const VK_ESCAPE = &H1B Public Const VK_SHIFT = &H10 '-- поиск в ListBox Private Const LB_FINDSTRING = &H18F Private Const LB_FINDSTRINGEXACT = &H1A2 Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, _                                               ByVal wParam As Long, lParam As Any) As Long Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, _                                           ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long Public hHook As Long Public Function KeyboardProc(ByVal idHook As Long, ByVal wParam As Long, ByVal lParam As Long) As Long     Dim f As Form     Dim rExp As RegExp     Dim KeybLayoutName$, sSymb$, asci&     Dim ret     '-- if idHook is less than zero, no further processing is required     If idHook < 0 Then         'call the next hook         KeyboardProc = CallNextHookEx(hHook, idHook, wParam, ByVal lParam)     Else         Set f = Forms(0)         '-- нажата ESC         If (GetKeyState(VK_ESCAPE) And &HF0000000) Then 'And wParam = Asc("S")             '-- пошлём ESC и нашему листбоксу             ret = SendMessage(f.List1.hwnd, WM_KEYPRESS, 27, vbNull)         Else             '-- автоподстановка             Dim re&             re = FindWindowEx(GetSpshWnd(f.hwnd), ByVal 0&, "RichEdit20W", vbNullString)             If re <> 0 Then                 sSymb = GetText(re)                 f.List1.ListIndex = SendMessage(f.List1.hwnd, LB_FINDSTRING, -1, ByVal sSymb)             End If              '            '-- пригодиццо обработка других клавиш '            Set rExp = New RegExp '            rExp.IgnoreCase = True '            rExp.Pattern = "." '            sSymb = Chr$(wParam) '            asci = Asc(sSymb) '            '-- обработка странных исключений '            If asci = 219 Or asci = 221 Or asci = 186 Or asci = 222 Or asci = 188 Or asci = 190 Or asci = 191 Then '                sSymb = Switch(asci = 219, Chr("91"), _ '                               asci = 221, Chr("93"), _ '                               asci = 186, Chr("59"), _ '                               asci = 222, Chr("39"), _ '                               asci = 188, Chr("44"), _ '                               asci = 190, Chr("46"), _ '                               asci = 191, Chr("47")) '            End If '            If rExp.Test(sSymb) Then '                '-- шо за раскладка? '                KeybLayoutName = String(9, 0) '                Call GetKeyboardLayoutName(KeybLayoutName) '                KeybLayoutName = CStr(CLng(Left$(KeybLayoutName, _ '                                      InStr(1, KeybLayoutName, Chr(0)) - 1))) '                Select Case KeybLayoutName '                Case "409" '-- английская '                    sSymb = sSymb '                Case "419" '-- русская '                    sSymb = Eng2Rus(sSymb) '                Case "422" '-- українська '                    sSymb = Eng2Ukr(sSymb) '                Case Else  ' другая '                    sSymb = sSymb '                End Select '                'sbuff = sbuff & sSymb '                f.StatusBar1.Panels(1).Text = Asc(wParam) & " " & sSymb & " " & KeybLayoutName '                'ret = SendMessage(f.List1.hwnd, WM_KEYPRESS, wParam, vbNull) '                f.List1.ListIndex = SendMessage(f.List1.hwnd, LB_FINDSTRING, -1, ByVal sSymb) '                'f.StatusBar1.Panels(1).Text = f.Spreadsheet1.ActiveCell.Value '            End If '            Set rExp = Nothing         End If         'call the next hook         KeyboardProc = CallNextHookEx(hHook, idHook, wParam, ByVal lParam)     End If End Function '-- вызов из формы '    '-- поискать нужный класс '    hwndRichEdit = FindWindowEx(hwndSpreadSheet, ByVal 0&, "RichEdit20W", vbNullString) '    If hwndRichEdit = 0 Then '        If hHook <> 0 Then UnhookWindowsHookEx hHook: hHook = 0 '    End If '    If hHook = 0 Then '        hHook = SetWindowsHookEx(WH_KEYBOARD, AddressOf KeyboardProc, App.hInstance, App.ThreadID) '    End If

VERSION 5.00 Object = "{0002E558-0000-0000-C000-000000000046}#1.0#0"; "OWC11.DLL" Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX" Begin VB.Form frmMain     Caption         =   "Tune DWH Light"    ClientHeight    =   8265    ClientLeft      =   165    ClientTop       =   735    ClientWidth     =   10710    LinkTopic       =   "Form1"    ScaleHeight     =   8265    ScaleWidth      =   10710    StartUpPosition =   3  'Windows Default    Begin VB.Timer Timer1        Interval        =   777       Left            =   8760       Top             =   1680    End    Begin VB.ListBox List1        Appearance      =   0  'Flat       BackColor       =   &H00E0E0E0&       Height          =   1590       ItemData        =   "frmMain.frx":0000       Left            =   8760       List            =   "frmMain.frx":0002       TabIndex        =   2       Top             =   0       Visible         =   0   'False       Width           =   1695    End    Begin ComctlLib.StatusBar StatusBar1        Align           =   2  'Align Bottom       Height          =   375       Left            =   0       TabIndex        =   0       Top             =   7890       Width           =   10710       _ExtentX        =   18891       _ExtentY        =   661       SimpleText      =   ""       _Version        =   327682       BeginProperty Panels {0713E89E-850A-101B-AFC0-4210102A8DA7}           NumPanels       =   1          BeginProperty Panel1 {0713E89F-850A-101B-AFC0-4210102A8DA7}              Key             =   ""             Object.Tag             =   ""          EndProperty       EndProperty    End    Begin OWC11.Spreadsheet Spreadsheet1        Height          =   6600       Left            =   0       OleObjectBlob   =   "frmMain.frx":0004       TabIndex        =   1       Top             =   0       Width           =   8565    End    Begin VB.Menu xx        Caption         =   "xx"    End    Begin VB.Menu m_Treasury        Caption         =   "ыыыы"       Index           =   0       Begin VB.Menu m_stc           Caption         =   "аааа"          Index           =   1       End       Begin VB.Menu m_STC_carm           Caption         =   "ааааыва"          Index           =   2       End       Begin VB.Menu m_stc_original           Caption         =   "ываыва"          Index           =   7       End    End    Begin VB.Menu m_products        Caption         =   "цав"       Index           =   4       Begin VB.Menu m_tune_goods_grp           Caption         =   "апв"          Index           =   5       End       Begin VB.Menu m_goods_ukrup_grp           Caption         =   "апра"          Index           =   6       End    End End Attribute VB_Name = "frmMain" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Private Type ROWCOLUMN         row As Long         col As Long End Type Private Const dsn = "" Private Const usr = "" Private Const pwd = "" Private tgt As OWC11.Range Private rerc As ROWCOLUMN '-- флаг наличия листбокса, чтобы не выводить повторно Private bListVisible As Boolean '-- дескриптор SpreadSheet Private hwndSpreadSheet& Private Sub Form_Load()     StatusBar1.Panels(1).AutoSize = sbrContents     '-- on/off     Me.Spreadsheet1.DisplayOfficeLogo = False     Me.Spreadsheet1.DisplayTitleBar = True     Me.Spreadsheet1.DisplayToolbar = True     Me.Spreadsheet1.Visible = False     '-- определить дескриптор SpreadSheet     hwndSpreadSheet = GetSpshWnd(Me.hwnd)     bListVisible = False     Set tgt = Me.Spreadsheet1.Cells(1, 1) End Sub Private Sub Form_Resize()     Dim ct As Control     For Each ct In Me         If TypeName(ct) = "Spreadsheet" Then             With ct                 .Width = Me.Width - 500                 .Height = Me.Height - 1060             End With         End If     Next End Sub Private Sub Form_Unload(Cancel As Integer)     UnhookWindowsHookEx hHook: hHook = 0 End Sub Private Sub List1_DblClick()     On Error GoTo err3232     '-- если выбранная колонка та, что надо     If Me.Spreadsheet1.ActiveCell.Address = tgt.Address Then         '-- попытка обновить данные на сервере         'ключ - все поля?                   '-- если удачно - обновить данные в spsht         tgt.Value = Me.List1.Text     End If     Exit Sub err3232:     MsgBox Err.Description, vbCritical, "Error#" & Err.Number     Exit Sub End Sub Private Sub List1_KeyPress(KeyAscii As Integer)  If KeyAscii = 27 Then     If hHook <> 0 Then UnhookWindowsHookEx hHook: hHook = 0     Me.List1.Visible = False     bListVisible = Me.List1.Visible  End If  'Me.StatusBar1.Panels(1).Text = KeyAscii End Sub Private Sub List1_LostFocus()     If hHook <> 0 Then UnhookWindowsHookEx hHook: hHook = 0     Me.List1.Visible = False     bListVisible = Me.List1.Visible End Sub '--  Private Sub m_goods_ukrup_grp_Click(Index As Integer) On Error GoTo err444      SpreadRequest "select f.* from таблицца f order by 1", "вава" Exit Sub err444: MsgBox Err.Description, vbCritical, "Error#" & Err.Number Exit Sub End Sub '--  Private Sub m_STC_carm_Click(Index As Integer) On Error GoTo err444      SpreadRequest "select f.* from ещётаблицца f order by 1,2,3,4", "ыввв" Exit Sub err444: MsgBox Err.Description, vbCritical, "Error#" & Err.Number Exit Sub End Sub '--  Private Sub m_STC_Click(Index As Integer) On Error GoTo err444      SpreadRequest "select f.* from иещё by 1,2,3,4", "ыва" Exit Sub err444: MsgBox Err.Description, vbCritical, "Error#" & Err.Number Exit Sub End Sub '--  Private Sub m_stc_original_Click(Index As Integer) Dim osht As Object On Error GoTo err444      SpreadRequest "SELECT * FROM гога a order by 1,2,3", _               "вввв" Exit Sub err444: MsgBox Err.Description, vbCritical, "Error#" & Err.Number Exit Sub End Sub '--  Private Sub m_tune_goods_grp_Click(Index As Integer) Dim osht As Object On Error GoTo err444      SpreadRequest "SELECT a.gid, a.description, a.nickname, a.budget_description " & _               "FROM ываыв a", "вввы" Exit Sub err444: MsgBox Err.Description, vbCritical, "Error#" & Err.Number Exit Sub End Sub Private Sub Spreadsheet1_Click()     If tgt.Column <> rerc.col Or tgt.row <> rerc.row Then         Me.List1.Visible = False         bListVisible = Me.List1.Visible     End If     If hHook <> 0 Then UnhookWindowsHookEx hHook: hHook = 0 End Sub Private Sub Spreadsheet1_MouseOver(ByVal Button As Long, ByVal Shift As Long, ByVal Target As OWC11.Range)     Dim hwndRichEdit&     '-- если активный RichEdit, то не перечитывать!     hwndRichEdit = FindWindowEx(hwndSpreadSheet, ByVal 0&, "RichEdit20W", vbNullString)     If hwndRichEdit = 0 Then         If hHook <> 0 Then UnhookWindowsHookEx hHook: hHook = 0         Set tgt = Target '-- заполняем глобальную структуру     End If     'Me.StatusBar1.Panels(1).Text = hHook End Sub '-- таймер ожидания появления RichEdit '-- хорошо бы еще перехватить его события Private Sub Timer1_Timer()     Dim hwndRichEdit&     Dim sText$     Dim pt As POINTAPI     Dim rc As RECT, fc As RECT     Dim dx&, dy&     '-- поискать нужный класс     hwndRichEdit = FindWindowEx(hwndSpreadSheet, ByVal 0&, "RichEdit20W", vbNullString)     If hwndRichEdit = 0 Then         If hHook <> 0 Then UnhookWindowsHookEx hHook: hHook = 0     End If                  '-- если нужные колонки     Select Case Spreadsheet1.Tag     Case "CLT_TUNE"         If tgt.Column = 4 _            And Me.Spreadsheet1.ActiveCell.Column = 4 _            And tgt.row > 1 Then '-- если колонка та, что нужно ;) D                          '-- если RichEdit не загружен - уходим             If hwndRichEdit = 0 Then Exit Sub                          '--попытка перехватить события RichEdit             If hHook = 0 Then                 hHook = SetWindowsHookEx(WH_KEYBOARD, AddressOf KeyboardProc, App.hInstance, App.ThreadID)             End If                          '-- если уже работаем с этим, то и нефик еще раз             If bListVisible = True Then Exit Sub                          '-- запомним текущие колонку и строку             rerc.col = tgt.Column: rerc.row = tgt.row             '-- нашли! перепрячем, как сало %)             Me.List1.Visible = False             '-- отпозиционировать и обновить данные в ListBox             '-- считаем координаты окна             Call GetWindowRect(Me.hwnd, fc)             '-- определить координаты контрола             GetWindowRect hwndRichEdit, rc             dx = Me.ScaleX(rc.Left - fc.Left - 5, vbPixels, vbTwips)             dy = Me.ScaleY(rc.Top - fc.Top - 4 - _                           (GetSystemMetrics(SM_CYMENUSIZE) + _                            GetSystemMetrics(SM_CXBORDER) + _                            GetSystemMetrics(SM_CYCAPTION)) + _                           (rc.Bottom - rc.Top), vbPixels, vbTwips)             '-- если координаты внизу больше клиентской области, то - отображать вверх             If (dy + Me.List1.Height) > Me.Spreadsheet1.Height Then                 dy = Me.ScaleY(rc.Top - fc.Top - 4 - _                           (GetSystemMetrics(SM_CYMENUSIZE) + _                            GetSystemMetrics(SM_CXBORDER) + _                            GetSystemMetrics(SM_CYCAPTION)), vbPixels, vbTwips) _                      - Me.List1.Height             End If             ListRequest Me.List1, "select f.description from qwerqwer f order by er"             Me.List1.Left = dx             Me.List1.Top = dy             Me.List1.Width = Me.ScaleX((rc.Right - rc.Left + 2), vbPixels, vbTwips)             Me.List1 = tgt.Value             Me.List1.Visible = True             bListVisible = Me.List1.Visible         Else             Me.List1.Visible = False             bListVisible = Me.List1.Visible         End If     Case Else         Me.List1.Visible = False         bListVisible = Me.List1.Visible     End Select End Sub Private Sub xx_Click() '    Dim NewDoc As New Form1 '    NewDoc.Show End Sub '-- ф-ция загрузки SpreadSheet '-- 20071005  Private Sub SpreadRequest(ssql$, Optional sResp$ = "") Dim hg As HourGlass Dim conn As New Connection, rs As New Recordset, oSheet As Object On Error GoTo err444 If hHook <> 0 Then UnhookWindowsHookEx hHook: hHook = 0 Spreadsheet1.Visible = False conn.ConnectionString = "Provider=msdaora;" & _                         "Data Source=" & dsn & ";" & _                         "User Id=" & usr & ";" & _                         "Password=" & pwd & ";" conn.CommandTimeout = 300 Set hg = New HourGlass '-- показать часики conn.Open rs.Source = ssql$ Set rs.ActiveConnection = conn rs.Open Set oSheet = Spreadsheet1.Worksheets(1) oSheet.ConnectionString = conn.ConnectionString oSheet.CommandText = rs.Source If rs.State <> 0 Then rs.Close If conn.State <> 0 Then conn.Close '-- запомним, кто вызвал Spreadsheet1.Tag = sResp '-- и [зачеркнуто]накажем[/зачеркнуто] покажем Spreadsheet1.Caption = sResp Spreadsheet1.DisplayTitleBar = True '-- отобразим Spreadsheet1.Visible = True Set hg = Nothing Exit Sub err444: MsgBox Err.Description, vbCritical, "Error#" & Err.Number If rs.State <> 0 Then rs.Close If conn.State <> 0 Then conn.Close Spreadsheet1.Visible = False Set hg = Nothing Exit Sub End Sub Private Sub ListRequest(lst As ListBox, ssql$) Dim hg As HourGlass Dim conn As New Connection, rs As New Recordset, i&, inlist$ On Error GoTo err444 conn.ConnectionString = "Provider=msdaora;" & _                         "Data Source=" & dsn & ";" & _                         "User Id=" & usr & ";" & _                         "Password=" & pwd & ";" conn.CommandTimeout = 300 Set hg = New HourGlass '-- показать часики Me.List1.Clear conn.Open rs.Source = ssql$ Set rs.ActiveConnection = conn rs.Open If Not rs.EOF Then rs.MoveFirst Do While Not rs.EOF     For i = 0 To rs.Fields.Count - 1             If i = 0 Then                 If IsNull(rs.Fields(i)) Then                     inlist = " "                 Else                     inlist = rs.Fields(i)                 End If             Else                 If IsNull(rs.Fields(i)) Then                     inlist = inlist & Chr(9) & " "                 Else                     inlist = inlist & Chr(9) & _                         rs.Fields(i)                 End If             End If         Next i         lst.AddItem inlist         lst.ItemData(lst.NewIndex) = i         rs.MoveNext Loop If rs.State <> 0 Then rs.Close If conn.State <> 0 Then conn.Close Set hg = Nothing Exit Sub err444: MsgBox Err.Description, vbCritical, "Error#" & Err.Number If rs.State <> 0 Then rs.Close If conn.State <> 0 Then conn.Close Set hg = Nothing Exit Sub End Sub

както так в общем