Выбрать дату в календареВыбрать дату в календаре

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 31 След.
Ошибка при попытке вывода InputBox, Возникновение ошибки после перехода на Виндовс 10 x64
 
Александр Моторин! Спасибо огромное, помогло!
Ошибка при попытке вывода InputBox, Возникновение ошибки после перехода на Виндовс 10 x64
 
Доброго времени суток!
Для подтверждения пользовательских прав использую функцию ввода пароля доступа в InputBox. Для этого использую следующий скрипт:
Код
Private Const HC_ACTION = 0
Private hHook As Long
Private Const HCBT_ACTIVATE = 5
Public Const WH_CBT = 5
Public Const EM_SETPASSWORDCHAR = &HCC
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long

Public Function vbInputBox(Prompt As String, Optional Title As String, Optional Default As String, Optional Xpos As Single, Optional Ypos As Single, Optional Helpfile As String, Optional Context As Long) As String
    hHook = SetWindowsHookEx(WH_CBT, AddressOf CBTProc, Application.Hinstance, 0)
    vbInputBox = InputBox(Prompt, Title, Default, Xpos, Ypos, Helpfile, Context)
End Function

Private Function CBTProc(ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim hwndEditControl As Long
    If lMsg = HCBT_ACTIVATE Then
        hwndEditControl = FindWindowEx(wParam, 0, "Edit", "")
        If hwndEditControl Then SendMessage hwndEditControl, EM_SETPASSWORDCHAR, Asc("*"), 0
        UnhookWindowsHookEx hHook
    End If
    CBTProc = 0
End Function

Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim RetVal
    Dim strClassName As String, lngBuffer As Long
    If lngCode < HC_ACTION Then
        NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)
        Exit Function
    End If
    strClassName = String$(256, " ")
    lngBuffer = 255
    If lngCode = HCBT_ACTIVATE Then
        RetVal = GetClassName(wParam, strClassName, lngBuffer)
        If Left$(strClassName, RetVal) = "#32770" Then SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
    End If
    CallNextHookEx hHook, lngCode, wParam, lParam
End Function

Public Function InputBoxDK(Prompt As String, Optional Title As String, Optional Default As String, Optional Xpos As Long, Optional Ypos As Long, Optional Helpfile As String, Optional Context As Long) As String
    Dim lngModHwnd As Long, lngThreadID As Long
    On Error GoTo ExitProperly
    lngThreadID = GetCurrentThreadId
    lngModHwnd = GetModuleHandle(vbNullString)
    hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
    If Xpos Then
        InputBoxDK = InputBox(Prompt, Title, Default, Xpos, Ypos, Helpfile, Context)
    Else
        InputBoxDK = InputBox(Prompt, Title, Default, , , Helpfile, Context)
    End If
ExitProperly: UnhookWindowsHookEx hHook
End Function
После перехода с Вин7 х32 на Вин10 х64, при попытке выполнения Public Function InputBoxDK,  получаю сообщение об ошибке типа: Type Mismatch. Ругается на строку: hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID), а именно на ..., AddressOf NewProc, ...

Подскажите пожалуйста, как это побороть?
Заранее огромное спасибо всем!
B Win 10 oтсутствует контрол ListView и TreeView, Возникновение ошибки после перехода на Виндовс 10
 
Цитата
офис 2019 всё есть
Точно! Переустановил на 2019 офис и всё появилось. Спасибо!
B Win 10 oтсутствует контрол ListView и TreeView, Возникновение ошибки после перехода на Виндовс 10
 
Цитата
Win 10, Office 2019, все 64 бита - TreeView в наличии (в дополнительных контролах)
Вот и я думаю, надо видимо офис переустановить и всё.
B Win 10 oтсутствует контрол ListView и TreeView, Возникновение ошибки после перехода на Виндовс 10
 
Дело в том, что эти же Файлы спокойно работают на других (более ранних) ПК. Которые также на Вин 10 и с офисом 2010 года. А с моей машиной, ну прям коллунство какое-то. ((((
Может кто сталкивался?
B Win 10 oтсутствует контрол ListView и TreeView, Возникновение ошибки после перехода на Виндовс 10
 
Доброго времени суток! Давиче на предприятии мне установили новый ПК под Вин 7. Начал тут же получать ошибки от ВБА. Установил и зарегистрировал новый MSCOMCTL.OCX для 64бит системы. Переделал запросы. Но осталась проблема с отсутствием контролов ListView и TreeView для UserForm. Подскажите как это побороть?
Заранее огромное спасибо!
как из столбца извлечь нужные значения и прописать их через запятую
 
Цитата
, протянуть как с формулами не смог?
с макросом и не получится. Макрос проверяет значения в столбцах указанного диапазона. Если условия поиска соблюдаются, собирает данные через запятую. По окончанию выгружает в указанную ячейку.
как из столбца извлечь нужные значения и прописать их через запятую
 
Так?
замена значения в ячейке на текст
 
немного не понятно при каких именно значениях и в какой именно текст. Сделал как понял.
Проверка двух массивов на редактирование, удаление или добавление данных
 
Доброго времени суток!
Существует база в mySQL которая управляется через форму.
При закрытии формы необходимо выполнить проверку данных: были ли добавлены, удалены или отредактированы какие либо данные. В случае обнаружения оных, внести изменения в БД.
Решил выполнять проверку циклично: сравнивая поэтапно одно значение с другим. Но как бы не крутил, то удаленные не могу определить, то новые не вижу. Нашел единственный выход: циклично проверить удаленные и редактируемые, а затем новым циклом найти добавляемые значения. (см. файл). Но как-то не "камельфо".
Подскажите пожалуйста, может есть более корректный способ?
Заранее огромное спасибо!

P.S. Пример выполнил за счет двух ListBox-ов с данными.
Listview сортировка даты, HELP! нужен код для сортировке по дате при нажатии на заголовок столбца в listview
 
Код
Private Sub ListView1_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader) 'Сортировка данных
    Dim i As Integer, j As Integer
    With Me.ListView1
        .ColumnHeaderIcons = Me.ImageList1 'Отключаем сортировку
        .Sorted = False
        .SortKey = ColumnHeader.Index - 1
        For i = 1 To 12
            .ColumnHeaders(i).Icon = 0
        Next
        For i = 1 To .ListItems.Count 'Выполняем цикл по столбцу с проверкой в десятичном формате
            On Error Resume Next
            .ListItems(i).ListSubItems(ColumnHeader.Index - 1).Text = CDec(CDate(.ListItems(i).ListSubItems(ColumnHeader.Index - 1).Text))
        Next i
        'Включаем сортировку данных
        .SortOrder = IIf(.SortOrder = lvwAscending, lvwDescending, lvwAscending)
        ColumnHeader.Icon = IIf(.SortOrder = lvwDescending, "up", "down") '|Изменяем вид иконки (если она есть) при сортировке
        .Sorted = True
        For i = 1 To .ListItems.Count 'Выводим данные в нужном формате
            If ColumnHeader.Index = 2 Then
                .ListItems(i).ListSubItems(ColumnHeader.Index - 1).Text = Format(CDate(.ListItems(i).ListSubItems(ColumnHeader.Index - 1).Text), "dd.mm.yyyy HH:MM")
            End If
            
            If ColumnHeader.Index = 3 Then
                .ListItems(i).ListSubItems(ColumnHeader.Index - 1).Text = Format(CDate(.ListItems(i).ListSubItems(ColumnHeader.Index - 1).Text), "HH:MM")
            End If
        Next i
    End With
End Sub

Адаптируйте под себя.
Успехов!
Ошибка method 'open' of object '_Recordset' failed при выполнении запроса, Запрос к MySQL
 
[B][I][SIZE=12pt]А-А-А-А-А!
Это ужасно! Я, хотите верьте, хотите нет, но уже два дня ковыряюсь и не могу понять в чем дело? И на библиотеки грешил и на драйвер, переустанавливал кучу раз, но увы всё четно. А оно вот как: СЛОНА ТО Я И НЕ ЗАМЕТИЛ.
Андрей VG, спасибо Вам за подсказку! Впредь буду внимательнее.
Ошибка method 'open' of object '_Recordset' failed при выполнении запроса, Запрос к MySQL
 
Доброго времени суток!
На компьютере есть установлен сервер. Установил также и ODBS Driver (конектор).
Подключение к серверу из ВБА получается, но вот выполнить запрос - никак.
При этом через консоль сервера или через "Использование источника данных" в эксель, запрос выполняется успешно.
Подскажите пожалуйста, что не так?
Код
    Dim sSQL As String
    Set FConn = New ADODB.Connection
    Set pFilter = New ADODB.Recordset
    pFilter.CursorLocation = adUseClient
    FConn.Open "DRIVER={MySQL ODBC 5.1 Driver}; SERVER=localhost; USER=root; PASSWORD=MyPassword; Option=3"
    sSQL = "SELECT * FROM keep_3.keep"
    pFilter.Open sSQL, FConn.ConnectionString, adOpenKeyset, adLockOptimistic
    If pFilter.RecordCount > 0 Then
    ...
ошибка возникает на строке:
Код
pFilter.Open sSQL, FConn.ConnectionString, adOpenKeyset, adLockOptimistic
Заранее всем спасибо за помощь!
Маска ввода домашнего адреса, может кому пригодится
 
Доброго времени суток!
Задался вопросом создания маски ввода домашнего адреса в одной строке. Пока, немного конечно, "костылем", но вроде работает.
Буду рад любым советам или критике.
Заранее спасибо всем и успехов!
Использование формулы записанной в TextBox
 
Спасибо Вам большое!
Использование формулы записанной в TextBox
 
Доброго времени суток!
Подскажите пожалуйста, можно ли и как (если можно) использовать формулу которая написана в TextBox?
Заранее всем спасибо!
Как сравнить два разных прайса и выделить цены, сравнить прайсы и выделить цены
 
Я перенес лист из прайса 2 в книгу первого прайса. В стандартном модуле код:
Код
Sub oo()
    For i = 5 To 124
       For j = 20 To 156
        If Sheets("TDSheet (2)").Cells(i, 4) = Sheets("TDSheet").Cells(j, 3) Then
            If Sheets("TDSheet (2)").Cells(i, 6) < Sheets("TDSheet").Cells(j, 6) Then
                Sheets("TDSheet (2)").Cells(i, 6).Interior.ColorIndex = 6
            End If
        End If
       Next j
    Next i
End Sub

Но вот проблема: у Вас там нечего сравнивать. Нет одинаковых наименований. Все разные.
Изменить цвет ячеек в зависимости от условий макросом
 
Цитата
а зечем нужен УФ с его заливками,
Да как бы уже и не зачем. Разве только для визуальной красоты?!
Изначально планировалось, что цвет ячейки станет условием для заполнения таблицы. Ну а теперь...
Изменить цвет ячеек в зависимости от условий макросом
 
Kuzmich! Простите, не увидел Ваш скрипт.
Всем спасибо за помощь, советы и за легкий "нагоняй"! )))
Изменить цвет ячеек в зависимости от условий макросом
 
Не судите строго. Что смог.
Код
Sub Month()
    j = 1
    For i = 3 To 14
        For x = 2 To 32
            Select Case x
                Case 30, 31, 32
                    If IsDate(i - 2 & "/" & x - 1 & "/" & Range("N1")) = False Then
                    Else
                        Cells(i, x) = j
                    End If
                Case Else
                    Cells(i, x) = j
            End Select
            j = j + 1
        Next x
    Next i
End Sub
Изменить цвет ячеек в зависимости от условий макросом
 
Цитата
Цикл будет по дням с первого числа по максимальное в месяце, вот и вычисляйте  количество дней в месяце.
Вы уж меня простите, но я по неволе сам себе пса напоминаю. Логику и порядок действий понимаю, но сказать в скрипте этого не могу. Не  могу понять как объяснить экселю, что ячейка эта определенная дата и тем более, как у него спросить существует ли эта дата?
Изменить цвет ячеек в зависимости от условий макросом
 
Цитата
Возможно у автора темы компьютеры 10 - 20 летней давности
У меня такое чувство, что год вымирания динозавров и является годом выпуска компьютера.  :D  
Изменить цвет ячеек в зависимости от условий макросом
 
По теме. Поскольку как сделать проверку я не знаю, решил пойти другим путем. Т.к. количество дней в месяцах (кроме февраля) являются константными, решил не нужное заранее закрасить и проверять только  29.02.????. Если таковое число есть, тогда не закрашиваю, ну и наоборот если такого нет. Может конечно костылем... Но уж не судите строго. ))
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("N1")) Is Nothing Then
        If Target.Cells.Count > 1 Then Exit Sub
        If CDate(Format("28.02." & Range("N1"), "dd.mm.yyyy")) + 1 = "29.02." & Range("N1") Then
            Range("AD4").Interior.ColorIndex = xlNone
        Else
            Range("AD4").Interior.ColorIndex = 23
        End If
    End If
End Sub
Изменить цвет ячеек в зависимости от условий макросом
 
Цитата
Не думаю, что это из-за железа
На домашнем ноутбуке всё работало. Но может и стал криво?!
Изменить цвет ячеек в зависимости от условий макросом
 
Цитата
никаких затруднений не испытывал.
Пробовал в свое время установить 2007. При любой попытке запуска офиса машина висла. Помогала только наглая перезагрузка. Я как бы уже привык в кустарных условиях работать. ))
Изменить цвет ячеек в зависимости от условий макросом
 
Цитата
Может уже стоит обновиться?
Абсолютно с Вами согласен. Только руководство упорно не хочет использовать дополнительную карту расходов на новые машины. А нынешнее оборудование не справится с новым офисом. ( Ну это я немного поплакался в жилетку ).
Цитата
Т.е. цвет заливки ячейки будет для макроса неким условием
Точно так. Только я в качестве условия использовал именно конкретно указанный цвет.
Цитата
Заполняйте график, проверяя именно даты попадающие/не попадающие куда надо
Вот тут мне не понятно. Как макросом определить есть такая дата в месяце или её нет?
П.С. Спасибо, что обратили внимание на тему!  
Изменить цвет ячеек в зависимости от условий макросом
 
Доброго времени суток!
Есть таблица 12х31 (годовой график выходов на работу). Необходимо закрасить другим цветом те ячейки, которые соответствуют дням отсутствующим в месяце указанного года (т.е 29,30,31 февраля, 31 апреля и т.д.). С этой задачей легко справляется УФ. Но проблема в том, что далее мне необходимо будет циклом заполнить график значениями из формы. А XL уперто не хочет воспринимать заливку УФ как другой цвет. Подскажите пожалуйста, как сменить цвет ячеек макросом? Заранее огромное спасибо всем!
П.С. Офис 2003 года
С помощью макроса найти с конца столбца первую пустую строку сверху
 
Код
For i = Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
If Cells(i, 1) = "" Then Cells(i, 1).Select: MsgBox "Вот она!": Exit Sub
Next
Изменено: Ronin751 - 10.03.2018 23:00:31
Макрос: копирование ячеек
 
Конкретно для Вашего файла:
В стандартный модуль
Код
Sub Copy_cell()
    For i = 3 To 167 Step 2
        Cells(i, 2) = Cells(i - 1, 2)
    Next
End Sub
П.С. Измените имя пользователя. Ваше нарушает правила форума.
Ошибка при создании контекстного меню на UserForm, До сегодня всё работало
 
Все_просто! Спасибо большое за ссылку, помогло. Успехов Всем!
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 31 След.
Наверх