VBA Mania

Szybkie sprawdzenie czy czy istnieje tabela o podanej nazwie

2011-10-02T16:11:00.002+02:00

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.

Zrzut danych z bazy do pliku tekstowego

2011-10-02T15:16:00.003+02:00

Nieraz stajemy przed wyzwaniem jak sobie poradzić w przypadku braku jakiegoś narzędzia na naszym komputerze. Z doświadczenia wiem że w korporacjach komputery są dosyć rygorystycznie ograniczane pod kątem możliwości instalacji aplikacji, co może niestety dosyć utrudnić życie. Dlatego też trzeba często kombinować jak tu sobie poradzić w takiej ekstremalnej sytuacji. Dobrym przykładem moze być zrzut danych z bazy do pliku tekstowego. Do wielu baz danych są dostarczane odpowiednie narzędzia jak np. BCP.EXE albo SQLCMD.EXE do MSSQL-a. Problem w tym że trzeba te narzędzia zainstalować. Rozwiązaniem tego problemu może być prosty skrypt w VBS-e pobierający dane z bazy i zrzucający do pliku. Pozwoliłem sobie coś takiego napisać:

Dim aConn, sConn , aRs, sSQL 
Dim sPath
Dim oFld, sHeader, bHeader, sContent, sDelimiter
Dim sCharset
dim oArgs, oArg, sArg
dim oStdOut

Const adTypeText = 2
Const adSaveCreateOverWrite = 2

set oArgs=wscript.Arguments 
Set oStdOut = WScript.StdOut

sPath = ""
sCharset = "utf-8"
sDelimiter = ";"
bHeader = 0

For Each oArg In oArgs
 sArg = fGetParmName(oArg)
 select case sArg
  case "Sql", "S"
   sSQL = fGetParmValue(oArg)
  case "Path", "P"
   sPath = fGetParmValue(oArg)
  case "Conn", "C"
   sConn = fGetParmValue(oArg)
  case "Charset", "A"
   sCharset = fGetParmValue(oArg)
  case "Header" , "H"
   bHeader = fGetParmValue(oArg)
  case "Delimiter", "D" 
   sDelimiter = fGetParmValue(oArg)
 End Select
Next

On Error Resume Next
Err.Clear

Set aConn = CreateObject("ADODB.Connection")
aConn.Open sConn
If Err.Number <> 0 Then call sError

Set aRs = aConn.Execute(sSQL)
If Err.Number <> 0 Then call sError

aRs.MoveFirst
If Err.Number <> 0 Then call sError

if bHeader = "Yes" Then
 For Each oFld In aRs.Fields
  sHeader = sHeader & oFld.Name & sDelimiter
 Next
 sHeader = Left(sHeader, Len(sHeader) - 1) & Chr(13) & Chr(10)
End If

sContent = sHeader & aRs.GetString(, , sDelimiter)
If Err.Number <> 0 Then call sError

if sPath<> "" Then
 ExportToFile sPath, sContent
Else
 oStdOut.Write sContent
end if

aConn.Close
If Err.Number <> 0 Then call sError

set oStdOut = Nothing
Set aRs = Nothing
Set aConn = Nothing

function fGetParmName (sIn)
 fGetParmName= left(sIn, InStr(sIn,":") -1 )
 if left(fGetParmName,1) ="/" Then fGetParmName = mid(fGetParmName,2)
End Function

function fGetParmValue (sIn)
 fGetParmValue= mid(sIn, InStr(sIn,":") + 1 )
End Function

sub sError
 Wscript.Echo Err.Description
 On Error GoTo 0
 Err.Clear
 Wscript.Quit
End Sub

sub ExportToFile (sPath, sContent)
 Dim aStream 'As ADODB.Stream
 Set aStream = CreateObject("ADODB.Stream")
 With aStream
  .Open
  .Type = adTypeText
  .Charset = sCharset
  If Err.Number <> 0 Then call sError
  .Position = 0
  .WriteText sContent
  If Err.Number <> 0 Then call sError
  .SaveToFile sPath, adSaveCreateOverWrite
  If Err.Number <> 0 Then call sError   
 End With
 Set aStream = Nothing
End Sub

Skrypt ten można uruchomić w następujący sposób:

eksport.vbs /Sql:"SELECT * FROM dbo.v_struktura_akt" /Conn:"DRIVER=SQL Server Native Client 10.0;SERVER=MASZYNA;UID=username;Trusted_Connection=Yes;WSID=MASZYNA;DATABASE=baza_danych;LANGUAGE=polski;" /Path:"E:\Roboczy\wynik.csv"

dostępne są następujące parametry:

/SQL:"select * from tabela" - zapytanie które chcemy uruchomić
/Conn:"DRIVER=SQL Server....." - ciąg połączenia do bazy danych, zaletą tego rozwiązania jest to że możemy pobrać dane z praktycznie dowolnej bazy danych
/Path:"d:\katalog\plik.csv" - ścieżka do pliku w którym chcemy przechowywać wynik. W przypadku gdy nie podamy pliku wynik zostanie przekierowany do strumienia STDOUT
/Charset:"utf-8" - domyślny marametr strony kodowej w której zapiszemy plik. Standardowo jest utf-8, ale można zastosować dowolną stronę kodową obsługiwaną przez ADODB.Stream np. windows-1250
/Header:"Yes" - dodaje wiersz z nagłówkami
/Delimiter:";" - ustala znak podziału poszczególnych kolumn

Mała uwaga: jeżeli chcemy wyłączyć Banner w programie CSCRIPT

Microsoft (R) Windows Script Host Version 5.7
Copyright (C) Microsoft Corporation. All rights reserved.

Wykonajmy polecenie

cscript //NoLogo //S

Automatyczne łączenie aplikacji i bibliotek w jeden plik podczas kompilacji

2011-05-01T18:16:00.003+02:00

Zastanawiałem się w jaki sposób mógł bym sprawić żeby mój projekt odwołujący się do kilku bibliotek zewnętrznych nie był zbieraniną plików a jednym wygodnym do użycia plikiem. Głównym motywatorem takiego działania jest fakt że to aplikacji przeznaczona do pracy z linii poleceń.

Żeby wykonać scalić wszystkie pliki w jedną całość skorzystałem z narzędzia ILMerge.exe dostępnego na stronach Microsoft. Po ściągnięciu i zainstalowaniu możemy korzystać z tego narzędzia standardowo za pomocą linii poleceń i np. wykonać komendę:

ilmerge /target:exe /out:Aplikacja.exe 
        Program.exe ClassLibrary1.dll ClassLibrary2.dll

Dzięki takiej operacji z trzech plików robi nam się jeden, ale tu uwaga - parametr /target:exe wskazuje na to że plik wynikowy będzie uruchamiany z linii poleceń, można też użyć opcji /target:winexe - dzięki czemu stworzymy aplikację okienkowa lub /target:library - dzięki czemu stworzymy bibliotekę.

Oczywiście takie łączenie da nam jak najbardziej prawidłowy plik, lecz na dłuższą metę nie jest to wygodne. Rozwiązaniem było by takie zmodyfikowanie naszego projektu aby łączenie nastąpiło automatycznie po skomplikowaniu projektu. Taką możliwość możemy uzyskać dzięki ręcznej modyfikacji pliku projektu *.vbproj polegającej na dodaniu następującej sekcji:

http://pastebin.com/L1eGGKYP

Taka konstrukcja sprawi że po wykonaniu opeacjii Build zostanie wykonana komenda ILMerge z parametrami. Dodatkowo dodałem parametr /targetplatform:v4,C:\Windows\Microsoft.NET\Framework\v4.0.30319 sprawiający że ILMerge bedzie działał z .NET w wersji 4.0

Dodanie takiej sekcji działa również w pliku projektu stworzonego w wersji Visual Studio Express .

Wielokrotny wybór w dialekcie JET SQL (Access)

2011-04-19T16:44:00.001+02:00

Często zdarza mi się korzystać z konstrukcji IIF(warunek,wartość dla prawda,wartość dla fałsz) z pozycji kwerend w Access-e. Taka przykładowa kwerenda mogła by wyglądać np. tak:

SELECT t1.pole, IIF(t2.pole_w = 'TAK', 1,0) as FLAGA 
FROM TABELA_1 as t1 join TABELA_2 as t2 on t1.id = t2.id

Problem zaczyna się w momencie gdy musimy sprawdzić kilka niezależnych warunków i na podstawie takiego wyboru określić wynik końcowy. Oczywiście można zagnieżdżać IIF-y, ale to nie jest ani ładne, ani czytelne a tym bardziej wygodne. Idealnym rozwiązaniem było by zastosowanie CASE WHEN .... THEN .... ELSE END, ale JET SQL nie udostępnia nam bezpośrednio tego typu rozwiązania. Daje nam za to coś podobnego i działającego de fakto tak samo. jest to instrukcja SWITCH. Nasz wcześniejszy przykład możemy sobie rozbudować np. tak

SELECT t1.pole
, SWITCH(t2.pole_w = 'TAK', 1, t2.pole_w = 'NIE' ,0, t2.pole_w = 'NIE WIEM', -1, t2.pole_w = 'INNA ODPOWIEDŹ', -2) as FLAGA 
FROM TABELA_1 as t1 join TABELA_2 as t2 on t1.id = t2.id

W tym momencie jak widzimy mamy kilka opcji bez zbędnego komplikowania, ale to nie koniec możliwości ;)

SELECT t1.pole
, SWITCH(t2.pole_w = 'TAK', 1, t2.pole_w = 'NIE' ,0, t2.pole_w = 'NIE WIEM', -1, t2.pole_w = 'INNA ODPOWIEDŹ', -2, t2.pole_w in ('A','B','C'), 'ABC' , 1=1, 'COKOLWIEK INNEGO') as FLAGA 
FROM TABELA_1 as t1 join TABELA_2 as t2 on t1.id = t2.id

t2.pole_w in ('A','B','C') - to klasyczne sprawdzenie czy element jest w podanym zbiorze
1=1 - to ostatni warunek logiczny będący zawsze prawdą i wykonany w momencie gdy którykolwiek z wcześniejszych nie został uwzględniony.

I tu małą uwaga: jeżeli SWITCH natrafi na kryterium które jest spełnione to zwraca wartość i kończy sprawdzanie.

Jako ciekawostkę podam że w instrukcji SWITCH można jako zbiór danych podzapytanie np.

t2.pole_w in (SELECT KLUCZ FROM SLOWNIK)

a jak znam życie to pewnie można też dać podzapytanie skorelowane, ale sprawdzenie tego pozostawiam już czytelnikom

Mapowanie dysku sieciowego z pozycji T-SQL-a

2011-04-19T16:26:00.001+02:00

Dziś pokażę w jaki prosty sposób zmapować dysk sieciowy z poziomu MSSQL-a. Jest to szczególnie przydatne w momencie jak chcemy pobrać jakiś plik ze zdalnego serwera zabezpieczonego za pomocą loginu i hasła np. w celu załadowania za pomocą BULK INSERT

xp_cmdshell 'cmd /c IF EXIST W: net use W: /DELETE'
xp_cmdshell 'cmd /c net use W: \\maszyna\udzial haslo /USER:maszyna\login /PERSISTENT:YES'

 BULK INSERT dbo.tabela
   FROM 'W:\plik.txt'
   WITH
   (
   FIELDTERMINATOR =';',
   ROWTERMINATOR ='\n',
   FIRSTROW = 2,
   CODEPAGE = 1250
   )

jeżeli z jakiegoś powodu nie chcemy angażować dysku sieciowego, to wykorzystamy UNC

xp_cmdshell 'cmd /c IF EXIST \\maszyna\udzial net use \\maszyna\udzial /DELETE'
xp_cmdshell 'cmd /c net use W: \\maszyna\udzial haslo /USER:maszyna\login /PERSISTENT:YES'

 BULK INSERT dbo.tabela
   FROM '\\maszyna\udzial\plik.txt'
   WITH 
   (
   FIELDTERMINATOR =';',
   ROWTERMINATOR ='\n',
   FIRSTROW = 2,
   CODEPAGE = 1250
   )

Synchronizacja tabeli z polem w Excelu

2011-02-17T23:00:00.000+01:00

Taka mała magiczna sztuczka dla tych, którzy by chcieli bez użycia kodu VBA zsynchronizować tabelę w Excelu z filtrami umieszczonymi w polach.

Gwiazdki w InputBox-e

2011-02-17T21:56:00.000+01:00

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

2010-12-25T00:51:00.001+01:00

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

2010-11-01T22:41:00.001+01:00

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

2010-11-01T22:14:00.002+01:00

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

2010-10-17T23:26:00.003+02:00

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

2010-10-17T22:51:00.001+02:00

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

2010-09-21T12:56:00.001+02:00

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

Eksport danych z MSSQL-a bezpośrednio do MySQL-a

2010-09-09T20:56:00.001+02:00

Dziś pokażę w jaki prosty sposób wyeksportować dane za pomocą jednego polecenia SQL. Wykorzystamy do tego mechanizm LINKED SERVER obecny w MSSQL-u.
Pierwszym krokiem jest stworzenie łącza do zdalnej maszyny:

/****** Object:  LinkedServer [MYSQL]    Script Date: 09/09/2010 20:33:31 ******/
IF  EXISTS (SELECT srv.name FROM sys.servers srv WHERE srv.server_id != 0 AND srv.name = N'MYSQL')
 EXEC master.dbo.sp_dropserver @server=N'MYSQL', @droplogins='droplogins'
GO

/****** Object:  LinkedServer [MYSQL]    Script Date: 09/09/2010 20:33:31 ******/
EXEC master.dbo.sp_addlinkedserver 
 @server = N'MYSQL', 
 @srvproduct=N'MySQL', 
 @provider=N'MSDASQL', 
 @provstr=N'Driver=MySQL ODBC 5.1 Driver;SERVER=localhost;UID=root;PWD=tajnehaslo;DATABASE=sprzedaz;PORT=3306;CHARSET=utf8'
 /* For security reasons the linked server remote logins password is changed with ######## */
EXEC master.dbo.sp_addlinkedsrvlogin 
 @rmtsrvname=N'MYSQL',
 @useself=N'True',
 @locallogin=NULL,
 @rmtuser=NULL,
 @rmtpassword=NULL

załóżmy że mamy tabelkę w bazie zdefiniowaną jako:

CREATE TABLE [dbo].[tab_import](
 [id] [int] IDENTITY(1,1) NOT NULL,
 [O1] [varchar](30) NULL,
 [L1] [varchar](70) NULL,
 [O2] [varchar](30) NULL,
 [L2] [varchar](70) NULL,
 [O3] [varchar](30) NULL,
 [L3] [varchar](70) NULL,
 [O4] [varchar](30) NULL,
 [L4] [varchar](70) NULL,
 [O5] [varchar](30) NULL,
 [L5] [varchar](70) NULL,
 CONSTRAINT [PK_tab_import] PRIMARY KEY CLUSTERED ([id] ASC)
) ON [PRIMARY]

Posiadamy również tabelkę po stronie MySQL-a zdefiniowaną jaką

CREATE TABLE `tab_import` (
  `id` int(11) NOT NULL AUTO_INCREMENT,
  `O1` varchar(30) DEFAULT NULL,
  `L1` varchar(70) DEFAULT NULL,
  `O2` varchar(30) DEFAULT NULL,
  `L2` varchar(70) DEFAULT NULL,
  `O3` varchar(30) DEFAULT NULL,
  `L3` varchar(70) DEFAULT NULL,
  `O4` varchar(30) DEFAULT NULL,
  `L4` varchar(70) DEFAULT NULL,
  `O5` varchar(30) DEFAULT NULL,
  `L5` varchar(70) DEFAULT NULL,
  PRIMARY KEY (`id`)
) ENGINE=InnoDB DEFAULT CHARSET=utf8;

i chcemy przetransferować dane z bazy MSSQl do bazy MySQL. Skorzystamy w takim przypadku z możliwości INSERT INTO ... SELECT

INSERT INTO openquery (MYSQL,'select * from test.tab_import where 1 = 0')
                      (O1, L1, O2, L2, O3, L3, O4, L4, O5, L5)
SELECT     O1, L1, O2, L2, O3, L3, O4, L4, O5, L5
FROM         tab_import AS tab_import_1

Ciekawostką w tym układzie jest konstrukcja zagnieżdżonego SELECT-a wykorzystywanego przez OPENQUERY. warunek w tym zapytaniu filtruje wszystkie rekordy gdyż de fakto nie są one nam do niczego potrzebne. Podobna sztuczka nie jest wskazana w przypadku gdybyśmy chcieli wykonać DELETE lub UPDATE.

Formatowanie warunkowe

2010-09-06T01:25:00.001+02:00

Formatowanie warunkowe w Excel 2010

Dodatki i usprawnienia dla MSSQL w wersji Express

2010-09-05T23:35:00.003+02:00

MSSQL w wersji Express to ciekawa baza, tyle że pozbawiona wielu użytecznych narządzi. Dzięki kilku dodatkom praca z tą wersją bazy będzie o wiele prostsza i zaoszczędzi nam mnóstwa pracy.

Automatyzacja

Shulder-y

Dodatki

Menadżery

Toad

Określenie daty zakończenia miesiąca w SQL-u

2010-08-30T00:45:00.002+02:00

Dziś pokażę jak określić koniec miesiąca dla dowolnej daty. Wykorzystam tu pewną sztuczkę związaną z dodawaniem dat za pomocą funkcji DATEADD oraz wyciąganiem części składowych za pomocą funkcji YEAR i MONTH.

declare @dstop as datetime
set @dstop = getdate()
set @dstop =  dateadd(d,-1,dateadd(mm,1,convert(datetime,cast(year(@dstop) as nvarchar(4)) + '-' + RIGHT('0' + cast(MONTH(@dstop) as nvarchar(4)),2) + '-01',120)))

select @dstop

Algorytm postępowania jest następujący:
Wyciągamy Rok i miesiąc i na podstawie tego sklejamy datę określającą pierwszy dzień miesiąca
dodajemy miesiąc do tak otrzymanej daty
dodajemy -1 dzień do otrzymanej wcześniej sumy

Inna metoda to:

declare @dstop datetime
set @dstop = getdate() + 1
set @dstop =  dateadd(d,-day(dateadd(m,1,@dstop)),dateadd(m,1,@dstop))

select @dstop

Sposób ten zaprezentował kolega Bartosz Ślepowroński w tym wątku

Z powodzeniem ten sposób można zastosować w innych dialektach SQL np. JET

Sprawdzenie czy plik jest otwarty przez inny program

2010-08-27T23:52:00.001+02:00

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.

MSSQL i polskie nazwy miesięcy i dni tygodnia

2010-08-26T20:12:00.004+02:00

W MSSQL-u w bardzo prosty sposób można uzyskać poprawną polską nazwę miesiąca. wystarczy tylko wykonać prostą instrukcję przed wykonaniem głównego zapytania. Chodzi o wymuszenie języka w jakim będą prezentowane dane przez MSSQL. robimy to tak:

SET LANGUAGE Polish

Zaś wykorzystanie możemy zobaczyć tutaj:

select DATENAME (mm,GETDATE()) as [miesiąc], DATENAME (dw,GETDATE()) as [dzień]

Sprawdzenie aktualnego języka możemy za pomocą zmiennych systemowych @@language i @@langid.

SELECT @@language, @@langid

No i możemy również zmienić domyślny język dla loginu za pomocą menagment Studio: Security -> Logins -> Wybrany login , właściwości -> General -> Default Language.

Lub za pomocą T-SQL-a

ALTER LOGIN sa WITH DEFAULT_LANGUAGE = Polish;

Pełną informację o dostępnych językach uzyskamy zaś po wykonaniu komendy:

select * from sys.syslanguages

Now Available: SQL Server Migration Assistant for MySQL! - Brian Swan - Site Home - MSDN Blogs

2010-08-13T11:12:00.001+02:00

Now Available: SQL Server Migration Assistant for MySQL! - Brian Swan - Site Home - MSDN Blogs

Bardzo ciekawe narzędzie służące do migrowania bazy danych MySQL do MSSQL-a. Dzięki temu kreatorowi można wykonać to zadanie w miarę szybko i bezboleśnie.

Coding Horror: A Visual Explanation of SQL Joins

2010-08-09T07:51:00.001+02:00

Coding Horror: A Visual Explanation of SQL Joins

Bardzo proste wyjaśnienie istoty Joinów w SQL-u

Wykorzystanie wget.exe do pobierania danych raportowych

2010-07-18T14:50:00.002+02:00

W poprzednim poście pisałem o możliwości pobrania danych ze strony która wymaga logowania za pomocą loginu i hasła wpisywanego do formularza. Rozwiązanie bazowało na kodzie w VBA, co w pewnych sytuacjach jest nieco kłopotliwe do wykorzystania.

Dziś chciał bym przedstawić rozwiązanie bazujące na narzędziu wget.exe dostępnego dla platformy *nix jaki Windows. Narzędzie dla Windows jest do pobraniu np. tu. Narzędzie to nie wymaga instalowania, wystarczy że skopujemy plik wget.exe do jakiegoś katalogu.

Metoda jaką się posłużymy wymaga posiadania wiedzy o tym co jest przesyłane do strony z której chcemy coś pobrać. Przeglądarki webowe komunikują się z serwerami za pomocą komunikatów tekstowych które możemy podejrzeć za pomocą odpowiedniego narzędzia. Jednym z takich narzędzi może być rozszerzenie do przeglądarki Firefox: LiveHeader. Rozszerzenie to pokazuje pełną komunikację między przeglądarką a serwerem na poziomie nagłówków. Dzięki temu można podejrzeć co jest wysyłane do serwera WWW np. po naciśnięciu guzika wyślij lub loguj. Dla przykładu to co zaobserwujemy po kliknięciu Loguj w przeglądarce:

Na tym rysunku widzimy adres strony jaką wywołaliśmy po wyciśnięciu Loguj

A tu widzimy jaki nagłówek został przesłany do serwera.

Uzbrojeni w takie informacje możemy wykorzystać pewne specyficzne mechanizmy narzędzia wget.exe do zalogowania a następnie do pobrania raportu.

Przykładowy skrypt takiej znajdujący się np. w pliku webget.cmd to:

@ECHO OFF
wget --save-cookies cookies.txt --post-data "login=janek&password=123456789" -q "http://localhost/index.php?k=auth&a=auth&target="
wget --load-cookies cookies.txt --post-data "filtr_1=201006&filtr_2=844&sekcja=b&raport_n=compl&=undefined" --output-document=raport.csv -q "http://localhost/?k=raporty&a=GetReport&content=xls"

Wyjaśnienia mogą wymagać poszczególne opcje jakie zostały użyte podczas takiej operacji:

--save-cookies cookies.txt - zapisuje wszystkie informacje pobrane podczas logowania do pliku
--post-data "dane=vos" - wysyła dane do serwera udając formularz. Dane które są w przykładzie pochodziły z rysunku 2
-q - wget.exe działa w trybie cichym, to znaczy że nie będzie wyświetlał wszystkich komunikatów
"http://strona/" - adres URL strony którą pobieramy
--load-cookies cookies.txt - pobieramy informacje o logowaniu z wcześniej przygotowanego pliku
--output-document=raport.csv - zapisujemy wynik w pliku o konkretnej nazwie

Proszę zauważyć że zarówno dane dla --post-data jaki zam adres URL znajdują się między znakami " " - jest to konieczne do prawidłowego działania skryptu

Szybkie przekodowanie pliku teksowego

2010-07-17T20:24:00.005+02:00

Częstą zmorą podczas pracy z plikami jest ich kodowanie. Czasem można sobie poradzić ręcznie jakimś prostym narzędziem np. Notepad++, czasem importujemy plik do Access-a i eksportujemy w żądanym kodowaniu. Te metody się sprawdzają do momentu gdy nie zderzymy się z plikiem wielkości ~1GB. Cóż można wtedy zrobić? Ano skorzystać z dobrodziejstw darmowego narzędzia ICONV dla platformy Win32 czyli Windowsa.
Pierwotnie narzędzie to było dostępne dla systemów rodziny *nix, lecz w chwili obecnej możemy się cieszyć że jest dostępne też dla nas szarych użytkowników okieek.

Pliki wykonywalne Iconv można ściągnąć z adresu: http://gnuwin32.sourceforge.net/packages/libiconv.htm. Do wyboru mamy paczkę zip lub instalator exe. W zależności od wyboru ściągamy żądany plik i wypakowywujemy lub instalujemy.

Załóżmy że plik iconw.exe znajduje się w katalogu: c:\dekoder\, zaś pliki do dekodowania znajdują się w katalogu d:\pliki\. To jak wykorzystać to narzędzie do tego żeby przekodować nasze pliki np. ze strony kodowej UTF-8 do CP1250 (Strona kodowa Windows). Należy wykonać polecenie z wiersza poleceń:

c:\dekoder\iconv.exe -f UTF-8 -t CP1250 d:\pliki\plik.txt > d:\pliki\plik.cp1250.txt

Konstrukcja taka to proste wykonanie instrukcji iconv z przekierowaniem strumienia ">" do nowego pliku. Jest niezwykle wydajna i na średniej klasy sprzęcie przekodowanie pliku o wielkości setek megabajtów zajmuje tylko kilkanaście sekund.

Lista dostępnych stron kodowych jest dostępna po wykonaniu polecenia:

c:\dekoder\iconv.exe -l

Jednym z ciekawszych zastosowań takiej metody jest przekodowanie pliku przed importem do MSSQl-a. Jest to konieczne gdyż MSSQL nie wspiera tak jakbyśmy chcieli. Cóż można zrobić? ano można użyć procedury systemowej xp_cmdshell to przekonwertorownia pliku.

declare @cmd varchar(2000)
set @cmd = 'c:\dekoder\iconv.exe -f UTF-8 -t CP1250 d:\pliki\plik.txt > d:\pliki\plik_cp1250.txt'
exec xp_cmdshell @cmd

Jeżeli nie będziemy mieli aktywnej procedury xp_cmdshell możemy ją włączyć w następujący sposób:

EXEC master.dbo.sp_configure 'show advanced options', 1
RECONFIGURE
EXEC master.dbo.sp_configure 'xp_cmdshell', 1
RECONFIGURE

Konwertowanie UTF-8 do Unicode w VBA

2010-07-03T22:42:00.000+02:00

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

Logowanie do formularza web

2010-07-03T13:23:00.001+02:00

Dziś zaprezentuję metodę logowani się do stron internetowych/intranetowych zabezpieczonych formularzem logowania. Jest to w zasadzie standardowy sposób zabezpieczania aplikacji przed nieautoryzowanym dostępem. O ile jest to dobre z punktu widzenia security, to z punktu widzenia usera który musi klikać w ileś tam formularzy dziennie jest to droga przez mękę.

Dlatego proponuję ułatwić sobie życie za pomocą poniższego zestawu:

Function httpSessionRequest(theStep, method, url, data, cookie, viewState)

    Dim HTTPReferrer As String
    Dim postVars As String
    Dim XMLHTTP As Object
    Dim strHeaders As String
    Dim hArr() As String
    Dim kk As Long
    Dim theCookie As String
    Dim mycookie As String


    If Len(cookie) = 0 Then cookie = "dummy=dummy;"
    HTTPReferrer = Trim(url)
    postVars = Trim(data)

    Set XMLHTTP = CreateObject("MSXML2.serverXMLHttp")
    XMLHTTP.Open method, Trim(url), False

    If UCase(method) = "POST" Then
        XMLHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    End If
    
    XMLHTTP.setRequestHeader "Referer", HTTPReferrer    'just in case the server cares
    XMLHTTP.setRequestHeader "Cookie", "excuse the Microsoft bug"
    XMLHTTP.setRequestHeader "Cookie", cookie

    XMLHTTP.send postVars

    'wait for response
    While XMLHTTP.readyState <> 4
        XMLHTTP.waitForResponse 1000
    Wend
    strHeaders = XMLHTTP.getAllResponseHeaders()

    hArr = Split(strHeaders, "Set-Cookie: ")
    For kk = 1 To UBound(hArr)
        theCookie = Left(hArr(kk), InStr(hArr(kk), "path=/") - 2)
        mycookie = mycookie & " " & theCookie
    Next

    If Len(mycookie) = 0 Then mycookie = cookie

    Select Case CInt(theStep)
        Case 1
            httpSessionRequest = mycookie
        Case 2
            httpSessionRequest = XMLHTTP.responsetext
        Case 3
            httpSessionRequest = XMLHTTP.responseStream
        Case 4
            httpSessionRequest = XMLHTTP.responseBody
        Case 5
            httpSessionRequest = XMLHTTP.responseXML
        Case 6
            httpSessionRequest = XMLHTTP
        Case Else
            httpSessionRequest = XMLHTTP.responsetext
    End Select

    Set XMLHTTP = Nothing
End Function

Public Function URLEncode( _
   StringVal As String, _
   Optional SpaceAsPlus As Boolean = False _
) As String

  Dim StringLen As Long: StringLen = Len(StringVal)

  If StringLen > 0 Then
    ReDim result(StringLen) As String
    Dim i As Long, CharCode As Integer
    Dim Char As String, Space As String

    If SpaceAsPlus Then Space = "+" Else Space = "%20"

    For i = 1 To StringLen
      Char = Mid$(StringVal, i, 1)
      CharCode = Asc(Char)
      Select Case CharCode
        Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
          result(i) = Char
        Case 32
          result(i) = Space
        Case 0 To 15
          result(i) = "%0" & Hex(CharCode)
        Case Else
          result(i) = "%" & Hex(CharCode)
      End Select
    Next i
    URLEncode = Join(result, "")
  End If
End Function

Function WriteStream(file As String, body)
    Dim oStream As Object
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1
    oStream.Write body
    oStream.SaveToFile "D:\header_.gif"
    oStream.Close
    Set oStream = Nothing
End Function

Sub test()

    Dim Filename As String
    Dim baseURL As String, url1 As String, url2 As String, url3 As String
    Dim Data1 As String
    Dim nodata As String, noCookie As String, noViewState As String
    Dim theCookie As String
    Dim finalHTML As String
    Dim bytes() As Byte

    baseURL = "http://192.168.1.103/"    'This is to fix any broken images in the output.

    url1 = baseURL & "index.php" ' strona służąca do pobrania sesji
    url2 = baseURL & "?k=auth&a=auth&target=" ' strona logowania
    url3 = baseURL & "static/images/header.gif" ' strona

    Data1 = "login=rachwprz&password=thepass"

    theCookie = httpSessionRequest(1, "GET", baseURL, nodata, noCookie, noViewState)
    finalHTML = httpSessionRequest(2, "POST", url2, Data1, theCookie, noViewState)
    
    bytes = httpSessionRequest(4, "POST", url3, Data1, theCookie, noViewState)

    Filename = "D:\header_.gif"
    
    If Dir(Filename) <> "" Then Kill (Filename)

    WriteStream Filename, bytes

    
End Sub

Dla wyjaśnienia dodam tylko:
funkcja httpSessionRequest - jest uniwersalną metodą logowania i pobierania danych ze strony web za. W zależności od parametru theStep uzyskamy pożądany efekt. Przykładem może być pobranie wartości binarnej a następnie zapisanie jest za pomocą WriteStream
parametry przekazywane za pomocą metody POST nie muszą być traktowane funkcją URLEncode