Sapass

Pukiwiki Page name conversion in Excel VBA

2010-11-29T04:25:00.000-08:00

This is to convert PukiWiki filename into converted text.
From: 536974654E6176696761746F72.txt
To: SiteNavigator
-----
Function GetWikiName(strFileName As String, Optional strFr As String = "EUC-JP", Optional strTo As String = "Unicode") As String

Dim lngLen As Long
Dim lngIdx As Long
Dim strTranslated As String
Dim strTemp() As Byte

strTranslated = ""
lngLen = (Len(strFileName) - 4) / 2 - 1

ReDim strTemp(lngLen)
For lngIdx = 0 To lngLen
strTemp(lngIdx) = "&H" & Mid(strFileName, lngIdx * 2 + 1, 2)
DoEvents
Next

GetWikiName = Euc2Jis(strTemp, strFr, strTo)

End Function

Function Euc2Jis(ByRef src() As Byte, Optional strFrom = "EUC-JP", Optional strTo = "Unicode") As Byte()
Dim EUC As Object
Dim JIS As Object

Const adTypeBinary = 1
Const adTypeText = 2
Const adReadAll = -1
Const adCR = 13
Const adCRLF = -1
Const adLF = 10

Set EUC = CreateObject("ADODB.Stream")
Set JIS = CreateObject("ADODB.Stream")

EUC.Open
EUC.Type = adTypeBinary
EUC.Write src
EUC.Position = 0
EUC.Type = adTypeText
EUC.Charset = strFrom

JIS.Open
JIS.Type = adTypeText
JIS.Charset = strTo
JIS.LineSeparator = adCRLF

EUC.CopyTo JIS, adReadAll
EUC.Close
Set EUC = Nothing

JIS.Position = 0
JIS.Type = adTypeBinary

Euc2Jis = JIS.Read(adReadAll)

JIS.Close
Set JIS = Nothing

End Function

FTP - Mass processing to put files

2006-01-08T19:17:00.000-08:00

This snippet can be used for putting mass files on remote server via FTP. You specify Server name, User ID, Password, Remote directory, Local directory and files then the function will put files on the remote server. For declaration of the APIs, refer to the previous posts.


Public Function PutFiles(FtpSvr As String, UserID As String, _
Password As String, RemoteDirectory As String, _
LocalDirectory As String, LocalFiles As Collection) As Long
Dim iHandle As Long
Dim iFTP As Long
Dim lngRet As Long
Dim ErrText As String
Dim varUnit As Variant
PutFiles = vbOK
'Connection open
iHandle = InternetOpen(vbNullString, _
INTERNET_OPEN_TYPE_PRECONFIG, _
vbNullString, _
vbNullString, _
0&)
If iHandle = 0 Then PutFiles = vbCancel: GoTo GOEXIT ': Exit Function 'Error
'Connect to server
iFTP = InternetConnect(iHandle, _
FtpSvr, _
INTERNET_DEFAULT_FTP_PORT, _
UserID, _
Password, _
INTERNET_SERVICE_FTP, _
0&, _
0&)
If iFTP = 0 Then PutFiles = vbCancel: GoTo GOEXIT

'Put file to server. Can switch Ascii/Binary by changing the parameter below.
'Change directory on Local
ChDir LocalDirectory
'Change directory on Remote
lngRet = FtpSetCurrentDirectory(iFTP, RemoteDirectory)
If lngRet = 0 Then PutFiles = vbCancel ': Exit Function 'Error
'
For Each varUnit In LocalFiles
   lngRet = FtpPutFile(iFTP, _
   varUnit & vbNullChar, _
   varUnit & vbNullChar, _
   FTP_TRANSFER_TYPE_ASCII, _
   0&)
   DoEvents
Next

GOEXIT:
lngRet = InternetCloseHandle(iFTP)
lngRet = InternetCloseHandle(iHandle)
End Function

FTP - List up files on remote server

2006-01-07T04:03:00.000-08:00

Here is a code to create a list of the files on the remote server. The function ListUpFiles will create a collection of the file name that you have specified as a parameter. In addition to the FTPFindFirstFile and InternetFindNextFile, you will need the declaration of the functions like Open/Close. (Refer to the past posts for these functions.)


'Get first file
Public Declare Function FtpFindFirstFile Lib "wininet.dll" _
Alias "FtpFindFirstFileA" (ByVal hFtpSession As Long, _
ByVal lpszSearchFile As String, ByRef lpFindFileData As WIN32_FIND_DATA, _
ByVal dwFlags As Long, ByVal dwContent As Long) As Long

'Get next file
Public Declare Function InternetFindNextFile Lib "wininet.dll" _
Alias "InternetFindNextFileA" _
(ByVal hFind As Long, ByRef findFileData As WIN32_FIND_DATA) _
As Boolean
   
Public Type FILETIME
   dwLowDateTime As Long
   dwHighDateTime As Long
End Type

Public Type WIN32_FIND_DATA
   dwFileAttributes As Long
   ftCreationTime As FILETIME
   ftLastAccessTime As FILETIME
   ftLastWriteTime As FILETIME
   nFileSizeHigh As Long
   nFileSizeLow As Long
   dwReserved0 As Long
   dwReserved1 As Long
   cFileName As String * 260
   cAlternate As String * 14
End Type
...
Public Function ListUpFiles(FtpSvr As String, UserID As String, _
Password As String, RemoteDirectory As String) As Collection

Dim iHandle As Long
Dim iFTP As Long
Dim lngRet As Long
Dim ErrText As String
Dim varUnit As Variant
Dim w32File As WIN32_FIND_DATA
Dim strFile As String

Set ListUpFiles = New Collection
 
'Connection open
iHandle = InternetOpen(vbNullString, _
INTERNET_OPEN_TYPE_PRECONFIG, _
vbNullString, _
vbNullString, _
0&)
If iHandle = 0 Then GoTo GOEXIT:  ' Exit Function 'Error

'Connect to server
iFTP = InternetConnect(iHandle, _
FtpSvr, _
INTERNET_DEFAULT_FTP_PORT, _
UserID, _
Password, _
INTERNET_SERVICE_FTP, _
0&, _
0&)
If iFTP = 0 Then GoTo GOEXIT

'Change directory on Remote
lngRet = FtpSetCurrentDirectory(iFTP, RemoteDirectory)
If lngRet = 0 Then GoTo GOEXIT ': Exit Function 'Error

'
lngRet = FtpFindFirstFile(iFTP, RemoteDirectory, _
                          w32File, 0, 0)
Do
   If lngRet > 0 Then
      strFile = Left(w32File.cFileName, _
                InStr(w32File.cFileName, Chr(0)) - 1)
      ListUpFiles.Add strFile
   End If
   DoEvents
Loop While InternetFindNextFile(lngRet, w32File) <> 0

GOEXIT:
lngRet = InternetCloseHandle(iFTP)
lngRet = InternetCloseHandle(iHandle)

End Function

You can use this with the code below.


Sub Temp()
Dim colTemp As Collection
Dim varUnit As Variant
Set colTemp = ListUpFiles("blue.client.jp", _
    "UserID", "PassWord", "/")
For Each varUnit In colTemp
  Debug.Print varUnit
Next
End Sub

Windows - Check window is maxmized

2006-01-06T05:20:00.000-08:00

On the contrary to IsIconic API, you can check if the window is maxmized by IsZoomed API.


'Declare API
Public Declare Function IsZoomed Lib "USER32" _
(ByVal hWnd As Long) As Long

Sub Temp()
Dim lngReturn As Long
lngReturn = IsZoomed(Application.hWnd)
If lngReturn <> 0 Then
   MsgBox "Window is maximized"
Else
   MsgBox "Window is not maximized"
End If
End Sub

Windows - Check window is minimized

2006-01-05T07:09:00.000-08:00

This API - IsIconic - is for checking the window status. If it is minimized and iconized, the result is returned as 1.


'Decare API
Public Declare Function IsIconic Lib "USER32" _
  (ByVal hWnd As Long) As Long

Private Sub Temp()
Dim lngResult As Long
lngResult = IsIconic(Application.hWnd)
If lngResult = 1 Then
   MsgBox Application.Name & " is minimized"
Else
   MsgBox Application.Name & " is not minimized"
End If
End Sub

Windows - Display About dialog

2006-01-04T06:49:00.000-08:00

By declaring ShellAbout function, we can display "About" dialog in application. Here is an example of the code.


Public Declare Function ShellAbout Lib "SHELL32" _
  Alias "ShellAboutA" _
  (ByVal hWnd As Long, ByVal szApp As String, _
   ByVal szOtherStuff As String, ByVal hIcon As Long) As Long

Sub Temp()
Dim lngRet As Long
lngRet = ShellAbout(Application.hWnd, "Sapass", vbCrLf & "Description", 0)
End Sub

Windows - Sleep

2005-12-04T06:13:00.000-08:00

Sleep function makes the running process sleep for specified milli seconds.


Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub Temp()
MsgBox "Fall into sleep.."
Sleep 5000
MsgBox "Slept 5000 mm sec"
End Sub

FTP - Rename file by Wininet API

2005-12-03T16:48:00.000-08:00

In Wininet, in order to rename the file name on FTP server, this FtpRenameFile API needs to be called.


'Rename File
Private Declare Function FtpRenameFile Lib "wininet.dll" _
Alias "FtpRenameFileA" _
(ByVal hFtpSession As Long, ByVal lpszExisting As String, _
ByVal lpszNew As String) As Boolean

FTP - Delete file by Wininet API

2005-12-03T07:04:00.000-08:00

This is for deleting file through FTP by wininet.dll API. After get connected through the Internet connection function, this can be used. For the connection, refer to the past post.


'Delete File
Private Declare Function FtpDeleteFile Lib "wininet.dll" _ 
Alias "FtpDeleteFileA" _
(ByVal hFtpSession As Long, ByVal lpszFileName As String) As Boolean

FTP - Remove directory by Wininet API

2005-12-03T03:55:00.000-08:00

Removing directory can be done through this function in wininet.dll.


'Remove Direcotry
Private Declare Function FtpRemoveDirectory Lib "wininet.dll" _ 
Alias "FtpRemoveDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean

FTP - Create directory by Wininet API

2005-12-03T03:54:00.000-08:00

This is for creating directory on FTP server through Ftp CreateDirectory of wininet.dll.


'Create Directory
Private Declare Function FtpCreateDirectory Lib "wininet.dll" _
Alias "FtpCreateDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean

FTP - Change directory by Wininet API

2005-12-03T00:59:00.000-08:00

Changing the directory in FTP can be done with the code below. Same as GetCurDirectory, this can be used in conjunction with connect/disconnect. Refer to the past post for these functions.
This can be used as function in Excel like:
=SetCurrentDir("sapass.metro.client.jp","username","password","TargetDir")
Returns true if it can be changed successfully.


'Set current directory
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" _
Alias "FtpSetCurrentDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean

...
Function SetCurrentDir(strFtpSvr As String, strUserID As String, _
strPassword As String, strTargetDir As String) As Boolean
Dim hInternet As Long
Dim hFTP As Long
Dim lngRet As Long

SetCurrentDir = False
'Open connection
hInternet = InternetOpen(vbNullString, _
INTERNET_OPEN_TYPE_PRECONFIG, _
vbNullString, _
vbNullString, _
0&)
If hInternet = 0 Then Exit Function  'Error occurred
'Connect to server
hFTP = InternetConnect(hInternet, _
strFtpSvr, _
INTERNET_DEFAULT_FTP_PORT, _
strUserID, _
strPassword, _
INTERNET_SERVICE_FTP, _
0&, _
0&)
If hFTP = 0 Then Exit Function 'Error occurred
lngRet = FtpSetCurrentDirectory(hFTP, strTargetDir)
If lngRet <> 0 Then SetCurrentDir = True
lngRet = InternetCloseHandle(hFTP)
lngRet = InternetCloseHandle(hInternet)

End Function

FTP - Get current directory with Wininet API

2005-12-03T00:55:00.000-08:00

The declaration of the FtpGetCurrentlDirecotry in winninet API is like this. With the combination of connect/disconnect this can be used.
You can use this e.g. from Excel sheet like:
=GetCurrentDir("sapass.metro.client.jp","username","password")

*For connection & discconection, refer to the log.


'Get curernt directory
Private Declare Function FtpGetCurrentDirectory Lib "wininet.dll" _
Alias "FtpGetCurrentDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszCurrentDirectory As String, _
 ByRef lpdwCurrentDirectory As Long) As Boolean

...

Function GetCurrentDir(strFtpSvr As String, strUserID As String, _
strPassword As String) As String
Dim hInternet As Long
Dim hFTP As Long
Dim lngRet As Long
Dim strErrText As String

GetCurrentDir = String(255, 0)
'Open connection
hInternet = InternetOpen(vbNullString, _
INTERNET_OPEN_TYPE_PRECONFIG, _
vbNullString, _
vbNullString, _
0&)
If hInternet = 0 Then GetCurrentDir = "": Exit Function 'Error occurred
'Connect to server
hFTP = InternetConnect(hInternet, _
strFtpSvr, _
INTERNET_DEFAULT_FTP_PORT, _
strUserID, _
strPassword, _
INTERNET_SERVICE_FTP, _
0&, _
0&)
If hFTP = 0 Then GetCurrentDir = "": Exit Function 'Error occurred
lngRet = FtpGetCurrentDirectory(hFTP, GetCurrentDir, Len(GetCurrentDir))
lngRet = InternetCloseHandle(hFTP)
lngRet = InternetCloseHandle(hInternet)

End Function

Windows - Check if destination is reachable

2005-12-02T04:22:00.000-08:00

Check if the destination is reacheable or not.


Private Type QOCINFO
  dwSize As Long
  dwFlags As Long
  dwInSpeed As Long
  dwOutSpeed As Long
End Type

Private Declare Function IsDestinationReachable Lib "sensapi.dll" _
   Alias "IsDestinationReachableA" _
  (ByVal lpszDestination As String, _
   lpQOCInfo As QOCINFO) As Long

Function DestinationFound(strAddress As String) As Boolean
Dim objQoc As QOCINFO
objQoc.dwSize = Len(objQoc)
DestinationFound = IsDestinationReachable(strAddress, objQoc)
End Function

Windows - Parse HTML

2005-11-26T06:28:00.000-08:00

This snippet reads HTML as document and help to recognize tag/class and so on during processing. The logic can be used when you want to transfor the HTML into some other format.


Sub Temp()

Dim objBrowser As Object
Dim objBody As Object

Set objBrowser = CreateObject("InternetExplorer.Application")
objBrowser.navigate "http://sapass.metro.client.jp"
Do Until objBrowser.busy = False
   DoEvents
Loop

ParseBody objBody:=objBrowser.document.body

End Sub

Sub ParseBody(objBody As Object)
Dim objElement As Object
For Each objElement In objBody.Children
   If objElement.Children.Length > 0 Then
      ParseBody objBody:=objElement
   End If
   Debug.Print objElement.tagname
Next
End Sub

Windows - Remove IE cache

2005-11-17T04:04:00.000-08:00

This snippet helps to remove cached data for IE. If you need to obtain latest data through e.g. XMLHTTP, this may be useful.


Private Declare Function DeleteUrlCacheEntry Lib "wininet" _
Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
...
Dim objDocument As MSHTML.HTMLDocument
Const strurl As String = "http://site.com/page.html"
DeleteUrlCacheEntry(strurl)
Set objDocument = objMSHTML.createDocumentFromUrl(strurl, vbNullString)
...

XL - Open URL 3

2005-11-15T07:06:00.000-08:00

The other alternative to open URL from Excel VBA form. This actually triggers Explorer but subsequently it kicks up Internet Explorer and show the URL in the new window.


Sub Temp()
Shell "EXPLORER.EXE http://sapass.metro.client.jp/"
End Sub

XL - Check if Excel runs on Internet Explorer

2005-11-14T03:12:00.000-08:00

We can see if the Excel is running on IE or not by checking the container of workbook. Here is an example of functino to check it.


Function CheckRunOnIE() As Boolean
On Error Resume Next
CheckRunOnIE = _
IIf(Not(ThisWorkbook.Container.Name Like "*Internet Explorer*"), _
False, True)
On Error GoTo 0
End Function

XL - Calendar control

2005-11-13T06:46:00.000-08:00

To show calendar, you have to use calendar control in userform. Calendar control is provided with the office package as "MSCAL.OCX" (Microsoft Calendar Control). This calendar control has several methods like:
NextDay, NextMonth, PreviousDay, PreviousMonth, Refresh, Today...
Once after the date is selected, the date will be kept in value property of the control. Here is an example:


VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} UserForm 
   Caption         =   "UserForm"
   ClientHeight    =   2475
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   3225
   OleObjectBlob   =   "UserForm.frx":0000
   StartUpPosition =   1  'CenterOwner
End
Attribute VB_Name = "UserForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim datCalendar As Date

Private Sub OkButton_Click()
Hide
datCalendar = Calendar1.Value
End Sub

XL - Update Excel file without opening

2005-11-12T07:27:00.000-08:00

This snippet shows how to create Excel content without opening it. After creation of xlBook, if we specify existing file, we can update the contents.


Private Sub Button_Click()
Dim xlBook As Object
'Create Excel object
Set xlBook = CreateObject("Excel.Sheet")
'Put data 
xlBook.Sheets(1).Cells(1, 1).Value = "Test"
xlBook.Sheets(1).Cells(1, 2).Value = "Data"
xlBook.Sheets(1).Cells(1, 3).Value = Now()
'Disable overwrite confirmation prompt
xlBook.Application.DisplayAlerts = False
'Save Excel book
xlBook.SaveAs FileName:="C:\temp\temp.xls"
End Sub

SAPRFC - Reconnect

2005-11-11T20:55:00.000-08:00

Reconnect to SAP can be done with Reconnect method of Connection object. Here is the example of code.


Sub Reconnect()

Dim sapConn As Object 'Declare variant
Set sapConn = CreateObject("SAP.Functions") 'Create ActiveX object

If sapConn.Connection.Logon(0, False) <> True Then 'Try Logon
   sapConn.Connection.LastError
End If

sapConn.Connection.Logoff
MsgBox "Logged off then Reconnect"
sapConn.Connection.Reconnect

sapConn.Connection.SystemInformation

End Sub

SAPRFC - Logoff from SAP

2005-11-11T17:36:00.000-08:00

Logon is pretty simple. Just call Logoff method for the connection object.


Dim sapConn As Object 'Declare variant
Set sapConn = CreateObject("SAP.Functions") 'Create ActiveX object

sapConn.Connection.RfcWithDialog = 1
If sapConn.Connection.Logon(0, False) <> True Then 'Try Logon
   sapConn.Connection.SystemMessages
End If
sapConn.Connection.SystemInformation
sapConn.Connection.Logoff

End Sub

SAPRFC - Logon to SAP 6 - Show system info

2005-11-10T17:27:00.000-08:00

System information can be captured with the methods provided by SAP. Logon error message can be done by SystemMessages method of the connection object. For the logon system information is done with SystemInformation method.


Sub SapLogon()

Dim sapConn As Object 'Declare variant
Set sapConn = CreateObject("SAP.Functions") 'Create ActiveX object

sapConn.Connection.RfcWithDialog = 1
If sapConn.Connection.Logon(0, False) <> True Then 'Try Logon
   sapConn.Connection.SystemMessages
End If
sapConn.Connection.SystemInformation

End Sub

SAPRFC - Logon to SAP 5 - With dialog

2005-11-07T17:20:00.000-08:00

In some case, you may have to show SAP screen during the process of the RFC. Also, there may be a case you have to upload/download files between SAP and client. This RfcWithDialog parameter enables to make it.


Sub SapLogon()

Dim sapConn As Object 'Declare variant
Set sapConn = CreateObject("SAP.Functions") 'Create ActiveX object

sapConn.Connection.RfcWithDialog = 1
If sapConn.Connection.Logon(0, False) <> True Then 'Try Logon
   MsgBox "Error": Exit Sub
End If

End Sub

SAPRFC - Logon to SAP 4 - With logon selection

2005-11-06T17:15:00.000-08:00

By giving "False" to SilentLogon parameter of Logon method, we can show logon dialog and ask users to select the system to logon. This may be easier if you are going to develop a tool running on users' client.


Sub SapLogon()

Dim sapConn As Object 'Declare variant
Set sapConn = CreateObject("SAP.Functions") 'Create ActiveX object

If sapConn.Connection.Logon(0, False) <> True Then 'Try Logon
   MsgBox "Error": Exit Sub
End If

End Sub

SAPRFC - Logon to SAP 3

2005-11-05T17:12:00.000-08:00

Third alternative to logon to SAP is to use the BAPI contorl function. This should be used when you have a code with BAPI function. (You can call BAPI function as RFC function module. So it's just about a preference though.)


Sub SapLogon3()

Dim sapBapi As Object

Set sapBapi = CreateObject("SAP.BAPI.1")

sapBapi.Connection.User = "TEST"
sapBapi.Connection.Password = "PASSWORD"
sapBapi.Connection.Client = "999"
sapBapi.Connection.ApplicationServer = "sapass.metro.client.jp"
sapBapi.Connection.Language = "EN"

If sapBapi.Connection.Logon(0, True) <> True Then
   MsgBox "Error"
End If

End Sub

SAPRFC - Logon to SAP 2

2005-11-03T17:08:00.000-08:00

This is also for logging on to SAP but this uses SAP Logon Control function. May be useful to connect to SAP multiple times at the same time.


Sub SapLogon2()

Dim objBase As Object 'Connection base
Dim sapConn As Object
Set objBase = CreateObject("SAP.LogonControl.1") 'Create ActiveX

objBase.User = "TEST"
objBase.Password = "PASSWORD"
objBase.Client = "999"
objBase.ApplicationServer = "sapass.metro.client.jp"
objBase.Language = "EN"
Set sapConn = objBase.NewConnection

If sapConn.Logon(0, True) <> True Then 'Try Logon
   MsgBox "Error"
End If

End Sub

SAPRFC - Logon to SAP 1

2005-11-01T17:06:00.000-08:00

Here is the basic function to logon to SAP. This utilizes the SAP RFC function control.


Sub SapLogon()

Dim sapConn As Object 'Declare variant
Set sapConn = CreateObject("SAP.Functions") 'Create ActiveX

sapConn.Connection.User = "TEST"
sapConn.Connection.Password = "PASSWORD"
sapConn.Connection.Client = "999"
sapConn.Connection.ApplicationServer = "sapass.metro.client.jp"
sapConn.Connection.Language = "EN"

If sapConn.Connection.Logon(0, True) <> True Then 'Try Logon
   MsgBox "Error"
End If

End Sub

XL - Status bar

2005-10-24T21:21:00.000-07:00

Sometimes it is tedious to create progress bar in user format. In that case, we can use status bar instead.


Sub Temp()
Dim lngIdx As Long
Dim strPrev As String
Dim blnPrev As Boolean
strPrev = Application.StatusBar
For lngIdx = 1 To 100
  Application.StatusBar = "Counting .. " & lngIdx
Next
Application.StatusBar = strPrev
End Sub

XL - Execute macro on another book

2005-10-23T21:18:00.000-07:00

In order to execute a macro on another sheet, we have to do "Run" instead of "Call".


Sub Temp()
Application.Run "Book2!Temp2"
End Sub

XL - List up built in properties (Author etc..)

2005-10-21T20:38:00.000-07:00

This sub procedure lists up all the built-in properties in Excel workbook. Which covers, Title, Subject, Company, Author, Creation date, Last save time etc...


Sub Temp()
Dim objProperty As Object
On Error Resume Next
For Each objProperty In ActiveWorkbook.BuiltinDocumentProperties
   Debug.Print objProperty.Name & " = " & objProperty.Value
Next
On Error GoTo 0
End Sub

XL - List up all menus incl. sub menu

2005-10-20T20:28:00.000-07:00

Here this script helps to list up the menus in Excel. Some menu hidden but can be checked with this.


Sub ListUp()
Dim objBar As Object

For Each objBar In CommandBars
   Debug.Print "1 : " & objBar.Name
   ListSubMenu objSubMenu:=objBar.Controls, lngLevel:=1
Next

End Sub

Sub ListSubMenu(objSubMenu As Object, lngLevel As Long)
Dim objBar As Object
On Error Resume Next
For Each objBar In objSubMenu
   Debug.Print lngLevel & " : " & objBar.Caption
   If objBar.Controls.Count > 0 Then
      ListSubMenu objSubMenu:=objBar.Controls, lngLevel:=lngLevel + 1
   End If
Next
On Error GoTo 0
End Sub

XL - List up menus

2005-10-18T20:16:00.000-07:00

This scripts list up menus included in Excel.


Sub Temp()
Dim objBar As Object
For Each objBar In CommandBars
   Debug.Print objBar.Name
Next
End Sub

XL - Comparison of the string 2

2005-10-17T19:18:00.000-07:00

For comparing the pattern of the string, we can use "like" operator. "*" stands for any string character with any length and "?" stands for single character.


Sub Temp()

Const strA1 = "ABCD"
Const strA2 = "ABXD"
Const strA3 = "AXCD"
Const strB = "AB*"
Const strC = "A?C?"

MsgBox "Compare " & strA1 & " & " & strB & " - " & (strA1 Like strB)
MsgBox "Compare " & strA1 & " & " & strC & " - " & (strA1 Like strC)
MsgBox "Compare " & strA2 & " & " & strB & " - " & (strA2 Like strB)
MsgBox "Compare " & strA2 & " & " & strC & " - " & (strA2 Like strC)
MsgBox "Compare " & strA3 & " & " & strB & " - " & (strA3 Like strB)
MsgBox "Compare " & strA3 & " & " & strC & " - " & (strA3 Like strC)

End Sub

XL - Comparison of the string 1

2005-10-16T19:10:00.000-07:00

For comparing string, StrComp function is availabe.


Sub Temp()
Const strA = "ABCD"
Const strB = "abcd"
MsgBox strA = strB  'Not equal - Char code comparison (binary)
MsgBox StrComp(strA, strB, 0) = 0 'Not equal - Binary comparison
MsgBox StrComp(strA, strB, 1) = 0 'Equal - Textual comparison
End Sub

Folder - List up items in Temporary Internet folder

2005-10-14T16:53:00.000-07:00

This script helps to list up items in Temporary Internet file folder.


Sub Temp()
Dim objShell As Object
Dim objFolder As Object
Dim objItem As Object
Dim objFolderItem As Object
Const TEMPORARY_INTERNET_FILES = &H20&

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(TEMPORARY_INTERNET_FILES)
Set objFolderItem = objFolder.Self
Debug.Print objFolderItem.Path

For Each objItem In objFolder.Items
    Debug.Print objItem.Name
Next
End Sub

Folder - List up items in Recycle bin

2005-10-12T16:45:00.000-07:00

This snippet lists up the files in Recycle bin.


Sub Temp()
Dim objShell As Object
Dim objFolder As Object
Dim objItem As Object
Dim objFolderItem As Object
Const RECYCLE_BIN = &HA&

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(RECYCLE_BIN)
Set objFolderItem = objFolder.Self
Debug.Print objFolderItem.Path

For Each objItem In objFolder.Items
    Debug.Print objItem.Name
Next
End Sub

Folder - List up items in System32

2005-10-11T16:43:00.000-07:00

Here this script lists up the files in System32.


Sub temp()
Dim objShell As Object
Dim objFolder As Object
Dim objFolderItem As Object
Dim objItem As Object
Const SYSTEM32 = &H25&

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(SYSTEM32)
Set objFolderItem = objFolder.Self
Debug.Print objFolderItem.Path

For Each objItem In objFolder.Items
    Debug.Print objItem.Name
Next
End Sub

Windows - Get module name

2005-10-10T04:00:00.000-07:00

Module name that the specified windows is using can be obtained by the snippet below. The usage of the formula is as follows:
=GetModuleName(0)


Private Declare Function GetModuleFileName Lib "kernel32" Alias _
           "GetModuleFileNameA" (ByVal hModule As Long, ByVal lpFileName As _
           String, ByVal nSize As Long) As Long

Function GetModuleName(hInstance As Long) As String
Dim lngReturn As Long
Dim strModule As String * 100
lngReturn = GetModuleFileName(hInstance, strModule, 100)
GetModuleName = Left(strModule, lngReturn)
End Function

Windows - Get instance number

2005-10-09T03:57:00.000-07:00

We can get Instance number of the window handle by the function below. The function can be called as:
=GetWindowInstance(GetWindowFromPoint(200,200))


Private Declare Function GetWindowWord Lib "User32" (ByVal hwnd As _
           Long, ByVal nIndex As Long) As Integer
Const GWW_HINSTANCE = (-6)
           
Function GetWindowInstance(hwnd As Long) As Long
GetWindowInstance = GetWindowWord(hwnd, GWW_HINSTANCE)
End Function

Windows - Get class name

2005-10-07T03:26:00.000-07:00

This function gets class name by window handle. The function can be used:
=GetClassFromHandle(GetWindowFromPoint(200,200))


Private Declare Function GetClassName Lib "User32" Alias _
           "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As _
           String, ByVal nMaxCount As Long) As Long
           
Function GetClassFromHandle(hwnd As Long) As String
Dim lngReturn As Long
Dim strClass As String * 100
lngReturn = GetClassName(hwnd, strClass, 100)
GetClassFromHandle = Left(strClass, lngReturn)
End Function

Windows - Get window text

2005-10-06T03:19:00.000-07:00

This function obtains window text from window handle. With the combination of the other function, this can be used as below.
=GetWindowTextFromHandle(GetWindowFromPoint(200,200))
*GetWindowFromPoint is a function that returns window handle by window position.


Private Declare Function GetWindowText Lib "User32" Alias _
           "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, _
           ByVal cch As Long) As Long

Function GetWindowTextFromHandle(hWnd As Long) As String
Dim lngReturn As Long
Dim strText As String * 100
lngReturn = GetWindowText(hWnd, strText, 100)
GetWindowTextFromHandle = Left(strText, lngReturn)
End Function

Windows - Get window handle

2005-10-04T02:06:00.000-07:00

This function returns the window handle number which the parameter X and Y indicates. The usage of the function is:
=GetWindowFromPoint(100, 100)


Private Declare Function WindowFromPointXY Lib "User32" Alias _
     "WindowFromPoint" (ByVal xPoint As Long, ByVal yPoint As Long) _
     As Long

Function GetWindowFromPoint(lngX As Long, lngY As Long) As Long
GetWindowFromPoint = WindowFromPointXY(lngX, lngY)
End Function

Date - Split date into sub-part : DatePart

2005-10-03T01:57:00.000-07:00

For split date into Year, Month, Day or any units, you can use the function DatePart. The result you can get may be same as Year, Month, Day function, but you can make the unit of value as varible.


result = DatePart("", "2005/10/1")

yyyy - Year
q - Quarter
m - Month
y - Day of year
d - Day
w - Weekday
ww - Week
h - Hour
n - Minute
s - Second

Date - Date calculation : DateAdd

2005-10-02T01:53:00.000-07:00

Date calculation is done by DateAdd function.


result = DateAdd(interval, 10, "2005/1/1")

Possible values for interval.
yyyy - Year
q - Quarter
m - Month
y - Day of year
d - Day
w - Weekday
ww - Week
h - Hour
n - Minute
s - Second

Date - Difference of two dates: Datediff

2005-10-01T01:45:00.000-07:00

Datediff is a function for calculating the difference betweeen two dates. The unit of the difference can be year, month, day or etc... The format of the function is as below.


result = DateDiff(interval, "2005/1/1", "2005/10/1")

Possible values for interval:
yyyy - Year
q - Quarter
m - Month
y - Day of year
d - Day
w - Weekday
ww - Week
h - Hour
n - Minute
s - Second

WSH - Get environment variables

2005-09-30T00:23:00.000-07:00

Windows environment variables can be obtained as floows.


Sub Temp()
Dim objShell As Object
Dim varEnv As Variant
Set objShell = CreateObject("WScript.Shell")
For Each varEnv In objShell.Environment
   Debug.Print varEnv
Next
End Sub

WSH - Registry manipulation : Read

2005-09-28T00:11:00.000-07:00

Reading value from the registry can be done throught the snippet below.
=ReadRegistry("temp\temp")


Function ReadRegistry(strkey As String, Optional strRoot As String) As String
Dim objShell As Object
ReadRegistry = ""
Set objShell = CreateObject("WScript.Shell")
strRoot = IIf(strRoot = "", "HKEY_CURRENT_USER\", strRoot)
ReadRegistry = objShell.RegRead(strRoot & strkey)
End Function

WSH - Registry manipulation : Delete

2005-09-27T00:05:00.000-07:00

Deletion of the registry value/key can also be done with WSH. Here the function works with the code below:
=DeleteRegistry("temp\")
This removes all the keys/values under "temp".


Function DeleteRegistry(strKey As String, Optional strRoot As String)
Dim objShell As Object
Set objShell = CreateObject("WScript.Shell")
DeleteRegistry = 0
strRoot = IIf(strRoot = "", "HKEY_CURRENT_USER\", strRoot)
objShell.RegDelete strRoot & strKey
End Function

WSH - Registry manipulation : Add

2005-09-26T23:56:00.000-07:00

Even with WSH, you can add, delete or get the registry value. This is easier than to write a code which calls dlls. This function works like this.
=AddRegistry("temp\temp","tempvalue")


Function AddRegistry(strKey As String, strValue As String, Optional strRoot As String)
Dim objShell As Object
AddRegistry = 0
Set objShell = CreateObject("WScript.Shell")
strRoot = IIf(strRoot = "", "HKEY_CURRENT_USER\", strRoot)
objShell.RegWrite strRoot & strKey, strValue
End Function

WSH - Removing Network drive

2005-09-24T23:49:00.000-07:00

Same as doing printers, removing a Network to client can be done with the script below.


Sub Temp()
Dim objNet As Object
Set objNet = CreateObject("WScript.Network") 
objNet.AddWindowsPrinterConnection "\\Server\Printer"
objNet.RemoveNetworkDrive "Z:"
End Sub

WSH - Map network drive

2005-09-23T23:47:00.000-07:00

Same as doing printers, adding a Network to client can be done with the script below.


Sub Temp()
Dim objNet As Object
Set objNet = CreateObject("WScript.Network")    
objNet.AddWindowsPrinterConnection "\\Server\Printer"
objNet.MapNetworkDrive "Z:", "\\Server\Folder","True","user","password"
End Sub

WSH - Remove printer

2005-09-22T23:44:00.000-07:00

Removing a printer from a client can be done with the script below.


Sub Temp()
Dim objNet As Object
Set objNet = CreateObject("WScript.Network") 
objNet.RemovePrinterConnection "\\Server\Printer"
End Sub

WSH - Add printer

2005-09-21T23:42:00.000-07:00

Adding a printer to client can be done with the script below.


Sub Temp()
Dim objNet As Object
Set objNet = CreateObject("WScript.Network")    
objNet.AddWindowsPrinterConnection "\\Server\Printer"
End Sub

WSH - Get login information

2005-09-20T23:39:00.000-07:00

Instead of using dll, you can get username, domain and computer name through Windows Script.


Sub Temp()
Dim objNet As Object
Set objNet = CreateObject("WScript.Network")
Debug.Print objNet.UserName
Debug.Print objNet.UserDomain
Debug.Print objNet.ComputerName
End Sub

WSH - List up Network drives

2005-09-19T23:37:00.000-07:00

Same as listing up printers, Network drives can be listed up with the code below.


Sub Temp()
Dim objNet As Object
Dim objDrives As Object
Dim varDrive As Variant
Set objNet = CreateObject("WScript.Network")
Set objDrives = objNet.EnumNetworkDrives
For Each varDrive In objDrives
   Debug.Print varDrive
Next
End Sub

WSH - List up printers connected to client

2005-09-18T23:35:00.000-07:00

For list up the printers connected to the client, you can do it through Windows Script Hosting (WSH). This function utilize OCX library - wshom.ocx.


Sub Temp()
Dim objNet As Object
Dim objPrinters As Object
Dim varPrinter As Variant
Set objNet = CreateObject("WScript.Network")
Set objPrinters = objNet.EnumPrinterConnections
For Each varPrinter In objPrinters
   Debug.Print varPrinter
Next
End Sub

XL - Open URL 2

2005-09-17T22:09:00.000-07:00

Another way to open URL. Here we use WSH (Windows script) technology. Other than these, we can specificly open Internet explorer by creating ActiveX object, but not all of the users are using IE as standard web browser so these 2 are recommended.


Sub Temp()
Dim objWsh as Object
Set objWsh = CreateObject("Wscript.Shell")
objWsh.Run "http://sapass.metro.client.jp", 3
Set objWsh = Nothing
End Sub

XL - Open URL 1

2005-09-16T22:05:00.000-07:00

Sometimes we want to bring users to specific URL site.. like to show help texts to users. In that case, we want to show the site automatically. Here we will see how to make it. In this case, let windows judge which application to use for accessing web.


Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
  (ByVal hwnd As Long, ByVal lpOperation As String, _
   ByVal lpFile As String, ByVal lpParameters As String, _
   ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Sub Temp()
Dim strURL As String
Dim lngReturn as long
strURL = "http://sapass.metro.client.jp"
lngReturn = ShellExecute(0, "Open", strURL, "", "", 1)
End Sub

XL - RefEdit control

2005-09-15T22:00:00.000-07:00

In Excel user form, you may ever have faced a case to include dialog to let users to specify the range in the spreadsheet. The RefEdit control helps you to do that. The control is provided by the "REFEDIT.dll" in the MS office packages. This is an example for using it in the user form. (It does nothing though.)


VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} UserForm 
   Caption         =   "UserForm1"
   ClientHeight    =   525
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4170
   OleObjectBlob   =   "UserForm.frx":0000
   StartUpPosition =   1  'CenterOwner
End
Attribute VB_Name = "UserForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub CancelButton_Click()
Hide
End Sub

XL - Display progress bar

2005-09-14T21:50:00.000-07:00

Progress bar can be built in the form with the "mscomctl.ocx" library. The form below "Progress.frm" shows how to control it in VBA form. This form contains 3 methods and 2 events.
1. Init - Initializes the progress bar.
2. Update - Updates with Current position, Max position and comment.
3. Complete - Show complete status.
4. ButtonCancel_Click - Triggered when Cancel button hit.
5. ButtonOk_Click - Triggered when Ok button hit.

mscomctl.ocx contains lots more functions we can use.


VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} Progress 
   Caption         =   "Progress"
   ClientHeight    =   1905
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4710
   OleObjectBlob   =   "Progress.frx":0000
   ShowModal       =   0   'False
   StartUpPosition =   1  'CenterOwner
End
Attribute VB_Name = "Progress"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public OkCancel As Long

Private Sub ButtonOk_Click()
Hide
OkCancel = vbOK
End Sub

Private Sub ButtonCancel_Click()
If MsgBox("Do you want to stop this process?", vbYesNo) = vbYes Then
   Hide
   OkCancel = vbCancel
End If
End Sub

Sub Init(Process)
OkCancel = vbOK
ButtonOk.Enabled = False
ButtonCancel.Enabled = True
ProgressBar.Value = 0
PercentText = "0%"
TitleText = Process
Show
End Sub

Sub Update(Optional CurNum, Optional MaxNum, Optional OtherInfo)
CommentText = "Processing: " & OtherInfo
If MaxNum > 0 Then
   ProgressBar.Value = (CurNum / MaxNum) * 100
   PercentText = CInt((CurNum / MaxNum) * 100) & "%"
   Repaint
End If
End Sub

Sub Complete()
ButtonOk.Enabled = True
ButtonCancel.Enabled = False
CommentText = "Completed"
ProgressBar.Value = 100
PercentText = "100%"
Repaint
End Sub

XL - Specify color through Dialog

2005-09-12T21:00:00.000-07:00

There is a lot of built-in dialogs in Excel. But as they are designed to be used as part of Excel function, sometimes they are not useful to include its function in VBA. Color index dialog is one of the one. This Sub procedure describes how to make use of it.


Sub GetColor()

Dim objPrevCell As Object
Dim lngPrevColor As Long
Dim lngPrevIndex As Long
Dim lngColor As Long
Dim blnResult As Boolean

Set objPrevCell = ActiveCell
lngPrevIndex = ActiveCell.Interior.ColorIndex
lngPrevColor = IIf(lngPrevIndex > 0, ActiveCell.Interior.Color, xlNone)
blnResult = Application.Dialogs(xlDialogPatterns).Show

If blnResult = True Then
   With ActiveCell.Interior
   lngColor = .Color
      If lngPrevIndex > 0 Then
         .Color = lngPrevColor
      Else
         .ColorIndex = xlNone
      End If
   End With
   MsgBox lngColor
End If

End Sub

XL - Save file dialog

2005-09-11T20:15:00.000-07:00

Same as open file dialog, there is a one for Save. Unlike Open file dialog, of course, multiselect cannot be done.


Sub Temp()
Dim strFileName
strFileName = Application.GetSaveAsFilename(InitialFileName:="", _
              FileFilter:="Worksheets,*.xls")
If strFileName = "False" Then MsgBox "No file selected"
End Sub

XL - Open file dialog

2005-09-10T20:06:00.000-07:00

In Excel, common open file diaglog can be opened simply with Application.GetOpenFilename method. If cancel button is hit and no file name is selected in the dialog, "False" will be returned. *Actually the return will come as boolean, but in order to handle other strings, has to be checked as string.


Sub Temp()
Dim strFileName
strFileName = Application.GetOpenFilename(FileFilter:="Worksheets,*.xls", MultiSelect:=False)
If strFileName = "False" Then MsgBox "No file selected"
End Sub

Windows - Get windows directory

2005-09-09T19:20:00.000-07:00

With this function, Windows direcotry can be obtained. To use this, simply put the function:
=GetWindowsDir()


'Get Windows directory
Public Declare Function GetWindowsDirectory Lib "kernel32"  Alias "GetWindowsDirectoryA" _
 (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Function GetWindowsDir() As String
Dim strDir As String
Dim lngReturn As Long
strDir = Space(100)
lngReturn = GetWindowsDirectory(strDir, 100)
GetWindowsDir = Mid(strDir, 1, InStr(strDir, Chr(0)) - 1)
End Function

Windows - Get OS version

2005-09-08T19:00:00.000-07:00

OS version can be checked with the following function. The result will be returned as text string. This can be used in the formula:
=GetVersion()


Public Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _
  (lpVersionInformation As OSVERSIONINFO) As Long

Type OSVERSIONINFO
  dwOSVersionInfoSize As Long
  dwMajorVersion As Long
  dwMinorVersion As Long
  dwBuildNumber As Long
  dwPlatformId As Long
  szCSDVersion As String * 128
End Type

Function GetVersion() As String
Dim OSVER As OSVERSIONINFO
Dim strVersion As String

OSVER.dwOSVersionInfoSize = Len(OSVER)
Call GetVersionEx(OSVER)

Select Case OSVER.dwPlatformId
  Case 1 'Win32 Windows
    Select Case OSVER.dwMinorVersion
      Case 0
        GetVersion = "Win95"
      Case Else
        GetVersion = "Win98"
    End Select
  Case 2 'Win32 NT
    Select Case OSVER.dwMinorVersion
      Case 0
        GetVersion = "Win2K"
      Case 1
        GetVersion = "WinXP"
      Case 2
        GetVersion = "Win03" 'Sever 2003
    End Select
  Case Else
    GetVersion = "Unknown"
End Select

End Function

Windows - Lock computer

2005-09-07T18:47:00.000-07:00

In order to lock computer, you can do it with the sub procedure below.


Public Declare Function LockWorkStation Lib "User32.dll" ()

Sub LockComputer()
LockWorkStation
End Sub

Windows - Get logon user name

2005-09-06T18:32:00.000-07:00

The function below helps to obtain the logon user name which the function is running on. This can be used with the formula below:
=GetLogonName()


Public Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" _
 (ByVal Buffer As String, Size As Long) As Long

Function GetLogonName() As String

Dim strUserNameBuff As String * 128
Dim lngReturn As Long

'Get logon user name
lngReturn = GetUserName(strUserNameBuff, Len(strUserNameBuff))
GetLogonName = Left(strUserNameBuff, InStr(strUserNameBuff, vbNullChar) - 1)

End Function

Windows - Get computer name

2005-09-05T18:27:00.000-07:00

With this function, you can get computer name which the function is running on. Formula below enabels this:
=GetMachineName()


Public Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" _
 (ByVal Buffer As String, Size As Long) As Long

'-----
Function GetMachineName() As String

Dim strComputerNameBuff As String * 16
Dim lngReturn As Long
'Get ComputerName
GetMachineName = ""
lngReturn = GetComputerName(strComputerNameBuff, Len(strComputerNameBuff))
GetMachineName = Left(strComputerNameBuff, _
   InStr(strComputerNameBuff, vbNullChar) - 1)

End Function

FTP - Put file with Wininet API

2005-09-04T18:10:00.000-07:00

Like getting file via WinInet, with this function, we can put the file to server. The function can be used with the formula below:
=PutFileFtp("server.com", "user", "password", "targetfile", "localfile")


'--Declaration ------------------------------
'Open FTP connection
Public Declare Function InternetOpen Lib "WinInet.DLL" Alias "InternetOpenA" _
 (ByVal lpszAgent As String, ByVal dwAccessType As Long, _
  ByVal lpszProxyName As String, _
  ByVal lpszProxyBypass As String, ByVal dwFlags As Long) As Long

'Establish FTP connection
Public Declare Function InternetConnect Lib "WinInet.DLL" Alias "InternetConnectA" _
 (ByVal hInternetSession As Long, ByVal lpszServerName As String, _
  ByVal nServerPort As Long, ByVal lpszUserName As String, _
  ByVal lpszPassword As String, ByVal dwService As Long, _
  ByVal dwFlags As Long, ByVal dwContext As Long) As Long

'Close FTP Connection
Public Declare Function InternetCloseHandle Lib "WinInet.DLL" _
 (ByVal hInternetSession As Long) As Long

'PUT file via FTP
Public Declare Function FtpPutFile Lib "WinInet.DLL" Alias "FtpPutFileA" _
 (ByVal hFtpSession As Long, ByVal lpszLocalFile As String, _
  ByVal lpszNewRemoteFile As String, ByVal dwFlags As Long, _
  ByVal dwContext As Long) As Long

Public Const INTERNET_OPEN_TYPE_PRECONFIG As Long = 0&
Public Const INTERNET_DEFAULT_FTP_PORT As Long = 21&
Public Const INTERNET_SERVICE_FTP As Long = 1&
Public Const FTP_TRANSFER_TYPE_ASCII As Long = &H1& 'Ascii
Public Const FTP_TRANSFER_TYPE_BINARY As Long = &H2& 'Binary

'----------
Public Function PutFileFtp(FtpSvr As String, UserID As String, _
   Password As String, RemoteFile As String, LocalFile As String) As Long
Dim iHandle As Long
Dim iFTP As Long
Dim lngRet As Long
Dim ErrText As String
PutFileFtp = vbOK
'Connection open
iHandle = InternetOpen(vbNullString, _
                      INTERNET_OPEN_TYPE_PRECONFIG, _
                      vbNullString, _
                      vbNullString, _
                      0&)
If iHandle = 0 Then PutFileFtp = vbCancel: Exit Function  'Error
'Connect to server
iFTP = InternetConnect(iHandle, _
                       FtpSvr, _
                       INTERNET_DEFAULT_FTP_PORT, _
                       UserID, _
                       Password, _
                       INTERNET_SERVICE_FTP, _
                       0&, _
                       0&)
If iFTP = 0 Then PutFileFtp = vbCancel: Exit Function 'Error
'Put file to server. Can switch Ascii/Binary by changing the parameter below.
lngRet = FtpPutFile(iFTP, _
                    LocalFile & vbNullChar, _
                    RemoteFile & vbNullChar, _
                    FTP_TRANSFER_TYPE_ASCII, _
                    0&)
If lngRet = 0 Then PutFileFtp = vbCancel: Exit Function 'Error
lngRet = InternetCloseHandle(iFTP)
lngRet = InternetCloseHandle(iHandle)

End Function

FTP - Get file with Wininet API

2005-09-03T18:00:00.000-07:00

This function enables to do FTP from client. This uses the Wininet API functions. You can use this with the formula like:
=GetFileFtp("temp.server.com","userId","password","targetfile","localfile")


'--Declaration--------
'Open FTP connection
Public Declare Function InternetOpen Lib "WinInet.DLL" Alias "InternetOpenA" _
 (ByVal lpszAgent As String, ByVal dwAccessType As Long, _
  ByVal lpszProxyName As String, _
  ByVal lpszProxyBypass As String, ByVal dwFlags As Long) As Long

'Establish FTP connection
Public Declare Function InternetConnect Lib "WinInet.DLL" Alias "InternetConnectA" _
 (ByVal hInternetSession As Long, ByVal lpszServerName As String, _
  ByVal nServerPort As Long, ByVal lpszUserName As String, _
  ByVal lpszPassword As String, ByVal dwService As Long, _
  ByVal dwFlags As Long, ByVal dwContext As Long) As Long

'Close FTP Connection
Public Declare Function InternetCloseHandle Lib "WinInet.DLL" _
 (ByVal hInternetSession As Long) As Long

'GET file via FTP
Public Declare Function FtpGetFile Lib "WinInet.DLL" Alias "FtpGetFileA" _
  (ByVal hFtpSession As Long, ByVal lpszRemoteFile As String, _
   ByVal lpszNewFile As String, ByVal fFailIfExists As Long, _
   ByVal dwLocalFlagsAndAttributes As Long, ByVal dwInternetFlags As Long, _
   ByVal dwContext As Long) As Long

Public Const INTERNET_OPEN_TYPE_PRECONFIG As Long = 0&
Public Const INTERNET_DEFAULT_FTP_PORT As Long = 21&
Public Const INTERNET_SERVICE_FTP As Long = 1&
Public Const FTP_TRANSFER_TYPE_ASCII As Long = &H1&  'Ascii mode
Public Const FTP_TRANSFER_TYPE_BINARY As Long = &H2& 'Binary mode

'--------
Function GetFileFtp(strFtpSvr As String, strUserID As String, _
  strPassword As String, strRemoteFile As String, strLocalFile As String) As Long
Dim hInternet As Long
Dim hFTP As Long
Dim lngRet As Long
Dim strErrText As String

GetFileFtp = vbOK
'Open connection
hInternet = InternetOpen(vbNullString, _
                         INTERNET_OPEN_TYPE_PRECONFIG, _
                         vbNullString, _
                         vbNullString, _
                         0&)
If hInternet = 0 Then GetFileFtp = vbCancel: Exit Function 'Error occurred
'Connect to server
hFTP = InternetConnect(hInternet, _
                         strFtpSvr, _
                         INTERNET_DEFAULT_FTP_PORT, _
                         strUserID, _
                         strPassword, _
                         INTERNET_SERVICE_FTP, _
                         0&, _
                         0&)
If hFTP = 0 Then GetFileFtp = vbCancel: Exit Function 'Error occurred
'Finally get file. Switch ASCII, BINARY by chnaging the constant
lngRet = FtpGetFile(hFTP, _
                         strRemoteFile & vbNullChar, _
                         strLocalFile & vbNullChar, _
                         1&, _
                         0&, _
                         FTP_TRANSFER_TYPE_ASCII, _  
                         0&)
lngRet = InternetCloseHandle(hFTP)
lngRet = InternetCloseHandle(hInternet)

End Function

ADO - Stream write file

2005-09-02T06:49:00.000-07:00

This sub procedure will write what is specified in strContents as text file. Example of this is:
Call WriteHtml("c:\temp\temp.html", "Hello World", "UTF-8")


Sub WriteHtml(strFileName As String, strContents As String, strCharSet As String)

Dim oStream As Object

Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 2
oStream.Charset = strCharSet
oStream.WriteText strContents
oStream.SaveToFile FileName:=strFileName, Options:=2

oStream.Close
       
End Sub

ADO - Stream read HTML on URL

2005-09-01T06:59:00.000-07:00

The function for reading file can be used even for the file on the net. This can be done as like:
=GetFile("http://sapass.metro.client.jp", "UTF-8")


Function GetFile(strFile As String, strCharSet As String) As String
...
See "Stream read file" content.
...
End Function

ADO - Stream read file

2005-09-01T06:45:00.000-07:00

This function will read file and return the string as a result. This can be used as like:
=GetFile("c:\temp\temp.txt", "UTF-8")


Function GetFile(strFile As String, strCharSet As String) As String

Dim oStream As Object
 
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 2
oStream.flush
oStream.Charset = strCharSet
oStream.LoadFromFile FileName:=strFile
GetFile = oStream.ReadText
oStream.Close

End Function

Registry - Delete registry key

2005-08-30T05:47:00.000-07:00

This function helps to remove reigstry key. For deletion, it uses function in Shlwapi.dll.


'Open registry handle
Public Declare Function RegOpenKeyEx Lib "ADVAPI32" Alias "RegOpenKeyExA" _
 (ByVal hKey&, ByVal lpSubKey$, ByVal ulOptions&, ByVal samDesired&, _
  phkResult&) As Long
'Close registry handle
Public Declare Function RegCloseKey Lib "ADVAPI32" (ByVal hKey&) As Long
'Delete key
Private Declare Function SHDeleteKey Lib "Shlwapi" Alias "SHDeleteKeyA" _
 (ByVal hKey As Long, ByVal lpSubKey As String) As Long

Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const KEY_QUERY_VALUE           As Long = &H1
Public Const KEY_ENUMERATE_SUB_KEYS    As Long = &H8
Public Const KEY_NOTIFY                As Long = &H10
Public Const KEY_CREATE_SUB_KEY        As Long = &H4
Public Const KEY_CREATE_LINK           As Long = &H20
Public Const KEY_SET_VALUE             As Long = &H2
Public Const KEY_ALL_ACCESS            As Long = KEY_QUERY_VALUE Or _
                                                 KEY_ENUMERATE_SUB_KEYS Or _
                                                 KEY_NOTIFY Or _
                                                 KEY_CREATE_SUB_KEY Or _
                                                 KEY_CREATE_LINK Or _
                                                 KEY_SET_VALUE

   
Public Function DeleteKey(iKey As String, iSection As String, Optional iRoot _
  As String) As Long
Dim lngReturn As Long
Dim strReturn As Long
iRoot = IIf(iRoot = "", HKEY_CURRENT_USER, iRoot)
lngReturn = RegOpenKeyEx(iRoot, iKey, 0, KEY_ALL_ACCESS, strReturn)
lngReturn = SHDeleteKey(strReturn, iSection)
Call RegCloseKey(strReturn)
End Function

Registry - Set registry value

2005-08-29T02:44:00.000-07:00

On the contrary to get values from registry, here we try to set value on registry. In the code below, if there is no key yet exists, this function will create it for you. You can use this function in Excel with formula below:
=SetRegKey("temp","temp","temp")

You can check the result by RegEdit.


'Create registry key
Public Declare Function RegCreateKeyEx Lib "ADVAPI32.dll" Alias "RegCreateKeyExA" _
 (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, _
  ByVal lpClass As String, ByVal dwOptions As Long, _
  ByVal samDesired As Long, lpSecurityAttributes As Long, _
  phkResult As Long, lpdwDisposition As Long) As Long

'Set registry value
Public Declare Function RegSetValueEx Lib "ADVAPI32.dll" Alias "RegSetValueExA" _
 (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
  ByVal dwType As Long, ByVal lpData As Any, ByVal cbData As Long) As Long

'Close registry handle
Public Declare Function RegCloseKey Lib "ADVAPI32" (ByVal hKey&) As Long
    
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const KEY_QUERY_VALUE           As Long = &H1
Public Const KEY_ENUMERATE_SUB_KEYS    As Long = &H8
Public Const KEY_NOTIFY                As Long = &H10
Public Const KEY_CREATE_SUB_KEY        As Long = &H4
Public Const KEY_CREATE_LINK           As Long = &H20
Public Const KEY_SET_VALUE             As Long = &H2
Public Const KEY_ALL_ACCESS            As Long = KEY_QUERY_VALUE Or _
                                                 KEY_ENUMERATE_SUB_KEYS Or _
                                                 KEY_NOTIFY Or _
                                                 KEY_CREATE_SUB_KEY Or _
                                                 KEY_CREATE_LINK Or _
                                                 KEY_SET_VALUE

Public Function SetRegKey(iKey As String, iName As String, iValue As String, _
       Optional iRoot As String) As Long

'Update registry key
Dim lngReturn, lngResult, lngAttr As Long

SetRegKey = 0
'Open registry key
lngAttr = 0
iRoot = IIf(iRoot = "", HKEY_CURRENT_USER, iRoot)
lngResult = RegCreateKeyEx(iRoot, iKey, 0, vbNullString, 0, KEY_ALL_ACCESS, _
            lngAttr, lngReturn, Len(iValue))
lngResult = RegSetValueEx(lngReturn, iName, 0, 1, iValue, Len(iValue))
'Close registry key
Call RegCloseKey(lngReturn)

End Function

Registry - Get registry value

2005-08-28T02:33:00.000-07:00

In this code, obtain registry value for the specified key information. This utilizes the APIs in ADVAPI32 libraly.

In Excel, You can use this in formula below:
=GetRegValue("Control Panel\Desktop","ConvertedWallpaper")


'Open registry handle
Public Declare Function RegOpenKeyEx Lib "ADVAPI32" Alias "RegOpenKeyExA" _
 (ByVal hKey&, ByVal lpSubKey$, ByVal ulOptions&, ByVal samDesired&, phkResult&) As Long

'Close registry handle
Public Declare Function RegCloseKey Lib "ADVAPI32" (ByVal hKey&) As Long

'Get registry value
Public Declare Function RegQueryValueExstr Lib "ADVAPI32" Alias "RegQueryValueExA" _
 (ByVal hKey&, ByVal lpValueName$, ByVal lpReserved&, ByVal lpType&, ByVal lpData$, _
 lpcbData&) As Long

    
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const KEY_QUERY_VALUE           As Long = &H1
Public Const KEY_ENUMERATE_SUB_KEYS    As Long = &H8
Public Const KEY_NOTIFY                As Long = &H10
Public Const KEY_CREATE_SUB_KEY        As Long = &H4
Public Const KEY_CREATE_LINK           As Long = &H20
Public Const KEY_SET_VALUE             As Long = &H2
Public Const KEY_ALL_ACCESS            As Long = KEY_QUERY_VALUE Or _
                                                 KEY_ENUMERATE_SUB_KEYS Or _
                                                 KEY_NOTIFY Or _
                                                 KEY_CREATE_SUB_KEY Or _
                                                 KEY_CREATE_LINK Or _
                                                 KEY_SET_VALUE


Function GetRegValue(iKey As String, iSection As String, Optional iRoot As String) As String
'Get System information from registry
Dim lngResult, lngBuffer As Long
Dim strReturn, strBuffer As String

iRoot = IIf(iRoot = "", HKEY_CURRENT_USER, iRoot)
'Open registry key
GetRegValue = ""
lngResult = RegOpenKeyEx(iRoot, iKey, 0, KEY_QUERY_VALUE, strReturn)
If lngResult = 0 Then
   strBuffer = String(255, Chr(0))
   lngResult = RegQueryValueExstr(strReturn, iSection, 0, 0, strBuffer, 255)
   If lngResult = 0 Then
      GetRegValue = Left(strBuffer, InStr(strBuffer, Chr(0)) - 1)
   End If
End If
'Close Registry key
Call RegCloseKey(strReturn)

End Function

Ini File - Write .ini file

2005-08-27T17:04:00.000-07:00

To write and update .ini file, we can do it with the code below. This can be used with the formula below.
=WritePrivateProfileString("temp","temp","1","c:\temp\temp.ini")

Then the c:\temp\tmep.ini file will have content:
[temp]
temp=1


'Declare API
Public Declare Function WritePrivateProfileStringA Lib "kernel32" _
    (ByVal section As String, ByVal entry As String, _
     ByVal buf As String, ByVal ininm As String) As Long

Function WritePrivateProfileString(iSection As String, _
     iEntry As String, iValue As String, iFileName As String) As Long
WritePrivateProfileString = _
     WritePrivateProfileStringA(iSection, iEntry, iValue, iFileName)
End Function

Ini file - Get sections

2005-08-26T19:53:00.000-07:00

This function will get all section name defined in the specified ini file.


Public Declare Function GetPrivateProfileSectionNames Lib "Kernel32" _
  Alias "GetPrivateProfileSectionNamesA" _
 (ByVal lpszReturnBuffer As String, ByVal nSize As Long, ByVal lpFileName As String) As Long

Function GetSections(iFile As String) As String
Dim strBuffer As String * 1024
Dim lngBuffer As Long
Dim lngResult As Long
Dim lngIndex As Long
Dim varSections() As String

'strBuffer = Space(1024)
GetSections = ""
lngBuffer = GetPrivateProfileSectionNames(strBuffer, Len(strBuffer), iFile)
varSections = Split(Left(strBuffer, lngBuffer - 1), vbNullChar)
For lngIndex = 0 To UBound(varSections)
   GetSections = GetSections & varSections(lngIndex) & ";"
Next

End Function

Ini file - Get Ini file value

2005-08-25T17:54:00.000-07:00

This function reads .ini file specified in the parameter and get the value. The format of the function is:

=GetIniValue("Mail","CMCDLLNAME","c:\windows\win.ini")

Then, you may be able to obatin value "mapi.dll".


Public Declare Function GetPrivateProfileString Lib "kernel32" _
  Alias "GetPrivateProfileStringA" _
 (ByVal lpApplicationName As String, ByVal lpKeyName As Any, _
  ByVal lpDefault As String, ByVal lpReturnedString As String, _
  ByVal nSize As Long, ByVal lpFileName As String) As Long

Function GetIniValue(iSection As String, iKey As String, iFile As String) As String

Dim strBuffer As String * 96
Dim lngResult As Long
strBuffer = Space(96)
GetIniValue = ""
lngResult = GetPrivateProfileString(iSection, iKey, "", strBuffer, Len(strBuffer), iFile)
If Trim(Left(strBuffer, InStr(strBuffer, Chr(0)) - 1)) <> "" Then
   GetIniValue = Trim(Left(strBuffer, InStr(strBuffer, Chr(0)) - 1))
End If
End Function

FSO - Write text file

2005-08-24T17:25:00.000-07:00

This sample shows how to write text string into text file by FSO. This uses "WriteLine" method and write text string as line. If do not need to put CR, can use "Write" method instead.


Sub WriteToFile()

Dim objFso, objFile As Object
Dim varRange As Variant
Dim strPath As String
Dim lngRow As Long

Const FOR_READ = 1, FOR_WRITE = 2

strPath = Application.GetSaveAsFilename("*.txt")
If strPath = "False" Then Exit Sub

Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFile = objFso.OpenTextFile(strPath, FOR_WRITE, True)

For Each varRange In ActiveSheet.UsedRange.Rows
   objFile.WriteLine (varRange.Value)
Next

End Sub

FSO - Check existence of specified folder

2005-08-23T05:24:00.000-07:00

By this function, you can check the existence of the specified folder.


'This function checks for the existence of the folder
Function FolderExists(iDir As String) As Boolean 'iDir can be e.g. "c:\temp"
'Declare variable
Dim objFso As Object
'Create FSO object
Set objFso = CreateObject("Scripting.FileSystemObject")
'Returns the check result
FolderExists = objFso.FolderExists(iDir)
End Function

FSO - Check existence of the specified file

2005-08-22T05:20:00.000-07:00

This is a function which checks the existence of the specified file.


'Function to check file existence (iPath can be e.g. "c:\temp\temp.txt")
Function FileExists(iPath As String) As Boolean
'Declare variable
Dim objFso As Object
'Create FSO object
Set objFso = CreateObject("Scripting.FileSystemObject")
'Then return the result
FileExists = objFso.FileExists(iPath)
End Function

FSO - Read text file

2005-08-21T04:30:00.000-07:00

In this sub procedure, read text stream from the specified file path and copy the contents to the Active Excel worksheet. (will overwrite the contents).


'Read text file from file and copy contents to Excel sheet
Sub ReadFile()
'Define variables
Dim objFso, objFile As Object
Dim objFile As Object
Dim strPath As String
Dim lngRow As Long
'Define constant
Const FOR_READ = 1
Const FOR_WRITE = 2
'Ask file path
strPath = InputBox("Specify File Path") 'e.g. c:\temp\temp.txt
'Create FSO text stream
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFile = objFso.OpenTextFile(strPath, FOR_READ)
'Initialize row of sheet
lngRow = 1
'Read file until it ends then put the contents to sheet
Do Until objFile.AtEndOfStream
   ActiveSheet.Cells(lngRow, 1).Value = objFile.ReadLine
   lngRow = lngRow + 1
Loop

End Sub

FSO - List up files in the specified folder

2005-08-20T04:30:00.000-07:00

Here in this code, we check how to obtain the files in the specified folder. This reads the file information in the specified foler then copy the information to the active worksheet. (Note: this will overwrite the contents of the sheet.)


Sub ListUpFiles()
'Declare variables
Dim objFso, objFolder As Object
Dim varFile As Variant
Dim strDir As String
Dim lngRow As Long
'Ask directory to check
strDir = InputBox("Specify directory") 'e.g. c:\temp
'Create FSO and folder object
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder(strDir)
'Initialize row counter
lngRow = 1
'Loop file in the folder
For Each varFile In objFolder.Files
   'Copy the information
   ActiveSheet.Cells(lngRow, 1).Value = varFile.Name
   ActiveSheet.Cells(lngRow, 2).Value = varFile.DateCreated
   ActiveSheet.Cells(lngRow, 3).Value = varFile.DateLastAccessed
   ActiveSheet.Cells(lngRow, 4).Value = varFile.DateLastModified
   ActiveSheet.Cells(lngRow, 5).Value = varFile.Size
   ActiveSheet.Cells(lngRow, 6).Value = varFile.Type
   lngRow = lngRow + 1
Next

End Sub