VBA: Convert from local drive name to network drive name - vba

I have this macro that initially only used by me. But I need to distribute it to other people now. Basically, I wrote a macro that let you browse for file, and then it will convert my local path into network drive path (HTML style). As you can see from my code below, I am specifically referring to R drive and Z drive. However, if other people use it, they could have A drive and B drive instead. How do I rewrite the following such that, it will pull the network drive instead of local drive? Thanks!
Private Sub GetFilePath_Click()
FilePath = Application.GetOpenFilename()
If FilePath <> False Then
Range("E6").Value = FilePath
End If
End Sub
A function that convert the file that selected into HTML path
Function ModFilePath(FilePath As String) As String
Dim HTMLFilePath As String
Dim Drive1 As String
Dim Drive2 As String
Dim Drive3 As String
On Error Resume Next
HTMLFilePath = Replace(FilePath, " ", "%20")
'I know somehow I need to rewrite this part
Drive1 = Replace(HTMLFilePath, "R:\", "\\network_name\apple\")
Drive2 = Replace(HTMLFilePath, "Z:\", "\\network_name\orange\")
If Err.Number = 0 Then
If Left(HTMLFilePath, 1) = "R" Then
ModFilePath = Drive1
Else
If Left(HTMLFilePath, 1) = "Z" Then
ModFilePath = Drive2
End If
End If
Else
ModFilePath = "Error"
End If
End Function

Personally, I would add Inputbox to let ppl type their drive and the value given concatenated with rest of the path.

After doing some research, I actually answered my own question. Here is the code for those who are interested. The following code gets the UNC path instead of the network share drive letter when the end users import their file:
Option Explicit
Private Declare Function SetCurrentDirectory _
Lib "kernel32" _
Alias "SetCurrentDirectoryA" ( _
ByVal lpPathName As String) _
As Long
Public Sub GetFilePath_Click()
Dim vFileToOpen As Variant
Dim strCurDir As String
Dim WikiName As String
'// Keep Original Dir
strCurDir = CurDir
'// Note: If the UNC path does not exist then
'// It will default to your current one
SetCurrentDirectory "\\network_name\"
vFileToOpen = Application.GetOpenFilename
If TypeName(vFileToOpen) <> "Boolean" Then
Range("E6").Value = vFileToOpen
End If
'// End by resetting to last/original Dir
ChDir strCurDir
End Sub
The function below convert the file path that the imported file to HTML style.
Function Path2UNC(sFullName As String) As String
' Converts the mapped drive path in sFullName to a UNC path if one exists.
' If not, returns a null string
Dim sDrive As String
Dim i As Long
Dim ModDrive1 As String
Application.Volatile
sDrive = UCase(Left(sFullName, 2))
With CreateObject("WScript.Network").EnumNetworkDrives
For i = 0 To .Count - 1 Step 2
If .Item(i) = sDrive Then
Path2UNC = .Item(i + 1) & Mid(sFullName, 3)
Exit For
End If
Next
End With
ModDrive1 = Replace(Path2UNC, " ", "%20")
Path2UNC = ModDrive1
End Function

Copied from http://support.microsoft.com/kb/160529
Microsoft Office 97 and Microsoft Office 7.0
' 32-bit Function version.
' Enter this declaration on a single line.
Declare Function WNetGetConnection32 Lib "MPR.DLL" Alias _
"WNetGetConnectionA" (ByVal lpszLocalName As String, ByVal _
lpszRemoteName As String, lSize As Long) As Long
' 32-bit declarations:
Dim lpszRemoteName As String
Dim lSize As Long
' Use for the return value of WNetGetConnection() API.
Const NO_ERROR As Long = 0
' The size used for the string buffer. Adjust this if you
' need a larger buffer.
Const lBUFFER_SIZE As Long = 255
Sub GetNetPath()
' Prompt the user to type the mapped drive letter.
DriveLetter = UCase(InputBox("Enter Drive Letter of Your Network" & _
"Connection." & Chr(10) & "i.e. F (do not enter a colon)"))
' Add a colon to the drive letter entered.
DriveLetter = DriveLetter & ":"
' Specifies the size in characters of the buffer.
cbRemoteName = lBUFFER_SIZE
' Prepare a string variable by padding spaces.
lpszRemoteName = lpszRemoteName & Space(lBUFFER_SIZE)
' Return the UNC path (\\Server\Share).
lStatus& = WNetGetConnection32(DriveLetter, lpszRemoteName, _
cbRemoteName)
' Verify that the WNetGetConnection() succeeded. WNetGetConnection()
' returns 0 (NO_ERROR) if it successfully retrieves the UNC path.
If lStatus& = NO_ERROR Then
' Display the UNC path.
MsgBox lpszRemoteName, vbInformation
Else
' Unable to obtain the UNC path.
MsgBox "Unable to obtain the UNC path.", vbInformation
End If
End Sub
Microsoft Excel 5.0
' 16-bit Function for Excel 5.0. ' Enter this declaration on a single line. Declare Function WNetGetConnection Lib "user" (ByVal lpszLocalName _
As String, ByVal lpszRemoteName As String, cbRemoteName As _
Integer) As Integer
' 16-bit declarations: Dim NetName As String Dim x As Integer Dim DriveLetter As String
Sub GetNetPath()
' Prompt the user to type the mapped drive letter.
DriveLetter = UCase(InputBox("Enter Drive Letter of Your Network" & _
"Connection." & Chr(10) & "i.e. F (do not enter a colon)"))
DriveLetter = DriveLetter & ":"
' 16-bit call for Excel 5.0.
' Pad NetName with spaces.
NetName = NetName & Space(80)
' API call returns one of eight values. If it returns zero, it is
' successful.
x = WNetGetConnection(DriveLetter, NetName, 80)
' Display the UNC path.
MsgBox NetName
End Sub

Related

Save image from clipboard as .jpg and pass relative link to Access form

Using Access 365. I would like help building code to achieve the following please, I’m trying to streamline adding images to a record.
I would like to use VBA that on clicking a button will save an image as a .jpg from the clipboard (put there by User using Snip tool) to a subfolder of the database, then pass a relative link to this file to the form. I’d like to be able to attach multiple images’ links to a given record in this manner.
Using the code below (without the AltPrintScreen element) I’ve gotten as far as saving from the clipboard and generating an absolute link, but only as a .bmp. (https://www.access-programmers.co.uk/forums/threads/print-screen-into-image-file.245198/). Grateful for any help getting the rest of the way, or suggestion of an entirely different way of doing it. Cheers!
Module...
'***********************************************************************************************
' *
' * Please leave any Trademarks or Credits in place.
' *
' * ACKNOWLEDGEMENT TO CONTRIBUTORS :
' * STEPHEN BULLEN, 15 November 1998 - Original PastPicture code
' * G HUDSON, 5 April 2010 - Pause Function
' * LUTZ GENTKOW, 23 July 2011 - Alt + PrtScrn
' * PAUL FRANCIS, 11 April 2013 - Putting all pieces togeather
' *
' * DESCRIPTION: Creates a standard Picture object from whatever is on the clipboard.
' * This object is then saved to a location on the disc. Please note, this
' * can also be assigned to (for example) and Image control on a userform.
' *
' * The code requires a reference to the "OLE Automation" type library.
' *
' * The code in this module has been derived from a number of sources
' * discovered on MSDN, Access World Forum, VBForums.
' *
' * To use it, just copy this module into your project, then you can use:
' * SaveClip2Bit("C:\Pics\Sample.bmp")
' * to save this to a location on the Disc.
' * (Or)
' * Set ImageControl.Image = PastePicture
' * to paste a picture of whatever is on the clipboard into a standard image control.
' *
' * PROCEDURES:
' * PastePicture : The entry point for 'Setting' the Image
' * CreatePicture : Private function to convert a bitmap or metafile handle to an OLE reference
' * fnOLEError : Get the error text for an OLE error code
' * SaveClip2Bit : The entry point for 'Saving' the Image, calls for PastePicture
' * AltPrintScreen: Performs the automation of Alt + PrtScrn, for getting the Active Window.
' * Pause : Makes the program wait, to make sure proper screen capture takes place.
'**************************************************************************************************
Option Explicit
Option Compare Text
'Declare clipboard clear
Public Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
'Declare a UDT to store a GUID for the IPicture OLE Interface
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'Declare a UDT to store the bitmap information
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
'Windows API Function Declarations
#If Win64 = 1 And VBA7 = 1 Then
'Does the clipboard contain a bitmap/metafile?
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
'Open the clipboard to read
'Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
'Get a pointer to the bitmap/metafile
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
'Close the clipboard
'Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
'Convert the handle into an OLE IPicture interface.
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.
Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
'Uses the Keyboard simulation
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#Else
'Does the clipboard contain a bitmap/metafile?
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
'Open the clipboard to read
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
'Get a pointer to the bitmap/metafile
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
'Close the clipboard
Private Declare Function CloseClipboard Lib "user32" () As Long
'Convert the handle into an OLE IPicture interface.
Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.
Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
'Uses the Keyboard simulation
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#End If
'The API format types we're interested in
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Private Const KEYEVENTF_KEYUP = &H2
Private Const VK_SNAPSHOT = &H2C
Private Const VK_MENU = &H12
' Subroutine : AltPrintScreen
' Purpose : Capture the Active window, and places on the Clipboard.
Sub AltPrintScreen()
'keybd_event VK_MENU, 0, 0, 0
'keybd_event VK_SNAPSHOT, 0, 0, 0
'keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
'keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0
End Sub
' Subroutine : PastePicture
' Purpose : Get a Picture object showing whatever's on the clipboard.
Function PastePicture() As IPicture
'Some pointers
Dim h As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long
'Check if the clipboard contains the required format
If IsClipboardFormatAvailable(CF_BITMAP) Then
'Get access to the clipboard
h = OpenClipboard(0&)
If h > 0 Then
'Get a handle to the image data
hPtr = GetClipboardData(CF_BITMAP)
hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
'Release the clipboard to other programs
h = CloseClipboard
'If we got a handle to the image, convert it into a Picture object and return it
If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, CF_BITMAP)
End If
End If
End Function
' Subroutine : CreatePicture
' Purpose : Converts a image (and palette) handle into a Picture object.
' NOTE : Requires a reference to the "OLE Automation" type library
Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture
' IPicture requires a reference to "OLE Automation"
Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture
'OLE Picture types
Const PICTYPE_BITMAP = 1
Const PICTYPE_ENHMETAFILE = 4
' Create the Interface GUID (for the IPicture interface)
With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
' Fill uPicInfo with necessary parts.
With uPicInfo
.Size = Len(uPicInfo) ' Length of structure.
.Type = PICTYPE_BITMAP ' Type of Picture
.hPic = hPic ' Handle to image.
.hPal = hPal ' Handle to palette (if bitmap).
End With
' Create the Picture object.
r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
' If an error occured, show the description
If r <> 0 Then Debug.Print "Create Picture: " & fnOLEError(r)
' Return the new Picture object.
Set CreatePicture = IPic
End Function
' Subroutine : fnOLEError
' Purpose : Gets the message text for standard OLE errors
Private Function fnOLEError(lErrNum As Long) As String
'OLECreatePictureIndirect return values
Const E_ABORT = &H80004004
Const E_ACCESSDENIED = &H80070005
Const E_FAIL = &H80004005
Const E_HANDLE = &H80070006
Const E_INVALIDARG = &H80070057
Const E_NOINTERFACE = &H80004002
Const E_NOTIMPL = &H80004001
Const E_OUTOFMEMORY = &H8007000E
Const E_POINTER = &H80004003
Const E_UNEXPECTED = &H8000FFFF
Const S_OK = &H0
Select Case lErrNum
Case E_ABORT
fnOLEError = " Aborted"
Case E_ACCESSDENIED
fnOLEError = " Access Denied"
Case E_FAIL
fnOLEError = " General Failure"
Case E_HANDLE
fnOLEError = " Bad/Missing Handle"
Case E_INVALIDARG
fnOLEError = " Invalid Argument"
Case E_NOINTERFACE
fnOLEError = " No Interface"
Case E_NOTIMPL
fnOLEError = " Not Implemented"
Case E_OUTOFMEMORY
fnOLEError = " Out of Memory"
Case E_POINTER
fnOLEError = " Invalid Pointer"
Case E_UNEXPECTED
fnOLEError = " Unknown Error"
Case S_OK
fnOLEError = " Success!"
End Select
End Function
' Routine : SaveClip2Bit
' Purpose : Saves Picture object to desired location.
' Arguments : Path to save the file
Public Sub SaveClip2Bit(savePath As String)
On Error GoTo errHandler:
AltPrintScreen
Pause (2)
SavePicture PastePicture, savePath
errExit:
Exit Sub
errHandler:
Debug.Print "Save Picture: (" & Err.Number & ") - " & Err.Description
Resume errExit
End Sub
' Routine : Pause
' Purpose : Gives a short intreval for proper image capture.
' Arguments : Seconds to wait.
Public Function Pause(NumberOfSeconds As Variant)
On Error GoTo Err_Pause
Dim PauseTime As Variant, start As Variant
PauseTime = NumberOfSeconds
start = Timer
Do While Timer < start + PauseTime
DoEvents
Loop
Exit_Pause:
Exit Function
Err_Pause:
MsgBox Err.Number & " - " & Err.Description, vbCritical, "Pause()"
Resume Exit_Pause
End Function
I've created a solution that does what I want. I've used four Modules I found on various sites and then created a bit of VBA to pull the tasks together in the background.
Module 1 is the one I posted in the question above. I bypass the
AltPrintScreen part of it so it doesn't overwrite the image already in the
clipboard.
Module 2 Converts the BMP created by Modules 1 into a JPG.
Module 3 Scans a folder and populates an unbound listbox with a list
of the files found there.
Module 4 is used to make the filepaths in the listbox act as
hyperlinks to open the images on clicking.
I then created a button on a form that calls the first two Module to create a jpg from the image in the clipboard as follows...
Private Sub Command12_Click()
Dim Foldername As String
Dim FileRoot As String
Dim FilePathBMP As String
Dim FilePathJPG As String
Dim FilePathJPG2 As String
' Fist check to see if a unique folder for the open record exists, create if not
Foldername = CurrentProject.Path & "\xrays\" & Format(record_id.Value)
If Len(Dir(Foldername, vbDirectory)) = 0 Then
MkDir CurrentProject.Path & "\xrays\" & Format(record_id.Value)
End If
On Error GoTo reportErr
'The filename will begin with a date\time stamp then pull text from drop down lists the user can pick. This first creates a base filename without filtype extensions.
FileRoot = CurrentProject.Path & "\xrays\" & Format(record_id.Value) & "\" & Format(Now, "yyyymmddhhmmss") & "_" & Format(Combo14.Value) & "_" & Format(Combo21.Value)
'Creates a BMP and JPG version of the filename
FilePathBMP = FileRoot & ".bmp"
FilePathJPG = FileRoot & ".jpg"
'Save a BMP
SaveClip2Bit FilePathBMP
'Convert to JPG
WIA_ConvertImage FilePathBMP, FilePathJPG, JPEG, 85
'Delete the BMP
Kill (FilePathBMP)
Exit Sub
reportErr:
MsgBox "No image in Clipboard"
Resume Next
End Sub
On the form that will display the file list I've placed an unbound listbox "FileList". The following code calls on Module 3 and is in the OnLoad event of the form...
Call ListFiles(CurrentProject.Path & "\xrays\" & Format(record_id.Value), , , Me.FileList)
The following code is used to refresh the listbox "FileList". It can be put on an OnClick event of a button or added to the end of the above code to automatically refresh after adding a new image
Me.FileList.RowSource = ""
Call ListFiles(CurrentProject.Path & "\xrays\" & Format(record_id.Value), , , Me.FileList)
Me.FileList.Requery
Finally I put the following code in the OnDblClick event of the listbox, which calls Module 4...
Dim sPath As String
Dim sFile As String
sPath = FileList.Column(0)
' The line below extracts the filename from the full path (everything to the right of the last /)
' sFile = Right(sPath, Len(sPath) - InStrRev(sPath, "\"))
GoHyperlink (sPath)
Module 2...
Public Enum wiaFormat
BMP = 0
GIF = 1
JPEG = 2
PNG = 3
TIFF = 4
End Enum
'---------------------------------------------------------------------------------------
' Procedure : WIA_ConvertImage
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Convert an image's format using WIA
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Uses Late Binding, so none required
'
' Windows Image Acquisition (WIA)
' https://msdn.microsoft.com/en-us/library/windows/desktop/ms630368(v=vs.85).aspx
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sInitialImage : Fully qualified path and filename of the original image to resize
' sOutputImage : Fully qualified path and filename of where to save the new image
' lFormat : Format to convert the image into
' lQuality : Quality level to be used for the conversion process (1-100)
'
' Usage:
' ~~~~~~
' Call WIA_ConvertImage("C:\Users\Public\Pictures\Sample Pictures\Chrysanthemum.jpg", _
' "C:\Users\MyUser\Desktop\Chrysanthemum_2.jpg", _
' JPEG)
'
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' **************************************************************************************
' 1 2017-01-18 Initial Release
' 2 2018-09-20 Updated Copyright
'---------------------------------------------------------------------------------------
Public Function WIA_ConvertImage(sInitialImage As String, _
sOutputImage As String, _
lFormat As wiaFormat, _
Optional lQuality As Long = 85) As Boolean
On Error GoTo Error_Handler
Dim oWIA As Object 'WIA.ImageFile
Dim oIP As Object 'ImageProcess
Dim sFormatID As String
Dim sExt As String
'Convert our Enum over to the proper value used by WIA
Select Case lFormat
Case 0
sFormatID = "{B96B3CAB-0728-11D3-9D7B-0000F81EF32E}"
sExt = "BMP"
Case 1
sFormatID = "{B96B3CB0-0728-11D3-9D7B-0000F81EF32E}"
sExt = "GIF"
Case 2
sFormatID = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"
sExt = "JPEG"
Case 3
sFormatID = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
sExt = "PNG"
Case 4
sFormatID = "{B96B3CB1-0728-11D3-9D7B-0000F81EF32E}"
sExt = "TIFF"
End Select
If lQuality > 100 Then lQuality = 100
'Should check if the output file already exists and if so,
'prompt the user to overwrite it or not
Set oWIA = CreateObject("WIA.ImageFile")
Set oIP = CreateObject("WIA.ImageProcess")
oIP.Filters.Add oIP.FilterInfos("Convert").FilterID
oIP.Filters(1).Properties("FormatID") = sFormatID
oIP.Filters(1).Properties("Quality") = lQuality
oWIA.LoadFile sInitialImage
Set oWIA = oIP.Apply(oWIA)
'Overide the specified ext with the appropriate one for the choosen format
oWIA.SaveFile Left(sOutputImage, InStrRev(sOutputImage, ".")) & LCase(sExt)
WIA_ConvertImage = True
Error_Handler_Exit:
On Error Resume Next
If Not oIP Is Nothing Then Set oIP = Nothing
If Not oWIA Is Nothing Then Set oWIA = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: WIA_ConvertImage" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
Module 3...
Option Compare Database
Public Function ListFiles(strPath As String, Optional strFileSpec As String, _
Optional bIncludeSubfolders As Boolean, Optional lst As ListBox)
On Error GoTo Err_Handler
'Purpose: List the files in the path.
'Arguments: strPath = the path to search.
' strFileSpec = "*.*" unless you specify differently.
' bIncludeSubfolders: If True, returns results from subdirectories of strPath as well.
' lst: if you pass in a list box, items are added to it. If not, files are listed to immediate window.
' The list box must have its Row Source Type property set to Value List.
'Method: FilDir() adds items to a collection, calling itself recursively for subfolders.
Dim colDirList As New Collection
Dim varItem As Variant
Call FillDir(colDirList, strPath, strFileSpec, bIncludeSubfolders)
'Add the files to a list box if one was passed in. Otherwise list to the Immediate Window.
If lst Is Nothing Then
For Each varItem In colDirList
Debug.Print varItem
Next
Else
For Each varItem In colDirList
lst.AddItem varItem
Next
End If
Exit_Handler:
Exit Function
Err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume Exit_Handler
End Function
Private Function FillDir(colDirList As Collection, ByVal strFolder As String, strFileSpec As String, _
bIncludeSubfolders As Boolean)
'Build up a list of files, and then add add to this list, any additional folders
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add the files to the folder.
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colDirList.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Build collection of additional subfolders.
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call function recursively for each subfolder.
For Each vFolderName In colFolders
Call FillDir(colDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(varIn As Variant) As String
If Len(varIn) > 0& Then
If Right(varIn, 1&) = "\" Then
TrailingSlash = varIn
Else
TrailingSlash = varIn & "\"
End If
End If
End Function
Module 4...
Option Compare Database
Option Explicit
'Purpose: Avoid warning and error messages when opening files with FollowHyperlink
'Author: Allen Browne (allen#allenbrowne.com)
'Release: 28 January 2008
'Usage: To open MyFile.doc in Word, use:
' GoHyperlink "MyFile.doc"
' instead of:
' FollowHyperlink "MyFile.doc"
'Rationale:
'FollowHyperlink has several problems:
' a) It errors if a file name contains characters such as #, %, or &.
' b) It can give unwanted warnings, e.g. on a fileame with "file:///" prefix.
' c) It yields errors if the link did not open.
'This replacement:
' a) escapes the problem characters
' b) prepends the prefix
' c) returns True if the link opened (with an optional error message if you care.)
'Limitations:
' - If a file name contains two # characters, it is treated as a hyperlink.
' - If a file name contains % followed by 2 hex digits, it assumes it is pre-escaped.
' - File name must include path.
'Documentation: http://allenbrowne.com/func-GoHyperlink.html
Public Function GoHyperlink(FullFilenameOrLink As Variant) As Boolean
On Error GoTo Err_Handler
'Purpose: Replacement for FollowHyperlink.
'Return: True if the hyperlink opened.
'Argument: varIn = the link to open
Dim strLink As String
Dim strErrMsg As String
'Skip error, null, or zero-length string.
If Not IsError(FullFilenameOrLink) Then
If FullFilenameOrLink <> vbNullString Then
strLink = PrepHyperlink(FullFilenameOrLink, strErrMsg)
If strLink <> vbNullString Then
FollowHyperlink strLink
'Return True if we got here without error.
GoHyperlink = True
End If
'Display any error message from preparing the link.
If strErrMsg <> vbNullString Then
MsgBox strErrMsg, vbExclamation, "PrepHyperlink()"
End If
End If
End If
Exit_Handler:
Exit Function
Err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "GoHyperlink()"
Resume Exit_Handler
End Function
Public Function PrepHyperlink(varIn As Variant, Optional strErrMsg As String) As Variant
On Error GoTo Err_Handler
'Purpose: Avoid errors and warnings when opening hyperlinks.
'Return: The massaged link/file name.
'Arguments: varIn = the link/file name to massage.
' strErrMsg = string to append error messages to.
'Note: Called by GoHyperlink() above.
' Can also be called directly, to prepare hyperlinks.
Dim strAddress As String 'File name or address
Dim strDisplay As String 'Display part of hyperlink (if provided)
Dim strTail As String 'Any remainding part of hyperlink after address
Dim lngPos1 As Long 'Position of character in string (and next)
Dim lngPos2 As Long
Dim bIsHyperlink As Boolean 'Flag if input is a hyperlink (not just a file name.)
Const strcDelimiter = "#" 'Delimiter character within hyperlinks.
Const strcEscChar = "%" 'Escape character for hyperlinks.
Const strcPrefix As String = "file:///" 'Hyperlink type if not supplied.
If Not IsError(varIn) Then
strAddress = Nz(varIn, vbNullString)
End If
If strAddress <> vbNullString Then
'Treat as a hyperlink if there are two or more # characters (other than together, or at the end.)
lngPos1 = InStr(strAddress, strcDelimiter)
If (lngPos1 > 0&) And (lngPos1 < Len(strAddress) - 2&) Then
lngPos2 = InStr(lngPos1 + 1&, strAddress, strcDelimiter)
End If
If lngPos2 > lngPos1 + 1& Then
bIsHyperlink = True
strTail = Mid$(strAddress, lngPos2 + 1&)
strDisplay = Left$(strAddress, lngPos1 - 1&)
strAddress = Mid$(strAddress, lngPos1 + 1&, lngPos2 - lngPos1)
End If
'Replace any % that is not immediately followed by 2 hex digits (in both display and address.)
strAddress = EscChar(strAddress, strcEscChar)
strDisplay = EscChar(strDisplay, strcEscChar)
'Replace special characters with percent sign and hex value (address only.)
strAddress = EscHex(strAddress, strcEscChar, "&", """", " ", "#", "<", ">", "|", "*", "?")
'Replace backslash with forward slash (address only.)
strAddress = Replace(strAddress, "\", "/")
'Add prefix if address doesn't have one.
If Not ((varIn Like "*://*") Or (varIn Like "mailto:*")) Then
strAddress = strcPrefix & strAddress
End If
End If
'Assign return value.
If strAddress <> vbNullString Then
If bIsHyperlink Then
PrepHyperlink = strDisplay & strcDelimiter & strAddress & strcDelimiter & strTail
Else
PrepHyperlink = strAddress
End If
Else
PrepHyperlink = Null
End If
Exit_Handler:
Exit Function
Err_Handler:
strErrMsg = strErrMsg & "Error " & Err.Number & ": " & Err.Description & vbCrLf
Resume Exit_Handler
End Function
Private Function EscChar(ByVal strIn As String, strEscChar As String) As String
'Purpose: If the escape character is found in the string,
' escape it (unless it is followed by 2 hex digits.)
'Return: Fixed up string.
'Arguments: strIn = the string to fix up
' strEscChar = the single character used for escape sequqnces. (% for hyperlinks.)
Dim strOut As String 'output string.
Dim strChar As String 'character being considered.
Dim strTestHex As String '4-character string of the form &HFF.
Dim lngLen As Long 'Length of input string.
Dim i As Long 'Loop controller
Dim bReplace As Boolean 'Flag to replace character.
lngLen = Len(strIn)
If (lngLen > 0&) And (Len(strEscChar) = 1&) Then
For i = 1& To lngLen
bReplace = False
strChar = Mid(strIn, i, 1&)
If strChar = strEscChar Then
strTestHex = "&H" & Mid(strIn, i + 1&, 2&)
If Len(strTestHex) = 4& Then
If Not IsNumeric(strTestHex) Then
bReplace = True
End If
End If
End If
If bReplace Then
strOut = strOut & strEscChar & Hex(Asc(strEscChar))
Else
strOut = strOut & strChar
End If
Next
End If
If strOut <> vbNullString Then
EscChar = strOut
ElseIf lngLen > 0& Then
EscChar = strIn
End If
End Function
Private Function EscHex(ByVal strIn As String, strEscChar As String, ParamArray varChars()) As String
'Purpose: Replace any characters from the array with the escape character and their hex value.
'Return: Fixed up string.
'Arguments: strIn = string to fix up.
' strEscChar = the single character used for escape sequqnces. (% for hyperlinks.)
' varChars() = an array of single-character strings to replace.
Dim i As Long 'Loop controller
If (strIn <> vbNullString) And IsArray(varChars) Then
For i = LBound(varChars) To UBound(varChars)
strIn = Replace(strIn, varChars(i), strEscChar & Hex(Asc(varChars(i))))
Next
End If
EscHex = strIn
End Function
I hope all that helps others!

Word 2010 VBA to select printer without changing system default printer

In Word 2010, I'm trying to create a macro that sets the current printer to a specific color printer on our network, without making that printer the user's system default printer. I've hacked together some code below from samples I've found on the web. Everything works, except that the SetColorPrinterEast Sub changes the user's system default printer, which I do not want. I suspect the DoNotSetAsSysDefault in that sub is not working as intended, but I don't know what to do about it. See the comments in the code for further explanation. Any thoughts will be greatly appreciated. Thanks in advance!!!
'I found the code block below on the web. I don't understand it, but
'it seems to work properly with the "SetDefaultPrinter"
'Sub below to get the system default printer.
Public Declare Function GetProfileString Lib "kernel32" _
Alias "GetProfileStringA" _
(ByVal lpAppName As String, _
ByVal lpKeyName As String, _
ByVal lpDefault As String, _
ByVal lpReturnedString As String, _
ByVal nSize As Long) As Long
' This code successfully sets the document to print from
' the system default printer.
Public Sub SetDefaultPrinter()
Dim strReturn As String
Dim intReturn As Integer
strReturn = Space(255)
intReturn = GetProfileString("Windows", ByVal "device", "", _
strReturn, Len(strReturn))
If intReturn Then
strReturn = UCase(Left(strReturn, InStr(strReturn, ",") - 1))
End If
With Dialogs(wdDialogFilePrintSetup)
.Printer = strReturn
.DoNotSetAsSysDefault = True
.Execute
End With
End Sub
' This code correctly sets the printer to a specific color printer
' on our network. The problem is that it makes that printer
' the user's system default printer. I would think that the
' .DoNotSetAsSysDefault = True line would solve this problem
' but still this sub changes the user's system default printer.
Public Sub SetColorPrinterEast()
With Dialogs(wdDialogFilePrintSetup)
.Printer = "\\[*NETWORK PATH*]\Color Printer East"
.DoNotSetAsSysDefault = True
.Execute
End With
End Sub
I had this same problem a few years back, got around it by storing the current default print in a variable, changing the default printer to the one I need, printing, then changing the default printer back to users original default.
This was designed and written for Word 2003 but has continued to work in Word 2010.
Here is the specific code I used:
'Define Printer to add and printer to delete
Const PrintPath = "\\prn001l0003\Colour04"
Const PrintDeletePath = "\\prn001l0003\Colour02"
' Used to see what printers are set up on the user, and to set a new network printer
Public Declare Function EnumPrinters Lib "winspool.drv" Alias "EnumPrintersA" (ByVal flags As Long, ByVal name As String, _
ByVal Level As Long, pPrinterEnum As Long, ByVal cdBuf As Long, pcbNeeded As Long, pcReturned As Long) As Long
Public Declare Function PtrToStr Lib "kernel32" Alias "lstrcpyA" (ByVal RetVal As String, ByVal Ptr As Long) As Long
Public Declare Function StrLen Lib "kernel32" Alias "lstrlenA" (ByVal Ptr As Long) As Long
Const PRINTER_ENUM_CONNECTIONS = &H4
Const PRINTER_ENUM_LOCAL = &H2
Public Sub PrintLetter(ByRef LetterBrochures() As String)
'Print the document
Dim STDprinter As String
On Error Resume Next
Call CheckPrinterLoaded ' Get users loaded printers, remove any old printers used here,
' and add printer I want to users printers
STDprinter = Application.ActivePrinter ' store the current default printer
Application.ActivePrinter = PrintPath ' change default printer to want I want
On Error GoTo printLetterError
Application.DisplayAlerts = wdAlertsNone ' prevent Word showing any alert/warnings etc
With ActiveDocument ' first page is letterhead from tray 2, all others from tray 1, print
.PageSetup.FirstPageTray = 3 ' 3 = Tray 2 on MFLaser
.PageSetup.OtherPagesTray = 1 ' 1 = Tray 1 on MFLaser
.PrintOut Background:=False
End With
Application.DisplayAlerts = wdAlertsAll ' enable Word alets/warning etc
Application.ActivePrinter = STDprinter 'change back users default printer
Exit Sub
printLetterError:
MsgBox "Error printing letter" & vbCrLf & Err.Number & vbCrLf & Err.Description, vbCritical, "Error"
ActiveDocument.Close False
End
End Sub
Public Function CheckPrinterLoaded()
'get users printers
'look for and delete defined printer, PrintDeletePath
'add printer I want to users printers, PrintPath
Dim StrPrinters As Variant, x As Long
Dim StrSetPrinter As String
Dim objNetwork
Set objNetwork = CreateObject("WScript.Network")
StrPrinters = ListPrinters
'Fist check whether the array is filled with anything, by calling another function, IsBounded.
If IsBounded(StrPrinters) Then
For x = LBound(StrPrinters) To UBound(StrPrinters)
If StrPrinters(x) = PrintDeletePath Then
objNetwork.RemovePrinterConnection PrintDeletePath
End If
Next x
objNetwork.AddWindowsPrinterConnection PrintPath
Else
MsgBox "No printers found"
End If
End Function
Private Function ListPrinters() As Variant
Dim bSuccess As Boolean
Dim iBufferRequired As Long
Dim iBufferSize As Long
Dim iBuffer() As Long
Dim iEntries As Long
Dim iIndex As Long
Dim strPrinterName As String
Dim iDummy As Long
Dim iDriverBuffer() As Long
Dim StrPrinters() As String
iBufferSize = 3072
ReDim iBuffer((iBufferSize \ 4) - 1) As Long
'EnumPrinters will return a value False if the buffer is not big enough
bSuccess = EnumPrinters(PRINTER_ENUM_CONNECTIONS Or PRINTER_ENUM_LOCAL, vbNullString, 1, iBuffer(0), iBufferSize, iBufferRequired, iEntries)
If Not bSuccess Then
If iBufferRequired > iBufferSize Then
iBufferSize = iBufferRequired
Debug.Print "iBuffer too small. Trying again with "; iBufferSize & " bytes."
ReDim iBuffer(iBufferSize \ 4) As Long
End If
'Try again with new buffer
bSuccess = EnumPrinters(PRINTER_ENUM_CONNECTIONS Or PRINTER_ENUM_LOCAL, vbNullString, 1, iBuffer(0), iBufferSize, iBufferRequired, iEntries)
End If
If Not bSuccess Then
'Enumprinters returned False
MsgBox "Error enumerating printers."
Exit Function
Else
'Enumprinters returned True, use found printers to fill the array
ReDim StrPrinters(iEntries - 1)
For iIndex = 0 To iEntries - 1
'Get the printername
strPrinterName = Space$(StrLen(iBuffer(iIndex * 4 + 2)))
iDummy = PtrToStr(strPrinterName, iBuffer(iIndex * 4 + 2))
StrPrinters(iIndex) = strPrinterName
Next iIndex
End If
ListPrinters = StrPrinters
End Function
Private Function IsBounded(vArray As Variant) As Boolean
'If the variant passed to this function is an array, the function will return True; otherwise it will return False
On Error Resume Next
IsBounded = IsNumeric(UBound(vArray))
End Function

Writing a string to a new .csv in VB.net

I am trying to write a string to a .csv file, but unable to get it to display.
I have managed to do it in VBA, but when writing in VB.net it's not working.
I first create the file and set the headers for each column. After this I am getting information on each required attribute and writing it to a string s.
All i want to do now is write the string to the .csv file so that each attribute is in the right column under the right header.
Each time the string s simply needs to be on a new row.
This is what I have so far (I have cut out some bits of code so some syntax may look incorrect). What am i doing wrong or missing?
Sub Main()
Dim sOutput As String
' Create a header for the output file
sOutput = ("Level,Occurrence Name,Reference Name,Object type, Visibility, Path" & vbLf)
If Occs.Count > 0 Then
For i = 1 To Occs.Count
iLevel = 0
curOcc = Occs.Item(i)
GetOccurrenceData(curOcc, sOutput, oSel, False, iLevel)
Next
End If
' Write the output string to a file
Dim sPath As String
Dim bWrite As Boolean
sPath = ("C:\temp\data3.csv")
bWrite = WriteFile(sPath, sOutput)
End Sub
Sub GetOccurrenceData(curOcc As VPMOccurrence, s As String, sel As Selection, ByVal bParentHidden As Boolean, ByVal iParentLevel As Integer)
'CODE TO GET DATA REMOVED AS IRRELEVANT
' Append the output string with the data for the current occurrence.
s = (s & curLevel & "," & sName & "," & sRefName & "," & sType & "," & sVisibility & vbLf)
' Repeat this data gathering procedure on any children the current occurrence may have.
Occs = curOcc.Occurrences
If Occs.Count > 0 Then
For i = 1 To Occs.Count
GetOccurrenceData(Occs.Item(i), s, sel, bChildrenInheritNoShow, curLevel)
Next
End If
In GetOccurrenceData you pass in a string and change it in the method, but you did not pass it in as a ByRef so anything done to the string in the method stays in the method.
Change the header of your method to read
Sub GetOccurrenceData(curOcc As VPMOccurrence,ByRef s As String, sel As Selection, ByVal bParentHidden As Boolean, ByVal iParentLevel As Integer)
I would however recommend using a StringBuilder to accomplish what you are doing.
Like This:
Sub Main()
Dim sb As New Text.StringBuilder()
sb.AppendLine("Level,Occurrence Name,Reference Name,Object type, Visibility, Path")
If Occs.Count > 0 Then
For i = 1 To Occs.Count
iLevel = 0
curOcc = Occs.Item(i)
GetOccurrenceData(curOcc, sb, oSel, False, iLevel)
Next
End If
' Write the output string to a file
Dim sPath As String
Dim bWrite As Boolean
sPath = ("C:\temp\data3.csv")
bWrite = WriteFile(sPath, sb.ToString())
End Sub
Sub GetOccurrenceData(curOcc As VPMOccurrence, sb As Text.StringBuilder, sel As Selection, ByVal bParentHidden As Boolean, ByVal iParentLevel As Integer)
'CODE TO GET DATA REMOVED AS IRRELEVANT
' Append the output string with the data for the current occurrence.
sb.Append(curLevel).Append(",").Append(sName).Append(",").Append(sRefName).Append(",").Append(sType).Append(",").AppendLine(sVisibility)
' Repeat this data gathering procedure on any children the current occurrence may have.
Occs = curOcc.Occurrences
If Occs.Count > 0 Then
For i = 1 To Occs.Count
GetOccurrenceData(Occs.Item(i), sb, sel, bChildrenInheritNoShow, curLevel)
Next
End If
End Sub

Convert VBA to VBS

I have a little VBA script with some functions that I would like to convert to a single VBS file.
Here is an example of what I got:
Private 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
Private Function ReadIniFileString(ByVal Sect As String, ByVal Keyname As String) As String
Dim Worked As Long
Dim RetStr As String * 128
Dim StrSize As Long
Dim iNoOfCharInIni As Integer
Dim sIniString, sProfileString As String
iNoOfCharInIni = 0
sIniString = ""
If Sect = "" Or Keyname = "" Then
MsgBox "Erreur lors de la lecture des paramètres dans " & IniFileName, vbExclamation, "INI"
Access.Application.Quit
Else
sProfileString = ""
RetStr = Space(128)
StrSize = Len(RetStr)
Worked = GetPrivateProfileString(Sect, Keyname, "", RetStr, StrSize, IniFileName)
If Worked Then
iNoOfCharInIni = Worked
sIniString = Left$(RetStr, Worked)
End If
End If
ReadIniFileString = sIniString
End Function
And then, I need to use this function to put some values in strings. VBS doesn't seem to like any of my var declaration ((Dim) MyVar As MyType).
If I'm able to adapt that code to VBS, I should be able to do the rest of my functions too. How can I adapt/convert this to VBS? Thank you.
It's a pitty i didn't see this earlier, anyway, for future reference here is a pure vbscript solution to read a value from an ini file. If anyone needs explanation on the used regular expression just leave a comment.
'this is the contents of test.ini'
' [Brussels]
' Address = "Postbox 3245_58348 Brussels"
' [Copenhagen]
' Address = "Postbox 2455_5478347 Copenhagen"
' [Paris]
' Address = "Postbox 8546_5412557 Paris"
section = "Brussels"
key = "Address"
const ForReading = 1
set fso = CreateObject("Scripting.FileSystemObject")
set file = fso.OpenTextFile("test.ini", ForReading)
'returns "Postbox 3245_58348 Brussels"'
wscript.echo get_key_of_ini(file.readall, section, key)
function get_key_of_ini(readFile, section, key)
set regEx = New RegExp
with regEx
.Pattern = "(\[" & section & "\]\r\n)([^\[]+)"
.IgnoreCase = True
.Global = True
end With
set matches = regEx.execute(readFile)
for x = 0 to matches.count-1
set match = matches(x)
For i = 1 To match.subMatches.count-1
subMatches = match.SubMatches(i)
if trim(split(match.SubMatches(i),"=")(0)) = key then
get_key_of_ini = trim(split(match.SubMatches(i),"=")(1))
end if
Next
next
end function
Since you have an MDB that does what you want, run the VBS script to open this mdb and set the AutoExec Macro to run the functions that compact these Databases and then self close the MDB. This is a bit hacky but may prove to be the least troublesome.

How to retrieve this computer's IP address?

What is the least cumbersome (module-inclusion, code lenght, etc) way to retrieve the machine IP address (of the first interface open)?
I know of some solutions using MSINET, but I believe we can do better.
Don't reply
Function HomeIP() as Atring
HomeIP= "127.0.0.1"
End Function
because it's not that funny... or correct.
The scenario is a question wiht a document ID feature I'm trying to build a reply for.
Here's an adapted example from Technet:
Function GetIPAddress()
Const strComputer As String = "." ' Computer name. Dot means local computer
Dim objWMIService, IPConfigSet, IPConfig, IPAddress, i
Dim strIPAddress As String
' Connect to the WMI service
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
' Get all TCP/IP-enabled network adapters
Set IPConfigSet = objWMIService.ExecQuery _
("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled=TRUE")
' Get all IP addresses associated with these adapters
For Each IPConfig In IPConfigSet
IPAddress = IPConfig.IPAddress
If Not IsNull(IPAddress) Then
strIPAddress = strIPAddress & Join(IPAddress, ", ")
End If
Next
GetIPAddress = strIPAddress
End Function
It requires that you have Microsoft WMI Scripting Library in the project's references.
A couple of examples I found:-
http://www.everythingaccess.com/tutorials.asp?ID=Get-all-IP-Addresses-of-your-machine
http://puremis.net/excel/code/079.shtml
EDIT
Here is the code from the first link with slight modification
Option Explicit
' VBA MODULE: Get all IP Addresses of your machine
' (c) 2005 Wayne Phillips (http://www.everythingaccess.com)
' Written 18/05/2005
'
' REQUIREMENTS: Windows 98 or above, Access 97 and above
'
' Please read the full tutorial here:
' http://www.everythingaccess.com/tutorials.asp?ID=Get-all-IP-Addresses-of-your-machine
'
' Please leave the copyright notices in place.
' Thank you.
'
'Option Compare Database
'A couple of API functions we need in order to query the IP addresses in this machine
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function GetIpAddrTable Lib "Iphlpapi" (pIPAdrTable As Byte, pdwSize As Long, ByVal Sort As Long) As Long
'The structures returned by the API call GetIpAddrTable...
Type IPINFO
dwAddr As Long ' IP address
dwIndex As Long ' interface index
dwMask As Long ' subnet mask
dwBCastAddr As Long ' broadcast address
dwReasmSize As Long ' assembly size
Reserved1 As Integer
Reserved2 As Integer
End Type
Public Function ConvertIPAddressToString(longAddr As Long) As String
Dim IPBytes(3) As Byte
Dim lngCount As Long
'Converts a long IP Address to a string formatted 255.255.255.255
'Note: Could use inet_ntoa instead
CopyMemory IPBytes(0), longAddr, 4 ' IP Address is stored in four bytes (255.255.255.255)
'Convert the 4 byte values to a formatted string
While lngCount < 4
ConvertIPAddressToString = ConvertIPAddressToString + _
CStr(IPBytes(lngCount)) + _
IIf(lngCount < 3, ".", "")
lngCount = lngCount + 1
Wend
End Function
Public Function GetFirstNonLocalIPAddress()
Dim Ret As Long, Tel As Long
Dim bytBuffer() As Byte
Dim IPTableRow As IPINFO
Dim lngCount As Long
Dim lngBufferRequired As Long
Dim lngStructSize As Long
Dim lngNumIPAddresses As Long
Dim strIPAddress As String
On Error GoTo ErrorHandler:
Call GetIpAddrTable(ByVal 0&, lngBufferRequired, 1)
If lngBufferRequired > 0 Then
ReDim bytBuffer(0 To lngBufferRequired - 1) As Byte
If GetIpAddrTable(bytBuffer(0), lngBufferRequired, 1) = 0 Then
'We've successfully obtained the IP Address details...
'How big is each structure row?...
lngStructSize = LenB(IPTableRow)
'First 4 bytes is a long indicating the number of entries in the table
CopyMemory lngNumIPAddresses, bytBuffer(0), 4
While lngCount < lngNumIPAddresses
'bytBuffer contains the IPINFO structures (after initial 4 byte long)
CopyMemory IPTableRow, _
bytBuffer(4 + (lngCount * lngStructSize)), _
lngStructSize
strIPAddress = ConvertIPAddressToString(IPTableRow.dwAddr)
If Not ((strIPAddress = "127.0.0.1")) Then
GetFirstNonLocalIPAddress = strIPAddress
Exit Function
End If
lngCount = lngCount + 1
Wend
End If
End If
Exit Function
ErrorHandler:
MsgBox "An error has occured in GetIPAddresses():" & vbCrLf & vbCrLf & _
Err.Description & " (" & CStr(Err.Number) & ")"
End Function
You could execute the shell command ipconfig and parse the returned results?
There is another easy way using ipconfig.
http://www.vbaexpress.com/kb/getarticle.php?kb_id=537
Codeproject has a good article on how to do this with .net:
http://www.codeproject.com/KB/cs/network.aspx
You could always create a console executable out of this, and call it from VBA.
RO
nbtstat -n might do the job on XP anyway. Not sure about other Windows versions or about localisation in other languages. Partial sample output:
C:\Documents and
Settings\colin>nbtstat -n
Local Area Connection: Node IpAddress:
[192.168.1.100] Scope Id: []
NetBIOS Local Name Table
etc.
Option Explicit
Sub Main()
Dim wsh As Object
Dim strIPOutputFile As String, strSingleLine As String, strIP As String, strToFind As String
Dim intSourceFile As Integer, intLocation As Integer
Set wsh = CreateObject("WScript.Shell")
strIPOutputFile = "C:\Users\MeMeMeMe\Desktop\txtfile.txt"
'Save ipconfig info to file
wsh.Run "%comspec% /c ipconfig/all> """ & strIPOutputFile & """
'Close any open text files
Close
'Get the number of the next free text file
intSourceFile = FreeFile
Open strIPOutputFile For Input As intSourceFile
strToFind = "IPv4 Address. . . . . . . . . . . :" 'This will probably depend on your file
Do Until EOF(intSourceFile)
Input #intSourceFile, strSingleLine
If InStr(1, strSingleLine, strToFind) > 0 Then
Exit Do
End If
Loop
intLocation = Len(strToFind)
strIP = Trim(Mid(strSingleLine,1 + intLocation,Len(strSingleLine) - intLocation))
intLocation = Len(strIP)
While Not IsNumeric(Mid(strIP,intLocation,1))
strIP = Left(strIP, Len(strIP) - 1)
intLocation = Len(strIP)
Wend
Close
MsgBox strIP
End Sub