Pokazywanie postów oznaczonych etykietą VBA. Pokaż wszystkie posty
Pokazywanie postów oznaczonych etykietą VBA. Pokaż wszystkie posty

niedziela, 2 października 2011

Szybkie sprawdzenie czy czy istnieje tabela o podanej nazwie

ADODB daje nam szereg możliwości. Jedną z nich jest możliwość pobrania informacji o strukturze bazy do której się podłączyliśmy. Przypadkiem szczególnym takich baz są bazy plikowe czyli popularne pliki mdb i accdb. Przypadkiem jeszcze bardziej szczególnym zaś są pliki Excel-a które można traktować jak pliki bazodanowe.

Po podłączeniu do do tkiego pliku wystarczy uruchomić jedną metodę aby uzyskać pełen komplet informacji na temat tego zo znajduje się w środku a co najważniejsze nie musimy takiego pliku otwierać za pomocą Excel-a co mogło by być naprawdę czasochłonne.

Metoda o której mówię to OpenSchema, zaś parametr odpowiadający za pobranie informacji o tabelach to: adSchemaTables.

Przykładowy skrypt wykorzystujący ta metodę:
Function GetTablesFromDatabase(Plik As String, Tabela As String) As Boolean
    
    Dim aRs As ADODB.Recordset
    Dim aConn As ADODB.Connection
    Dim sConn As String
    Dim e As Long
    Dim ext As String
    
    e = InStrRev(Plik, ".")
    ext = Right(Plik, Len(Plik) - e)
    
    Select Case ext
        Case "xls"
            sConn = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & Plik & "; Extended Properties =""Excel 8.0;HDR=Yes;IMEX=1"";"
        Case "xlsx"
            sConn = "Provider =Microsoft.ACE.OLEDB.12.0; Data Source =" & Plik & "; Extended Properties =""Excel 12.0 Xml;HDR=YES"";"
        Case "mdb"
            sConn = "Provider =Microsoft.Jet.OLEDB.4.0; Data Source =" & Plik & " ; User Id =admin; Password =;"
        Case "accdb"
            sConn = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source =" & Plik & ";"
    End Select

On Error GoTo ERR_Handler:

    Set aConn = New ADODB.Connection
    With aConn
        .Mode = adModeShareDenyNone
        .CursorLocation = adUseServer
        .ConnectionString = sConn
        .Open
    
        Set aRs = aConn.OpenSchema(adSchemaTables)
    
        aRs.MoveFirst
        aRs.Filter = "TABLE_NAME='" & Tabela & "'"
    
        Do While Not aRs.EOF
            If aRs.Fields("TABLE_NAME").Value = Tabela Then
                GetTablesFromDatabase = True
                Exit Do
            End If
            aRs.MoveNext
        Loop
    
        .Close
    End With
    
    Exit Function
    
ERR_Handler:

    MsgBox Err.Description
    If aConn.State > 0 Then
        aConn.Close
    End If
    
End Function

Przykładowe wykorzystanie
Sub test()
    Debug.Print GetTablesFromDatabase("E:\Dane\user\Moje Dokumenty\zeszyt1.xls", "Arkusz1$")
End Sub

Uzyskujemy w ten sposób informację o tym czy dany arkusz istnieje w bazie danych czy też nie.

czwartek, 17 lutego 2011

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.

niedziela, 17 października 2010

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.

wtorek, 21 września 2010

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)")

piątek, 27 sierpnia 2010

Sprawdzenie czy plik jest otwarty przez inny program

Znalazłem ciekawy kawałek kodu w internecie do sprawdzenia czy dany plik nie został otwarty w innej aplikacji. np. plik Excel-a. Kod ten wykorzystuje API Windows.
Option Explicit

'===========================================

'http://www.xcelfiles.com/IsFileOpenAPI.htm

'===========================================

'// Note we use an Alias here as using the Actual
'// function name will not be accepted! ie underscore= "_lopen"
Private Declare Function lOpen _
                          Lib "kernel32" _
                              Alias "_lopen" ( _
                              ByVal lpPathName As String, _
                              ByVal iReadWrite As Long) _
                              As Long

Private Declare Function lClose _
                          Lib "kernel32" _
                              Alias "_lclose" ( _
                              ByVal hFile As Long) _
                              As Long

'// Don't use these...here for Info only

Private Const OF_SHARE_COMPAT = &H0
Private Const OF_SHARE_DENY_NONE = &H40
Private Const OF_SHARE_DENY_READ = &H30
Private Const OF_SHARE_DENY_WRITE = &H20

'// Use the Constant below
'// OF_SHARE_EXCLUSIVE = &H10
'// OPENS the FILE in EXCLUSIVE mode,
'// denying other processes AND the current process both read and write
'// access to the file. If the file has been opened in any other mode for read or
'// write access _lopen fails. This is important as if you open the file in the
'// current process = Excel BUT loose its handle
'// then you CANNOT open it again in the SAME session!
Private Const OF_SHARE_EXCLUSIVE = &H10

'If the Function succeeds, the return value is a File handle.
'If the Function fails, the return value is HFILE_ERROR = -1

Private Function IsFileAlreadyOpen(strFullPath_FileName As String) As Boolean
'// Ivan F Moala
'// http://www.xcelfiles.com
    Dim hdlFile As Long
    Dim lastErr As Long
    hdlFile = -1
    '// Open file for Read/Write and Exclusive Sharing.
    hdlFile = lOpen(strFullPath_FileName, OF_SHARE_EXCLUSIVE)
    '// If we can't open the file, get the last error.
    If hdlFile = -1 Then
        lastErr = Err.LastDllError
    Else
        '// Make sure we close the file on success!
        lClose (hdlFile)
    End If
    '// Check for sharing violation error.
    IsFileAlreadyOpen = (hdlFile = -1) And (lastErr = 32)
End Function

Private Function LastUser(strPath As String) As String
'// Code by Helen from http://www.visualbasicforum.com/index.php?s=
'// This routine gets the Username of the File In Use
'// Credit goes to Helen for code & Mark for the idea
'// Insomniac for xl97 inStrRev
'// Amendment 25th June 2004 by IFM
'// : Name changes will show old setting
'// : you need to get the Len of the Name stored just before
'// : the double Padded Nullstrings

    Dim strXl  As String
    Dim strFlag1 As String, strflag2 As String
    Dim i As Integer, j As Integer
    Dim hdlFile As Long
    Dim lNameLen As Byte

    strFlag1 = Chr(0) & Chr(0)
    strflag2 = Chr(32) & Chr(32)

    hdlFile = FreeFile
    Open strPath For Binary As #hdlFile
    strXl = Space(LOF(hdlFile))
    Get 1, , strXl
    Close #hdlFile
    j = InStr(1, strXl, strflag2)
    
#If Not VBA6 Then
    '// Xl97
    For i = j - 1 To 1 Step -1
        If Mid(strXl, i, 1) = Chr(0) Then Exit For
    Next
    i = i + 1
#Else
    '// Xl2000+
    i = InStrRev(strXl, strFlag1, j) + Len(strFlag1)
#End If

    '// IFM
    lNameLen = Asc(Mid(strXl, i - 3, 1))
    LastUser = Mid(strXl, i, lNameLen)

End Function
Wykorzystanie przykładowe znajduje się w kodzie poniżej:
Sub TestAPI()
'// We can use this for ANY FILE not just Excel!
    Dim t      As String
    t = "C:\Users\Przemek\Documents\pivot from db.xls"
    If IsFileAlreadyOpen(t) Then
        MsgBox t & " is already Open" & vbCrLf & "By " & LastUser(t), vbInformation, "File in Use"
    Else
        MsgBox "File is NOT open", vbInformation
    End If
End Sub
Trzeba zaznaczyć że funkcje są zadeklarowane jako prywatne i nie będą widoczne poza modułem w który zostały wklejone. Jeżeli ktoś chciał by je wykorzystać w innym miejscu konieczna może się okazać zmiana Private na Public.

sobota, 3 lipca 2010

Konwertowanie UTF-8 do Unicode w VBA

Kiedyś znalazłem kod do konwertowania tekstu w UTF-8 do Unicode. Przydaje się to czasem podczas przetwarzania danych ze stron web.

Private Const CP_UTF8 = 65001

Private Declare Function MultiByteToWideChar Lib "kernel32" ( _
                                             ByVal CodePage As Long, ByVal dwFlags As Long, _
                                             ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, _
                                             ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long

Public Function sUTF8ToUni(bySrc() As Byte) As String
' Converts a UTF-8 byte array to a Unicode string
    Dim lBytes As Long, lNC As Long, lRet As Long

    lBytes = UBound(bySrc) - LBound(bySrc) + 1
    lNC = lBytes
    sUTF8ToUni = String$(lNC, Chr(0))
    lRet = MultiByteToWideChar(CP_UTF8, 0, VarPtr(bySrc(LBound(bySrc))), lBytes, StrPtr(sUTF8ToUni), lNC)
    sUTF8ToUni = Left$(sUTF8ToUni, lRet)
End Function

sobota, 20 lutego 2010

Korespondencja seryjna z punktu widzenia VBA

W dzisiejszym odcinku przedstawiam makro generujące dokument Word-a na podstawie szablonu. Makro takie można wykorzystać np. z poziomu Excel-a lub Access-a do automatyzacji korespondencji seryjnej . Parametryzacji ewentualnie wymagały by parametry będące w stringach tekstowych.
Sub generuj_dokument()
    
    ' deklaracje zmiennych, może być potrzebna referencja w projekcie
    Dim w As Word.Application
    Dim d As Word.Document
    Dim nd As Word.Document
    Dim m As Word.MailMerge
    Dim wAllert As Word.WdAlertLevel
    
    Dim sConn As String
    Dim sComm As String
    Dim sFile As String
    Dim sFileOut As String
    Dim sDefaultDir As String
    Dim sTemplate As String
    Dim sPass As String

    sComm = "SELECT * FROM `Arkusz1$`" 'zapytanie sql z którego korzystamy
    sPass = "xxxxxxxx" ' hasło do pliku template
    sDefaultDir = "C:\Users\user\Documents\" ' katalog domyślny dla operacji
    sTemplate = sDefaultDir & "dokument.docx" ' plik szablonu
    sFileData = sDefaultDir & "dane.xlsx" ' plik z danymi
    sFileOut = sDefaultDir & "dane_out.docx" ' plik wyjściowy
    
    ' connection String, w tym przypadku dla Excel-a 12
    sConn = ""
    sConn = "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" & sFileData & ";Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Engine Type=37;Jet OLEDB:Database Locki"

    On Error Resume Next
    
    ' istniejący obiekt
    Set w = GetObject(, "Word.Application")
     
    If Err.Number <> 0 Then
        ' nowy obiekt
        Set w = CreateObject("Word.Application")
    End If

    ' wyłączenie alertu o pobieraniu danych
    wAllert = w.DisplayAlerts
    w.DisplayAlerts = wdAlertsNone
    Set d = w.Documents.Open( _
            FileName:=sTemplate, _
            PasswordDocument:=sPass)
    w.DisplayAlerts = wAllert
    Set m = d.MailMerge

    With m
        .OpenDataSource _
                Name:=sFileData, _
                SQLStatement:=sComm, _
                SubType:=wdMergeSubTypeAccess, _
                Connection:=sConn
        .Destination = wdSendToNewDocument
        If .State = wdMainAndDataSource Then
            .Execute
        Else
            MsgBox "problem w wypełnieniu dokumentu"
            Exit Sub
        End If
    End With

    ' obiekt nowo utworzonego dokumentu po wypełnieniu
    Set nd = ActiveDocument
    
    With nd
        .SaveAs _
                FileName:=sFileOut, _
                FileFormat:=wdFormatXMLDocument
        .Close
    End With
    
    d.Close False
    w.Quit
    
    Set nd = Nothing
    Set d = Nothing
    Set w = Nothing

End Sub

I taka mała uwaga na koniec. Plik Excel-a z którego korzystamy powinien być zamknięty na czas kiedy korzystamy z makra.

piątek, 19 lutego 2010

Masowy zapis z korespondencji seryjnej

Korespondencja seryjna to świetny wynalazek. Niesamowicie ułatwia życie, gdy np. chcemy wygenerować i wydrukować kilkaset listów. W momencie jednak gdy chcemy tylko wygenerować i zapisać jako pliki te dokumenty stajemy przed ścianą.

Prostym rozwiązaniem tej niedogodności jest to oto makro
Sub Generuj_i_Zapisz()

    Dim w As MailMerge
    Dim a As Long
    Dim sFileName As String

On Error GoTo ERR_Handler

    Application.ScreenUpdating = False
    Application.Visible = False
    
    Set w = ActiveDocument.MailMerge

    w.DataSource.ActiveRecord = wdFirstDataSourceRecord

    For a = 0 To w.DataSource.RecordCount

        With w
            .Destination = wdSendToNewDocument
            .SuppressBlankLines = True
            With .DataSource
                .FirstRecord = a
                .LastRecord = a
            End With
            .Execute Pause:=False
            
        End With
      
        ' składamy nazwę pliku z jakiś elementów np. z kolumn źródła danych
        sFileName = "C:\Users\Przemek\Documents\w\" & w.DataSource.DataFields("c").Value & ".docx"
        
        ActiveDocument.Parent.ScreenUpdating = False
        ActiveDocument.SaveAs _
            FileName:=sFileName, _
            FileFormat:=wdFormatXMLDocument, _
            LockComments:=False, _
            Password:="", _
            AddToRecentFiles:=True, _
            WritePassword:="", _
            ReadOnlyRecommended:=False, _
            EmbedTrueTypeFonts:=False, _
            SaveNativePictureFormat:=False, _
            SaveFormsData:=False, _
            SaveAsAOCELetter:=False
        ActiveWindow.Close
    
        w.DataSource.ActiveRecord = wdNextRecord
    
    Next
    
END_Handler:

    Application.Visible = True
    Application.ScreenUpdating = True
    
    Exit Sub

ERR_Handler:
    
    MsgBox Err.Description
    
    Resume END_Handler:
    
End Sub

Komentarza w zasadzie wymagać może tylko linia
sFileName = w.DataSource.DataFields("c").Value & ".docx"
gdzie DataFields("c") to nazwa kolumny ze źródła danych - w przypadku danych użytkownika trzeba to zmienić lub użyć własnego kodu VBA. Ewentualnie zamiast nazwy możemy podać numer obiektu w kolekcji.

poniedziałek, 25 stycznia 2010

Współpraca MSSQL 2008 Express z pakietem Office

Zapraszam wszystkich do lektury materiału, którego jestem autorem.


Zaznaczam od razu że materiał ten może ewoluować  zgodnie z aktualnymi potrzebami odbiorców. Dlatego też zachęcam do dyskusji na temat treści w nim zawartych.

czwartek, 21 stycznia 2010

Biblioteka COM napisana w VB.NET domowym sposobem

Każdy kto pisze bardziej zaawansowane projekty w języku VBA wie co to biblioteka zewnętrzna poszerzająca możliwości piszącego aplikację. Dodaje się je za pomocą referencji w projekcie lub też korzysta z plików widocznych w rejestrze Windows. W pewnym momencie dochodzimy do takiego momentu że sami chcielibyśmy utworzyć taką bibliotekę  zawierającą nasze ulubione funkcje, jakieś elementy które chcemy ukryć przed wścibskimi oczami osób postronnych lub chcemy dodać funkcjonalności nigdzie indziej nie dostępne.

niedziela, 18 października 2009

RegExp - jak to wykorzystać

Wstęp
W dzisiejszej odsłonie pokażę przykładowe wykorzystanie wyrażeń regularnych popularnie nazywanych Reular Expresion lub RegExp. Jest to potężne narzędzie służące do testowania, wyszukiwania lub podmiany tekstu na podstawie specyficznego wzorca - Patternu.
Wzorzec ten na pierwszy rzut oka przypomina spagetti - jakiś dziwny ciąg znaków bez ładu i składu. Nic bardziej mylnego. Ciąg ten jest aż do bólu logiczny, a każdy znaczek w nim coś oznacza.

niedziela, 19 lipca 2009

Wykorzystanie SQL-a w Excelu bez jakiejkolwiek bazy danych

Ostatnio wpadłem na dosyć oryginalny pomysł (pewnie nie ja pierwszy) wykorzystania silnika JET do wykonywania operacji na danych wprost z Excel-a. Pomysł opiera się na tym że można wskazać dowolny plik Excel jako źródło danych dla kwerendy SQL. Główkując chwilę stworzyłem procedurę tworzącą obiekt QueryTable w wybranej lokalizacji która zwraca wynik zapytania SQL. Jak wiadomo QueryTable to taki fajny mechanizm do prezentacji danych zewnętrznych w postaci tabelki. Ma wiele gadżetów ale nie o tym dziś mowa. Kod procedury i przykładowe wykorzystanie poniżej.

Plik do pobrania
Sub Raport(Target As Range, SQL As String, Optional Name)

Dim sConn As String
Dim sPath As String
Dim sName As String
Dim qt As QueryTable
Dim wks As Excel.Worksheet

If IsMissing(Name) Then
' sprawdź czy taki obiekt nie istnieje
sName = "Lista"
Else
sName = CStr(Name)
End If

On Error Resume Next
If ThisWorkbook.Names(sName).Name <> "" Then
If Err.Number = 0 Then
sName = sName & "_1"
End If
Err.Clear
End If

On Error GoTo ERR_Handler:
' ścieżka do pliku roboczego
sPath = ThisWorkbook.Path & "\" & ThisWorkbook.Name

' Connection String
sConn = "OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password=;User ID=Admin;Data Source=" & sPath & ";" & _
"Mode=Share Deny Write;Extended Properties=""HDR=YES;"";" & _
"Jet OLEDB:Engine Type=35;Jet OLEDB:Database Locking Mode=0;"

' skoroszyt roboczy
Set wks = Target.Parent

' sprawdź czy obiekt istnieje
If wks.QueryTables.Count > 0 Then
' generuje błąd jak QT nie ma, działanie celowe
Set qt = wks.QueryTables(sName)
Else
' generuj błąd braku obiektu
Err.Raise 9
End If

With qt   ' tworzymy obiekt QueryTable we wskazanej lokalizacji
.CommandType = xlCmdSql ' informacja o tym że korzystamy z polecenia SQL
.CommandText = SQL ' Komenda SQL, gdzie [Sheet1$] skoroszytem, po wstawieniu np. [lista] pobieramy dane z zakresu nazwanego
.Name = sName ' nazwa obiektu Querytable
.Refresh BackgroundQuery:=False 'pobieramy dane
End With

END_Handler:

Exit Sub

ERR_Handler:

Select Case Err.Number
Case 9
' tworzenie obiektu
Set qt = wks.QueryTables.Add(Connection:=sConn, Destination:=Target)
Resume Next

Case Else
MsgBox Err.Description
Resume END_Handler:
End Select

End Sub

' przykład wykorzystania
Sub test()
' wyswietl elementy ze skoroszytu Sheet1, znak $ konieczny do tego żeby JET wiedział że to cały skoroszyt
Raport Sheet3.Range("A1"), "select * from [Sheet1$]", "Wynik_2"
'policz oraz sumuj elementy z obszaru nazwanego lista
Raport Sheet3.Range("D1"), "select count(*) as ILE, sum(R) as [S] from [lista]", "Wynik_3"
End Sub

środa, 15 lipca 2009

Arkusze z Klasą

Język programowania dostarcza nam szereg funkcjonalności. Jedną z nich są klasy użytkownika. W odróżnieniu od modułów które mogą zawierać luźno powiązany ze sobą kod, klasa stanowi hermetyczną całość ściśle ze sobą powiązaną. Wymaga to bardziej abstrakcyjnego myślenia podczas programowania, niemniej jednak nagrodą są funkcjonalności niedostępne w podejściu modułowym.
Pracę z klasami rozpoczniemy od zrozumienia jak to w ogóle działa, gdyż bez tego nie ma co się brać za pisania :)

Klasa jest swego rodzaju kontenerem na inne elementy odseparowane w ramach tego pojemnika od innych części programu, dzięki czemu taką klasę można później swobodnie wykorzystać w innym projekcie. Tu muszę zaznaczyć że bezwzględnie należy stosować zasadę separacji i nie odwoływania się do jakiegoś elementu nadrzędnego. Powodem tego mogą być nieoczekiwane efekty w momencie gdyby przyszło nam do głowy stworzyć kolejną instancję klasy w obiekcie. Dojście do tego dlaczego mamy błąd było by niewątpliwie kłopotliwe.

Klasa jako taka nie może być wywołana jak zwykła funkcja lub procedura, musi być zadeklarowana do jakiegoś obiektu. Dopiero taki obiekt udostępnia nam dostęp do metod i właściwości publicznych w ramach danej klasy, są to odpowiednio odpowiedniki procedur i zmiennych. Osobnym elementem wymagającym szczególnego omówienia są Eventy, gdyż te nie mają odpowiednika w świecie modułów.

Event to zdarzenie które możemy stworzyć i wykorzystać do własnych celów. Działanie eventu jest bardzo proste. Mamy np. jakąś procedurę w klasie, procedura się wykonuje i w pewnym momencie następuje wyzwolenie event-a czyli wywołanie instrukcji RaiseEvent. W tym momencie następuje coś nieoczekiwanego z punktu widzenia podejścia standardowego, a mianowicie program przeskakuje do podprogramu obsługi event-a znajdującego się w kodzie głównym, czyli w miejscu gdzie nastąpiło wywołanie procedury z klasy.

Może brzmi to dziwnie, ale każdy bardziej zaawansowany programista VBA doskonale zna np. zdarzenia które oprogramowuje w skoroszycie np. Private Sub Worksheet_SelectionChange(ByVal Target As Range) lub Private Sub Worksheet_Calculate(). Widać tutaj pewną prawidłowość nazwa procedury składa się z dwu cześci rozdzielonych znakiem _. Pierwsza część to nazwa obiektu w którym programujemy Event-y, zaś część po znaku _ to nazwa eventu zadeklarowanego w klasie, reszta to parametry Eventu jakie będą przekazane do programu głównego.

Tu przedstawię ciekawostkę: nie można zadeklarować klasy w taki sposób aby tworzyła się samodzielnie instancja klasy wraz z obsługą Eventów. Ponadto Eventy są obsługiwane tylko w innych obiektach będących klasami czyli userformach, arkuszach, formularzach innych klasach. Nie są obsługiwane w modułach. O czym ja piszę :) bo pewnie brzmi to trochę po chińsku.
Chodzi mi o to że klasę można deklarować na dwa sposoby:

dim a as new clTest
a.test

Coś takiego możemy zadeklarować w dowolnym miejscu, działa to tak że klasa clTest działa dopiero po pierwszym użyciu. dzięki czemu nie musimy sobie zaprzątać głowy tym że np. instancja klasy nie jest zadeklarowana. Jeżeli jednak chcielibyśmy korzystać z dobrodziejstw Eventów trzeba postąpić w sposób bardziej wyrafinowany:

private WithEvents a as clTest

public sub wywolaj
set a = new clTest
a.test
end sub

private Sub a_test_event ()
msgbox ("a ku ku")
end sub

Jak widzimy w procedurze Wywołaj jawnie deklarujemy nową instancję klasy, co może być kłopotliwe przy wielokrotnym wykorzystani tej metody. Z odsieczą przyjdzie nam mała funkcja pozwalająca sprawdzić czy obiekt jest zadeklarowany:

Function IsNothing(vObject) As Boolean
On Error Resume Next
IsNothing = vObject Is Nothing
If Err.Number <> 0 Then IsNothing = True
End Function

Dzięki takiej funkcji możemy sprawdzić czy obiekt już został zadeklarowany.

public sub wywolaj
if IsNothing(a) then
set a = new clTest
end if
a.test
end sub

W takiej konstrukcji obiekt będzie tworzony tylko w momencie gdy jest niezadeklarowany.

Oddzielną kwestią jest to co się dzieje podczas tworzenia nowego obiektu. Klasy jako takie posiadają mechanizm konstruktora i destruktora czyli podprogramu uruchamianego w momencie tworzenia lub niszczenia obiektu klasy. bardzo praktycznym przykładem wykorzystania konstruktora i destruktora jest połączenie się z bazą danych i stworzenie obiektu ADODB.Connection podtrzymującego połączenie przez cały czas życia klasy czyli aż do zniszczenia obiektu lub wciśnięciu guzika Stop w edytorze VBA.

Deklaracja konstruktora i desruktora:

Private Sub Class_Initialize()
' kod konstruktora
End Sub

Private Sub Class_Terminate()
' kod destruktora
End Sub

wtorek, 14 lipca 2009

Uprawnienia w MSSQL-u do kolekcji parametrów

Dłubiąc dziś w SQL-u doszedłem co jest potrzebne do tego żeby kolekcja
parametrów w obiekcie typu ADODB.Parameters uzupełniła się sama po wpisaniu nazwy procedury. Trzeba mianowicie nadać prawo do wykonania EXECUTE userowi lub roli do obiektów
dbo.sp_ddopen oraz dbo.sp_sproc_columns.

uprawnienia dla użytkownika Guest

GRANT EXECUTE ON [dbo].[sp_ddopen] TO [guest]
GRANT EXECUTE ON [dbo].[sp_sproc_columns] TO [guest]
GO

uprawnienia dla roli Public

GRANT EXECUTE ON [dbo].[sp_ddopen] TO [public]
GRANT EXECUTE ON [dbo].[sp_sproc_columns] TO [public]
GO

Dzięki temu nie trzeba tworzyć kolekcji parametrów gdyż tworzy się sama

po podaniu nazwy procedury, dzięki czemu możemy podstawiać wartości bezpośrednio do istniejących elementów kolekcji

cmd.parameters("@par").value = "coś"

i są wszystkie parametry dostępne dla danej procedury łącznie z @return_value. Jak jest problem z uprawnieniami to tej kolekcji nie ma i trzeba sobie wszystkie parametry dodać ręcznie za pomocą konstrukcji:

cmd.Parameters.Append cmd.CreateParameter("@par", adChar, adParamInput, 50, "coś")

co jest niewygodne, lecz łatwe do osiągnięcia z poziomu kodu. Przydatne może być następujące zapytanie:

SELECT     S.name AS [Schema], PR.name, PA.name AS ParmName, T.name AS ParType, PA.max_length, PA.precision, PA.scale, PA.is_output, PA.has_default_value
FROM         sys.parameters AS PA INNER JOIN
sys.procedures AS PR ON PA.object_id = PR.object_id INNER JOIN
sys.schemas AS S ON PR.schema_id = S.schema_id INNER JOIN
sys.types AS T ON PA.system_type_id = T.system_type_id
WHERE     (PR.name = @RaportName) AND (S.name = @Schema)

Zwraca ono listę parametrów, które posiada procedura o nazwie zdefiniowanej w @RaportName i będącej w schemacie @Schema

niedziela, 14 czerwca 2009

Hakowanie w Accessie

Czasem mamy twardy orzech do zgryzienia z bazą napisaną przez nas lub przez kogoś obcego a występująca jedynie w postaci pliku mde - czyli wersji skompilowanej. Dla niewtajemniczonych plik taki to w pełni działająca aplikacja w której nie da się modyfikować formularzy, raportów i kodu VBA. Modyfikacja kwerend i makr jest dozwolona.

Naszym zadaniem jest poznanie Connection Stringa tak aby wydobyć z niego hasło, gdyż mamy niecny plan napisania lepszej aplikacji i potrzebujemy zalogować się na ten zewnetrzny serwer SQL.
Jeżeli w aplikacji znajduje się tabela podlinkowana lub kwerenda przekazująca to problem jest banalny. W przypadku zaś gdy nie ma takich obiektów jest trochę trudniej, ale nie beznadzijnie ;)
Do tego zadania wykorzystamye pewną cechę środowiska Access, które nie są wykorzystywana w codziennej pracy, a mianowicie możliwość dodania referencji w projekcie VBA do pliku mdb/mde dokładnie tak samo jak do biblioteki dll.



Na obrazku widzimy dodany do referencji projektu plik z tajnymi danymi. Na pasku bocznym zaś projekt będzie wyglądał następująco:



Widzimy listę obiektów do których możemy przeszukać pod kątem występowania obiektów do wykorzystania. Przeszukiwanie najłatwiej zrealizować za pomocą Object Browser-a

Ikonka Object Browser-a

Wybieramy tam z listy rozwijanej plik który przeszukujemy:



Pewną niedogodnością jest to że musimy się domyśleć jak działa sprawdzana aplikacja, gdyż obiekt do którego się odwołujemy sam z siebie może nie mieć oczekiwanych danych. Przy odrobinie szczęścia można dojść do tego na drodze dedukcji :)

Teraz najważniejsze: W jaki sposób dobrać się do takich danych?
Trzeba poprostu odwołać się do obiektu dokładnie tak samo jak by był normalnym obiektem, funkcją lub procedurą. Przykładowy kod poniżej
Sub test_conn()
Dim oConn As ADODB.Connection

mod_conn.Connec

Set oConn = mod_conn.fGetConn

Debug.Print oConn.ConnectionString
Debug.Print CurrentProject.Connection.ConnectionString

mod_conn.CloceConn

End Sub


przykładowy kod w module mod_conn wyglądał by np. tak:
Option Compare Database
Option Explicit

Private oConn As ADODB.Connection

Sub Connec()

Set oConn = New ADODB.Connection
oConn.ConnectionString = "Provider=sqloledb;Server=PRZEMEK-PC\SQLEXPRESS;Database=Aplikacja;Trusted_Connection=yes;"
oConn.Open

End Sub

Function fGetConn() As ADODB.Connection
Set fGetConn = oConn
End Function

Sub CloceConn()
oConn.Close
Set oConn = Nothing
End Sub

Widzimy tu że konieczne jest zainicjowanie połączenia za pomocą procedury Connec, informacje zaś o obiekcie Connection uzyskamy z funkcji fGetConn.

Jak się bronić?

Metoda jest bardzo prosta :) pisać kod w klasach, gdyż nie można utworzyć nowej instancji klasy znajdującej się w pliku z referencji.

pod tym linkiem można pobrać pliki do analizy w domowym zaciszu: projekt apollo

środa, 3 czerwca 2009

Krótka bajka o skracaniu (kodu)

Pokażę dziś w jaki sposób można sobie maksymalnie ułatwić życie wykorzystując pewne cechy programowania w VBA. Mi samemu z początku wydawało się to trochę abstrakcją, lecz po kilku(set) wykorzystanych razach stało się wręcz niezbędne. Ale do rzeczy :)

Język VBA udostępnia nam możliwość skracania odwołań do obiektów poprzez zastosowanie konstrukcji With....End With
With Obiekt
kod
End With
Gdzie:
Obiekt jak sama nazwa wskazuje jest Obiektem który będziemy wykorzystywać wielokrotnie
kod to czynności które wykonamy wykorzystując wcześniej zadeklarowane odwołanie do obiektu czyli korzystamy z jego metod i właściwości poprzedzając je znakiem kropki np.
.top = 10
Ciekawostką jest to że obiektem może być dowolne coś co zwraca nam w wyniku operacji zmienną obiektową np.
Function getFromTable(id As Integer) As Variant
With CurrentProject.Connection.Execute("select opishtml from tabela where id =" & id)
If .EOF Or .BOF Then getFromTable = Empty: Exit Function
getFromTable = Nz(.Fields.Item(0).Value, Empty)
End With
End Function
Wykorzystuję tu fakt że wynikiem wykonania metody .Execute jest obiekt ADODB.Recordset. Fakt jest to mocno niejawne ale działa :)

Wyjaśnienia mogą jeszcze wymagać elementy .EOF or .BOF - jest to sprawdzenie czy rekordset przypadkiem nie jest pusty. Gdyby był to kolejna linia wygenerował by błąd
getFromTable = Nz(.Fields.Item(0).Value, Empty)
Ta linia natomiast podstawia pod zmienną wartość elementu o indeksie 0 z kolekcji .Fields. Elementy tej kolekcji budują pojedynczy wiersz Recordset-a. Sprawdzam przy okazji czy wartość przypadkiem nie jest Null i jak jest to podstawiam Empty
Funkcja Nz jest z defaultu dostępna tylko w Accessie, ale bardzo łatwo ją skonstruować samodzielnie z wykorzystaniem funkcji logicznej IsNull(zmienna) oraz IF albo jeszcze szybciej IIF. Dla niewtajemniczonych funkcja ta sprawdza czy podany parametr jest wartością Null i jeżeli tak to podstawia pod wartość końcową drugi parametr. W przeciwnym wypadku jest zwracana wartość pierwotna.

Poniżej trzy wersje funkcji Nz. Mogą być przydatne np. w Excelu
Function Nz(vIn As Variant, vIsNull As Variant) As Variant
If IsNull(vIn) Then
Nz = vIsNull
Else
Nz = vIn
End If
End Function

Function Nz(vIn As Variant, vIsNull As Variant) As Variant
Nz = vIn
If IsNull(vIn) Then Nz = vIsNull
End Function

Function Nz(vIn As Variant, vIsNull As Variant) As Variant
Nz = IIf(IsNull(vIn), vIsNull, vIn)
End Function


Morał
Wykorzystanie With ma wiele zalet jedną z nich jest możliwoć skrócenia kodu i jego wizualna optymalizacja. Kolejną niewątpliwą zaletą jest przyspieszenie kodu.

sobota, 2 maja 2009

Masowy import danych z Excel-a

Majówka w pełni :) Korzystając z chwili wolnego czasu napisałem klasę masowo importującą wiele identycznych arkuszy w jedną spójną całość. Wbrew pozorom nie jest to takie łatwe zadanie :( ale po kilku godzinach walki udało mi się stworzyć coś takiego klasa C_MASS_IMPORT
Przykład wykorzystania jest poniżej:
Sub work()
Dim im As New C_MASS_IMPORT

im.BaseFile = "C:\Users\Orzemek\Documents\Report_file.mdb"
im.ImportFromFile "C:\Users\Orzemek\Documents\Report1.XLS", False, Array("Sheet2", "Sheet3", "Sheet4")
im.ImportFromFile "C:\Users\Orzemek\Documents\Report1.XLS", True

' tworzenie QueryTable
im.CreateQt Sheet1.Range("A1"), , "wynik scalenia"


' Tworzenie Pivot-a
im.CreatePv Sheet2.Range("A1"), , "wynik scalenia"

End Sub

Zasada działania jest prosta: wskazujemy plik roboczy MDB, jak go nie ma to zostanie stworzony.
Kolejnym krokiem jest import zakładek z pliku, jak nie wskażemy konkretnych to mechanizm będzie chciał importować wszystkie naraz. Parametr true / False widoczny w przykładzie sprawia że dane nie zostaną (true) lub nie zostaną (False) nadpisane
Ostatni krok to stworzenie obiektu QueryTable w wybranym arkuszu, fajne, lecz niekonieczne

Edit:
Dodałem możliwość łatwego tworzenia pivot-a z tabeli będącej wynikiem scalenia
Poprawiłem też link - jest do nowszej wersji