Gwiazdki w InputBox-e

Czytając dzisiaj posty na forum dyskusyjnym goldenline.pl natrafiłem na bardzo elegancki sposób realizacji tytułowych gwiazdek w InputBox-e. Rozwiązanie opiera się o API Windows i wygląda następująco:

Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
                                                      ByVal ncode As Long, _
                                                      ByVal wParam As Long, _
                                                      lParam As Any) As Long
Private Declare Function GetModuleHandle Lib "kernel32" _
                                         Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private 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
Private Declare Function UnhookWindowsHookEx Lib "user32" _
                                             (ByVal hHook As Long) As Long
Private Declare 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 Function GetClassName Lib "user32" _
                                      Alias "GetClassNameA" (ByVal hwnd As Long, _
                                                             ByVal lpClassName As String, _
                                                             ByVal nMaxCount As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long

Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0
Private hHook  As Long



Public Function NewProc(ByVal lngCode As Long, _
                        ByVal wParam As Long, _
                        ByVal lParam As Long) As Long
    Dim RetVal
    Dim strClassName As String
    Dim 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
    End If
    CallNextHookEx hHook, lngCode, wParam, lParam
End Function



Public Function InputBoxDK(Prompt, _
                           Optional Title, _
                           Optional Default, _
                           Optional XPos, _
                           Optional YPos, _
                           Optional HelpFile, _
                           Optional Context) As String
    Dim lngModHwnd As Long
    Dim lngThreadID As Long
    lngThreadID = GetCurrentThreadId
    lngModHwnd = GetModuleHandle(vbNullString)
    hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
    On Error Resume Next
    InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
    UnhookWindowsHookEx hHook
End Function

Sub PasswordBox()

    If InputBoxDK("Proszą wprowadzić hasło", "Wymagane hasło") <> "ania" Then
        MsgBox "Niestety, to nie było prawidłowe hasło."
    Else
        MsgBox "Hasło prawidłowe! Zapraszamy."
    End If

End Sub

Moim skromnym zdaniem rozwiązanie jest świetne gdyż nie musimy korzystać z dedykowanego userforma, co w wielu przypadkach jest idealnym rozwiązaniem.

Nowość w CreateWorkspace wprowadzona od wersji Access 2007

CreateWorkspace Method [Access 2007 Developer Reference]: "ODBCDirect workspaces are not supported in Microsoft Office Access 2007. Setting the type argument to dbUseODBC will result in a run-time error. Use ADO if you want to access external data sources without using the Microsoft Access database engine."

Oznacza to ni mniej ni więcej to że nie da się wykonać następującego kodu:

Sub dbOpenDynamicX()

Dim wrkMain As Workspace
Dim conMain As Connection
Dim qdfTemp As QueryDef
Dim rstTemp As Recordset
Dim strSQL As String
Dim intLoop As Integer

' Create ODBC workspace and open connection to
' SQL Server database.
Set wrkMain = CreateWorkspace("ODBCWorkspace", _
"admin", "", dbUseODBC)

' Note: The DSN referenced below must be configured to 
'       use Microsoft Windows NT Authentication Mode to 
'       authorize user access to the Microsoft SQL Server.    
Set conMain = wrkMain.OpenConnection("Publishers", _
dbDriverNoPrompt, False, _
"ODBC;DATABASE=pubs;DSN=Publishers")

' Open dynamic-type recordset.
Set rstTemp = _
conMain.OpenRecordset("authors", _
dbOpenDynamic)

With rstTemp
Debug.Print "Dynamic-type recordset: " & .Name

' Enumerate records.
Do While Not .EOF
Debug.Print "    " & !au_lname & ", " & _
!au_fname
.MoveNext
Loop

.Close
End With

conMain.Close
wrkMain.Close

End Sub 

Skutkuje to tym że nie możemy stworzyć obiektu wrkMain służącego nam podczas otwierania połączania.
Jaki z tego płynie wniosek: piszmy od razu w ADO jeżeli zamierzamy korzystać z zewnętrznej bazy danych w naszym projekcie Accessowym.

Design navigation UI with Access 2010

Kolejna bardzo ciekawa funkcja moim zdaniem w Accessie. Dzięki takiej kontrolce w łatwy sposób możemy budować nawet zaawansowane struktury w bardzo szybki i intuicyjny sposób.

Access 2010 - The Web Browser Control Feature

Nowe kontrolki takie jak prezentowany Web Browser otwierają zupełnie nowe możliwości przez starym poczciwym Accessem :)

z ciekawostek mogę podać fakt w jaki sposób mozemy operować tą kontrolką, która de fakto jest osadzonym internet explorerem. Zrobimy to dzięki obiektowi Object znajdującego się wewnątrz kontrolki Web Browser-a. np.

Me.myWebBrowserControl.Object.Navigate myUrl

pozwoli nam na swobodne nawigowanie do dowolnie wybranej strony. Korzystanie z metody POST również będzie się odbywać za pomocą tego obiektu.

Wysyłanie maila za pomocą CDO

Biblioteka CDO obecna w systemie Windows świetnie nadaje się do masowego wysyłania wiadomości mailowych za pomocą za pomocą wszelakiej maści skryptów. Przykładowy skrypt wysyłający wiadomość HTML z osadzonym obrazkiem i dwoma załącznikami znajduje się w kodzie poniżej:

Option Explicit

' skracamy sobie trochę długość w ustawieniach
Private Const cdo_conf As String = "http://schemas.microsoft.com/cdo/configuration/"

Const cdoSendUsingPickup = 1 'wyslij wiadomość do katalogu z którego podejmie ją serwer
Const cdoSendUsingPort = 2 ' wysyłaj wiadomości na port serwer-a
Const cdoAnonymous = 0 'brak
Const cdoBasic = 1 'jawny tekst
Const cdoNTLM = 2 'NTLM
Const cdoRefTypeId = 0
Const cdoRefTypeLocation = 1

Sub CDO_Mail_Small_Text()

Dim strbody As String
Dim iMsg   As Object 'CDO.Message
Dim iConf  As Object 'CDO.Configuration
Dim Flds As Object

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")

iConf.Load -1    ' CDO Source Defaults
Set Flds = iConf.Fields

' ustawienie parametrów serwera z którego korzystamy
With Flds
.Item(cdo_conf & "sendusername") = "user" 'login
.Item(cdo_conf & "sendpassword") = "xxxxxx" 'hasło
.Item(cdo_conf & "smtpserver") = "poczta.o2.pl" 'serwer SMTP
.Item(cdo_conf & "smtpserverport") = 465 ' port
.Item(cdo_conf & "sendusing") = cdoSendUsingPort 'metoda wysyłania
.Item(cdo_conf & "smtpauthenticate") = cdoBasic 'metoda uwieżytelnienia
.Item(cdo_conf & "smtpusessl") = 1 ' kodowany kanał
.Update
End With

strbody = "Hi there" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"


With iMsg.Fields
' priorytet
.Item("urn:schemas:mailheader:X-MSMail-Priority") = "High" ' Dla Outlook 2003
.Item("urn:schemas:mailheader:X-Priority") = 2    ' Dla Outlook 2003 i innych np. Thunderbird-a
.Item("urn:schemas:httpmail:importance") = 2 ' Dla Outlook Express

' własny nagłówek
.Item("urn:schemas:mailheader:X-myfield") = "Email-Okay"
.Update
End With

With iMsg
Set .Configuration = iConf

' wielu odbiorców
.To = "user@gazeta.pl; user@gmail.com"
.CC = "" ' kopia
.BCC = "" ' ukryta kopia
.From = "user@o2.pl"       ' istotne wysyłamy w kontekście konkretnego konta pocztowego
.Subject = "Raport"         ' temat
.TextBody = strbody         ' wiadomość w postaci tekstu, jest niezależna od tej w HTML-u
' wiadomość w HTML-u. obrazek jako źródło ma ustawione cid:header.gif - ten sam nagłówek został dodany w kolejnej sekcji
.HTMLBody = "<img src='cid:header.gif'><br>" & Replace(strbody, vbNewLine, "<BR>" & vbNewLine)

' dodanie załącznika
.AddAttachment "d:\msg\indeksowanie.xlsm"
.AddAttachment "d:\msg\import_status.xlsx"

' dodaie obrazka wykorzystanego w wiadomości HTML
.AddRelatedBodyPart "d:\msg\header.gif", "header.gif", cdoRefTypeId

.Send ' wyślij
End With

End Sub

Jeżeli chcielibyśmy manipulować zawartością w zależności od adresata to od razu powiem – jest taka możliwość o czym opowiem w kolejnym odcinku.

WAMP i SKYPE

Platforma WAMP nie chce działać popranie w momencie gdy jakiś program zajmie jej porty 80 i 443. Coś takiego może się zdarzyć jak korzystamy z programu SKYPE który domyślnie podczas startu nasłuchuje na tych portach. Możemy to wyłączyć w aplikacji SKYPE, tak aby nie mieć z tym problemu w przyszłości.

Po wyłączeniu tej opcji należy uruchomić ponownie Skyp-a, o czym jesteśmy informowani. Na końcu zaś możemy już uruchomić Apache bez żadnych problemów.

Funkcja VBA do wyłuskiwania teksu

W dzisiejszym odcinku pokażę gotową funkcję umożliwiającą wyłuskiwanie tekstu na podstawie wzorca RegExp. Funkcja ta jest niezwykle prosta, a zarazem niezwykle użyteczna, gdyż ma o wiele szersze możliwości niż standardowe rozwiązania obecne w VBA lub Excel-u.

Function RegExpString(sString As String, pattern As String, _
                      Optional iMath As Integer = 0, _
                      Optional bIgnoreCase As Boolean = True, _
                      Optional bGlobal As Boolean = True) As String

    Dim oRegExp As Object
    Dim oMatches As Object

    On Error GoTo ERR_Handler:

    If pattern = "" Then
        RegExpString = ""
        Exit Function
    End If

    If sString = "" Then
        RegExpString = ""
        Exit Function
    End If
    
    Set oRegExp = CreateObject("vbScript.RegExp")
    With oRegExp
        .IgnoreCase = bIgnoreCase
        .Global = bGlobal
        .pattern = pattern
        Set oMatches = .Execute(sString)
    End With

    If oMatches.Count - 1 < iMath Then
        RegExpString = ""
        Exit Function
    End If
    
    RegExpString = oMatches(iMath).Value

END_Handler:

    Set oRegExp = Nothing

     Exit Function

ERR_Handler:

    RegExpString = ""

    Resume END_Handler:

End Function

Parametry funkcji to:

• sString - tekst w którym wyszukujemy 
• pattern - Wzorzec wykorzystany do wyszukiwania 
• iMath - numer przypisania w kolekcji ze wszystkimi pasującymi elementami. Może się okazać że mamy ich więcej niż jedno trafienie 
• bIgnoreCase - Ignoruj wielkość liter 
• bGlobal - badaj wszystkie możliwe kombinacje w ciągu

Przykład wykorzystania to np.:

Debug.Print RegExpString("ala ma psa, a kot to fafik","ala ma ?(kota|psa)")