Convert Excel file to KML file

 OPTION EXPLICIT '************************************************************************************************************* '************************************************************************************************************* 'VARIABLE AND CONSTANTS DECLARATION '************************************************************************************************************* '************************************************************************************************************* Public folders As New Collection Const FIRSTDATAROW = 13 'first active row Const LATITUDECOL = 26 'latitude column Const LONGITUDECOL = 27 'longitude column Const MARKERCOLORCOL = 30 'marker color Const MARKERSIZECOL = 31 'marker size Const MARKERIMAGECOL = 29 'marker image Const LABELCOLORCOL = 30 'label color Const LABELSIZECOL = 31 'label size Const NAMECOL = 1 'display type in google map Const DESCRIPTIONCOL = 28 'display description in google map Const FOLDERCOL = 3 'file creation in google map ' marker template Const PLACEMARKTEMPLATE = _ "<Placemark>%CR%" & _ " <description>%description%</description>%CR%" & _ " <name>%name%</name>%CR%" & _ " <Style>%CR%" & _ " <IconStyle><scale>1</scale></IconStyle>" & _ "%buttontemplate%" & _ "%labeltemplate%" & _ " </Style>%CR%" & _ " <visibility>1</visibility>%CR%" & _ " <Point>%CR%" & _ " <coordinates>%longitude%, %latitude%, 0</coordinates>%CR%" & _ " </Point>%CR%" & _ "</Placemark>%CR%%CR%" ' " <Icon><href>http://maps.google.com/mapfiles/kml/pal4/icon%buttonimage%.png</href></Icon>%CR%" & _ 'button template Const BUTTONTEMPLATE = _ " <IconStyle>%CR%" & _ "%buttoncolortemplate%" & _ "%buttonscaletemplate%" & _ " <Icon><href>http://maps.google.com/mapfiles/kml/pal4/icon%buttonimage%.png</href></Icon>%CR%" & _ " </IconStyle>%CR%" Const BUTTONCOLORTEMPLATE = " <color>%buttoncolor%</color>%CR%" Const BUTTONSCALETEMPLATE = " <scale>%buttonscale%</scale>%CR%" Const LABELTEMPLATE = " <LabelStyle>%labelcolortemplate%%labelscaletemplate%</LabelStyle>%CR%" Const LABELCOLORTEMPLATE = "<color>ff%labelcolor%</color>" Const LABELSCALETEMPLATE = "<scale>%labelscale%</scale>" 'KML output variables Dim s As String Dim name As String Dim description As String Dim markercolor As String Dim markerscale As String Dim markerimage As String Dim labelcolor As String Dim labelscale As String Dim latitude As String Dim longitude As String Dim folder As String Dim prevfolder As String Dim lastrow As Integer Dim sFileName As String '************************************************************************************************************************************************** '************************************************************************************************************************************************** 'KML FILE CREATION '************************************************************************************************************************************************** '************************************************************************************************************************************************** Sub OutputKML() 'Display the Open dialog box and assign the selected filename ' to the string variable 'sFileName' sFileName = Application.GetSaveAsFilename("test.kml", "KML Files (*.kml),*.kml", 1, "Where do you want to save your KML file?", "Save") ' If the user canceled If sFileName = "False" Then Exit Sub 'Call ConvertirNumerique Open CStr(sFileName) For Output As #1 ' to do for all folders prevfolder = "***BLANK***" Print #1, StartKML lastrow = LastDataRow For r = FIRSTDATAROW To lastrow name = CStr(ActiveSheet.Cells(r, NAMECOL)) description = CStr(ActiveSheet.Cells(r, DESCRIPTIONCOL)) markercolor = ActiveSheet.Cells(r, MARKERCOLORCOL) markerscale = ActiveSheet.Cells(r, MARKERSIZECOL) markerimage = ActiveSheet.Cells(r, MARKERIMAGECOL) labelcolor = ActiveSheet.Cells(r, LABELCOLORCOL) labelscale = ActiveSheet.Cells(r, LABELSIZECOL) folder = ActiveSheet.Cells(r, FOLDERCOL) latitude = ActiveSheet.Cells(r, LATITUDECOL) longitude = ActiveSheet.Cells(r, LONGITUDECOL) If folder <> prevfolder Then If prevfolder <> "***BLANK***" Then Print #1, EndFolder Print #1, StartFolder(folder) End If prevfolder = folder If latitude <> "" And latitude <> "not found" Then Print #1, KMLMakePlacemarkString(name, description, markerimage, markercolor, markerscale, labelcolor, labelscale, latitude, longitude) End If Next r Print #1, EndFolder Print #1, EndKML Close #1 'Shell (CStr([GoogleEarthExecutableLocation]) & " " & sFileName) End Sub '********************************************************************************************************************************************************************************* '********************************************************************************************************************************************************************************* 'FUNCTION FOR CREATING KML FILE '********************************************************************************************************************************************************************************* '********************************************************************************************************************************************************************************* '******************************************************************************************************* '******************************************************************************************************* 'HEADER FILE KML '******************************************************************************************************** '******************************************************************************************************** Function StartKML() As String StartKML = "<?xml version=""1.0"" encoding=""UTF-8""?>" & vbCrLf & _ "<kml xmlns=""http://earth.google.com/kml/2.0"">" & vbCrLf & "<Document>" & vbCrLf End Function '******************************************************************************************************* '******************************************************************************************************* 'END FILE KML '******************************************************************************************************** '******************************************************************************************************** Function EndKML() As String EndKML = "</Document>" & vbCrLf & "</kml>" & vbCrLf End Function '******************************************************************************************************* '******************************************************************************************************* 'START FILE KML '******************************************************************************************************** '******************************************************************************************************** Function StartFolder(folderName As String) As String StartFolder = " <Folder>" & vbCrLf & _ " <name>" & folderName & "</name>" & vbCrLf & _ " <visibility>1</visibility>" & vbCrLf & _ " <open>1</open>" & vbCrLf End Function '******************************************************************************************************* '******************************************************************************************************* 'END FILE KML '******************************************************************************************************** '******************************************************************************************************** Function EndFolder() As String EndFolder = " </Folder>" & vbCrLf End Function '******************************************************************************************************* '******************************************************************************************************* 'FILLING KML FILE '******************************************************************************************************** '******************************************************************************************************** Function KMLFromRow() r = ActiveCell.Row() Debug.Print KMLMakePlacemark(CStr(Cells(r, 10)), _ CStr(Cells(r, 11)), _ CStr(Cells(r, 9)), _ CStr(Cells(r, 6)), _ CStr(Cells(r, 7))) End Function '******************************************************************************************************* '******************************************************************************************************* 'KML TEMPLATE FILE '******************************************************************************************************** '******************************************************************************************************** Function template(templatestr As String, replacements As Collection) As String 'variable for template Dim findreplace Dim strFind As String Dim strReplace As String For Each findreplace In replacements strFind = findreplace(0) strReplace = findreplace(1) templatestr = Replace(templatestr, "%" & strFind & "%", strReplace) Next findreplace template = templatestr End Function '******************************************************************************************************* '******************************************************************************************************* 'KML MARKER TEMPLATE FILE '******************************************************************************************************** '******************************************************************************************************** Function KMLMakePlacemarkString(name As String, _ description As String, _ buttonimage As String, _ buttoncolor As String, _ buttonscale As String, _ labelcolor As String, _ labelscale As String, _ latitude As String, _ longitude As String) As String 'placemarker variables Dim repl As New Collection name = RegExValidate(name, "[a-zA-Z0-9-]") 'description = RegExValidate(description, "[a-zA-Z0-9,\(\)<>!\[\] ]") repl.Add Array("description", description) repl.Add Array("name", name) If buttonimage <> "" Then repl.Add Array("buttontemplate", BUTTONTEMPLATE) If buttoncolor <> "" Then repl.Add Array("buttoncolortemplate", BUTTONCOLORTEMPLATE) If buttonscale <> "" Then repl.Add Array("buttonscaletemplate", BUTTONSCALETEMPLATE) End If repl.Add Array("buttonimage", buttonimage) repl.Add Array("buttoncolor", buttoncolor) repl.Add Array("buttonscale", buttonscale) repl.Add Array("buttoncolortemplate", "") repl.Add Array("buttonscaletemplate", "") repl.Add Array("buttontemplate", "") If labelcolor <> "" Or labelscale <> "" Then repl.Add Array("labeltemplate", LABELTEMPLATE) If labelcolor <> "" Then repl.Add Array("labelcolortemplate", LABELCOLORTEMPLATE) If labelscale <> "" Then repl.Add Array("labelscaletemplate", LABELSCALETEMPLATE) End If repl.Add Array("labelcolor", labelcolor) repl.Add Array("labelscale", labelscale) repl.Add Array("labelcolortemplate", "") repl.Add Array("labelscaletemplate", "") repl.Add Array("labeltemplate", "") repl.Add Array("latitude", latitude) repl.Add Array("longitude", longitude) repl.Add Array("CR", vbCrLf) KMLMakePlacemarkString = template(PLACEMARKTEMPLATE, repl) End Function Private Function max(a, b): If a > b Then max = a Else max = b End If End Function '******************************************************************************************************* '******************************************************************************************************* 'LAST FILLED ROW OF TABLE FILTER '******************************************************************************************************** '******************************************************************************************************** ' finds the last row that contains an address Function LastDataRow() As Integer Dim r As Integer activecelladdr = ActiveCell.Address Range("i65536").End(xlUp).Select 'address r = ActiveCell.Row() Range("j65536").End(xlUp).Select 'postal code r = max(r, ActiveCell.Row()) Range("k65536").End(xlUp).Select 'city r = max(r, ActiveCell.Row()) Range(activecelladdr).Select LastDataRow = r End Function ' Returns a string containing only characters from the source ' that match the test items. ' ' For example: RegExValidate("chris gemignani","aeiou") returns "eiai" Public Function RegExValidate(ByRef Source As String, _ ByRef TEST As String) As String Dim s As String Dim regex As Object Set regex = CreateObject("vbscript.regexp") With regex .Pattern = TEST .Global = True End With Dim matches As Object Set matches = regex.Execute(Source) s = "" For Each m In matches s = s & m Next m RegExValidate = s End Function 

 ' This module defines a function that allows you to keep text data in the clipboard. 'function declarations Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) _ As Long Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) _ As Long Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, _ ByVal dwBytes As Long) As Long Declare Function CloseClipboard Lib "User32" () As Long Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) _ As Long Declare Function EmptyClipboard Lib "User32" () As Long Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _ ByVal lpString2 As Any) As Long Declare Function SetClipboardData Lib "User32" (ByVal wFormat _ As Long, ByVal hMem As Long) As Long 'constant declaration Public Const GHND = &H42 Public Const CF_TEXT = 1 Public Const MAXSIZE = 4096 'variable declaration Dim hGlobalMemory As Long Dim lpGlobalMemory As Long Dim hClipMemory As Long Dim x As Long Function ClipBoard_SetData(MyString As String) ' Allocate movable global memory. hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) ' Lock the block to get a pointer to this memory. lpGlobalMemory = GlobalLock(hGlobalMemory) ' Copy the string into this global memory. lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString) ' Unlock the memory. If GlobalUnlock(hGlobalMemory) <> 0 Then MsgBox "Unable to unlock the memory location. Copy interrupted. " GoTo OutOfHere2 End If ' Open the clipboard to copy the data. If OpenClipboard(0&) = 0 Then MsgBox "Unable to open the Clipboard. Copy interrupted." Exit Function End If ' Clear the clipboard. x = EmptyClipboard() ' Copy the data to the clipboard. hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) OutOfHere2: If CloseClipboard() = 0 Then MsgBox "Unable to close the clipboard." End If End Function 

 ' This module defines a function that allows you to keep text data in the clipboard. 'function declarations Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) _ As Long Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) _ As Long Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, _ ByVal dwBytes As Long) As Long Declare Function CloseClipboard Lib "User32" () As Long Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) _ As Long Declare Function EmptyClipboard Lib "User32" () As Long Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _ ByVal lpString2 As Any) As Long Declare Function SetClipboardData Lib "User32" (ByVal wFormat _ As Long, ByVal hMem As Long) As Long 'constant declaration Public Const GHND = &H42 Public Const CF_TEXT = 1 Public Const MAXSIZE = 4096 'variable declaration Dim hGlobalMemory As Long Dim lpGlobalMemory As Long Dim hClipMemory As Long Dim x As Long Function ClipBoard_SetData(MyString As String) ' Allocate movable global memory. hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) ' Lock the block to get a pointer to this memory. lpGlobalMemory = GlobalLock(hGlobalMemory) ' Copy the string into this global memory. lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString) ' Unlock the memory. If GlobalUnlock(hGlobalMemory) <> 0 Then MsgBox "Unable to unlock the memory location. Copy interrupted. " GoTo OutOfHere2 End If ' Open the clipboard to copy the data. If OpenClipboard(0&) = 0 Then MsgBox "Unable to open the Clipboard. Copy interrupted." Exit Function End If ' Clear the clipboard. x = EmptyClipboard() ' Copy the data to the clipboard. hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) OutOfHere2: If CloseClipboard() = 0 Then MsgBox "Unable to close the clipboard." End If End Function 

 OPTION EXPLICIT '************************************************************************************************************* '************************************************************************************************************* 'VARIABLE AND CONSTANTS DECLARATION '************************************************************************************************************* '************************************************************************************************************* Public folders As New Collection Const FIRSTDATAROW = 13 'first active row Const LATITUDECOL = 26 'latitude column Const LONGITUDECOL = 27 'longitude column Const MARKERCOLORCOL = 30 'marker color Const MARKERSIZECOL = 31 'marker size Const MARKERIMAGECOL = 29 'marker image Const LABELCOLORCOL = 30 'label color Const LABELSIZECOL = 31 'label size Const NAMECOL = 1 'display type in google map Const DESCRIPTIONCOL = 28 'display description in google map Const FOLDERCOL = 3 'create file in google map ' marker model Const PLACEMARKTEMPLATE = _ "<Placemark>%CR%" & _ " <description>%description%</description>%CR%" & _ " <name>%name%</name>%CR%" & _ " <Style>%CR%" & _ " <IconStyle><scale>1</scale></IconStyle>" & _ "%buttontemplate%" & _ "%labeltemplate%" & _ " </Style>%CR%" & _ " <visibility>1</visibility>%CR%" & _ " <Point>%CR%" & _ " <coordinates>%longitude%, %latitude%, 0</coordinates>%CR%" & _ " </Point>%CR%" & _ "</Placemark>%CR%%CR%" ' " <Icon><href>http://maps.google.com/mapfiles/kml/pal4/icon%buttonimage%.png</href></Icon>%CR%" & _ 'button model Const BUTTONTEMPLATE = _ " <IconStyle>%CR%" & _ "%buttoncolortemplate%" & _ "%buttonscaletemplate%" & _ " <Icon><href>http://maps.google.com/mapfiles/kml/pal4/icon%buttonimage%.png</href></Icon>%CR%" & _ " </IconStyle>%CR%" Const BUTTONCOLORTEMPLATE = " <color>%buttoncolor%</color>%CR%" Const BUTTONSCALETEMPLATE = " <scale>%buttonscale%</scale>%CR%" Const LABELTEMPLATE = " <LabelStyle>%labelcolortemplate%%labelscaletemplate%</LabelStyle>%CR%" Const LABELCOLORTEMPLATE = "<color>ff%labelcolor%</color>" Const LABELSCALETEMPLATE = "<scale>%labelscale%</scale>" 'KML output variables Dim s As String Dim name As String Dim description As String Dim markercolor As String Dim markerscale As String Dim markerimage As String Dim labelcolor As String Dim labelscale As String Dim latitude As String Dim longitude As String Dim folder As String Dim prevfolder As String Dim lastrow As Integer Dim sFileName As String '************************************************************************************************************************************************** '************************************************************************************************************************************************** 'KML FILE CREATION '************************************************************************************************************************************************** '************************************************************************************************************************************************** Sub OutputKML() 'Show the Open dialog box and set the selected file name 'to the string variable 'sFileName' sFileName = Application.GetSaveAsFilename("test.kml", "KML Files (*.kml),*.kml", 1, "Where do you want to save your KML file?", "Save") ' If the user canceled If sFileName = "False" Then Exit Sub 'Call ConvertirNumerique Open CStr(sFileName) For Output As #1 ' to do for all folders prevfolder = "***BLANK***" Print #1, StartKML lastrow = LastDataRow For r = FIRSTDATAROW To lastrow name = CStr(ActiveSheet.Cells(r, NAMECOL)) description = CStr(ActiveSheet.Cells(r, DESCRIPTIONCOL)) markercolor = ActiveSheet.Cells(r, MARKERCOLORCOL) markerscale = ActiveSheet.Cells(r, MARKERSIZECOL) markerimage = ActiveSheet.Cells(r, MARKERIMAGECOL) labelcolor = ActiveSheet.Cells(r, LABELCOLORCOL) labelscale = ActiveSheet.Cells(r, LABELSIZECOL) folder = ActiveSheet.Cells(r, FOLDERCOL) latitude = ActiveSheet.Cells(r, LATITUDECOL) longitude = ActiveSheet.Cells(r, LONGITUDECOL) If folder <> prevfolder Then If prevfolder <> "***BLANK***" Then Print #1, EndFolder Print #1, StartFolder(folder) End If prevfolder = folder If latitude <> "" And latitude <> "not found" Then Print #1, KMLMakePlacemarkString(name, description, markerimage, markercolor, markerscale, labelcolor, labelscale, latitude, longitude) End If Next r Print #1, EndFolder Print #1, EndKML Close #1 'Shell (CStr([GoogleEarthExecutableLocation]) & " " & sFileName) End Sub '********************************************************************************************************************************************************************************* '********************************************************************************************************************************************************************************* 'FUNCTION FOR CREATING KML FILE '********************************************************************************************************************************************************************************* '********************************************************************************************************************************************************************************* '******************************************************************************************************* '******************************************************************************************************* 'KML FILE HEADER '******************************************************************************************************** '******************************************************************************************************** Function StartKML() As String StartKML = "<?xml version=""1.0"" encoding=""UTF-8""?>" & vbCrLf & _ "<kml xmlns=""http://earth.google.com/kml/2.0"">" & vbCrLf & "<Document>" & vbCrLf End Function '******************************************************************************************************* '******************************************************************************************************* 'KML FILE END '******************************************************************************************************** '******************************************************************************************************** Function EndKML() As String EndKML = "</Document>" & vbCrLf & "</kml>" & vbCrLf End Function '******************************************************************************************************* '******************************************************************************************************* 'KML FILE START '******************************************************************************************************** '******************************************************************************************************** Function StartFolder(folderName As String) As String StartFolder = " <Folder>" & vbCrLf & _ " <name>" & folderName & "</name>" & vbCrLf & _ " <visibility>1</visibility>" & vbCrLf & _ " <open>1</open>" & vbCrLf End Function '******************************************************************************************************* '******************************************************************************************************* 'KML FILE END '******************************************************************************************************** '******************************************************************************************************** Function EndFolder() As String EndFolder = " </Folder>" & vbCrLf End Function '******************************************************************************************************* '******************************************************************************************************* 'KML FILLING FILE '******************************************************************************************************** '******************************************************************************************************** Function KMLFromRow() r = ActiveCell.Row() Debug.Print KMLMakePlacemark(CStr(Cells(r, 10)), _ CStr(Cells(r, 11)), _ CStr(Cells(r, 9)), _ CStr(Cells(r, 6)), _ CStr(Cells(r, 7))) End Function '******************************************************************************************************* '******************************************************************************************************* 'KML MODEL FILE '******************************************************************************************************** '******************************************************************************************************** Function template(templatestr As String, replacements As Collection) As String 'variable for model Dim findreplace Dim strFind As String Dim strReplace As String For Each findreplace In replacements strFind = findreplace(0) strReplace = findreplace(1) templatestr = Replace(templatestr, "%" & strFind & "%", strReplace) Next findreplace template = templatestr End Function '******************************************************************************************************* '******************************************************************************************************* 'KML MARKER MODEL FILE '******************************************************************************************************** '******************************************************************************************************** Function KMLMakePlacemarkString(name As String, _ description As String, _ buttonimage As String, _ buttoncolor As String, _ buttonscale As String, _ labelcolor As String, _ labelscale As String, _ latitude As String, _ longitude As String) As String 'placemarker variables Dim repl As New Collection name = RegExValidate(name, "[a-zA-Z0-9-]") 'description = RegExValidate(description, "[a-zA-Z0-9,\(\)<>!\[\] ]") repl.Add Array("description", description) repl.Add Array("name", name) If buttonimage <> "" Then repl.Add Array("buttontemplate", BUTTONTEMPLATE) If buttoncolor <> "" Then repl.Add Array("buttoncolortemplate", BUTTONCOLORTEMPLATE) If buttonscale <> "" Then repl.Add Array("buttonscaletemplate", BUTTONSCALETEMPLATE) End If repl.Add Array("buttonimage", buttonimage) repl.Add Array("buttoncolor", buttoncolor) repl.Add Array("buttonscale", buttonscale) repl.Add Array("buttoncolortemplate", "") repl.Add Array("buttonscaletemplate", "") repl.Add Array("buttontemplate", "") If labelcolor <> "" Or labelscale <> "" Then repl.Add Array("labeltemplate", LABELTEMPLATE) If labelcolor <> "" Then repl.Add Array("labelcolortemplate", LABELCOLORTEMPLATE) If labelscale <> "" Then repl.Add Array("labelscaletemplate", LABELSCALETEMPLATE) End If repl.Add Array("labelcolor", labelcolor) repl.Add Array("labelscale", labelscale) repl.Add Array("labelcolortemplate", "") repl.Add Array("labelscaletemplate", "") repl.Add Array("labeltemplate", "") repl.Add Array("latitude", latitude) repl.Add Array("longitude", longitude) repl.Add Array("CR", vbCrLf) KMLMakePlacemarkString = template(PLACEMARKTEMPLATE, repl) End Function Private Function max(a, b): If a > b Then max = a Else max = b End If End Function '******************************************************************************************************* '******************************************************************************************************* 'LAST FILLED LINE OF THE TABLE FILTERING '******************************************************************************************************** '******************************************************************************************************** ' searches for the last row containing an address Function LastDataRow() As Integer Dim r As Integer activecelladdr = ActiveCell.Address Range("i65536").End(xlUp).Select 'address r = ActiveCell.Row() Range("j65536").End(xlUp).Select 'postal code r = max(r, ActiveCell.Row()) Range("k65536").End(xlUp).Select 'city r = max(r, ActiveCell.Row()) Range(activecelladdr).Select LastDataRow = r End Function ' Returns a string containing only characters in the source ' that match the test elements. ' ' Example: RegExValidate("chris gemignani","aeiou") returns "eiai" Public Function RegExValidate(ByRef Source As String, _ ByRef TEST As String) As String Dim s As String Dim regex As Object Set regex = CreateObject("vbscript.regexp") With regex .Pattern = TEST .Global = True End With Dim matches As Object Set matches = regex.Execute(Source) s = "" For Each m In matches s = s & m Next m RegExValidate = s End Function 

 ' This module defines a function that allows you to keep text data in the clipboard. 'function declarations Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) _ As Long Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) _ As Long Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, _ ByVal dwBytes As Long) As Long Declare Function CloseClipboard Lib "User32" () As Long Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) _ As Long Declare Function EmptyClipboard Lib "User32" () As Long Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _ ByVal lpString2 As Any) As Long Declare Function SetClipboardData Lib "User32" (ByVal wFormat _ As Long, ByVal hMem As Long) As Long 'constant declarations Public Const GHND = &H42 Public Const CF_TEXT = 1 Public Const MAXSIZE = 4096 'variable declaration Dim hGlobalMemory As Long Dim lpGlobalMemory As Long Dim hClipMemory As Long Dim x As Long Function ClipBoard_SetData(MyString As String) ' Allocate global movable memory. hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) ' Lock the block to get a pointer to this memory. lpGlobalMemory = GlobalLock(hGlobalMemory) ' Copy the string into this global memory. lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString) ' Unlock the memory. If GlobalUnlock(hGlobalMemory) <> 0 Then MsgBox "Unable to unlock memory location. Copy interrupted. " GoTo OutOfHere2 End If ' Open the clipboard to copy data. If OpenClipboard(0&) = 0 Then MsgBox "Unable to open the Clipboard. Copy interrupted." Exit Function End If ' Clear clipboard. x = EmptyClipboard() ' Copy data to clipboard. hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) OutOfHere2: If CloseClipboard() = 0 Then MsgBox "Unable to close clipboard." End If End Function 

 ' This module defines a function that allows you to keep text data in the clipboard. 'function declarations Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) _ As Long Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) _ As Long Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, _ ByVal dwBytes As Long) As Long Declare Function CloseClipboard Lib "User32" () As Long Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) _ As Long Declare Function EmptyClipboard Lib "User32" () As Long Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _ ByVal lpString2 As Any) As Long Declare Function SetClipboardData Lib "User32" (ByVal wFormat _ As Long, ByVal hMem As Long) As Long 'constant declarations Public Const GHND = &H42 Public Const CF_TEXT = 1 Public Const MAXSIZE = 4096 'variable declaration Dim hGlobalMemory As Long Dim lpGlobalMemory As Long Dim hClipMemory As Long Dim x As Long Function ClipBoard_SetData(MyString As String) ' Allocate global movable memory. hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) ' Lock the block to get a pointer to this memory. lpGlobalMemory = GlobalLock(hGlobalMemory) ' Copy the string into this global memory. lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString) ' Unlock the memory. If GlobalUnlock(hGlobalMemory) <> 0 Then MsgBox "Unable to unlock memory location. Copy interrupted. " GoTo OutOfHere2 End If ' Open the clipboard to copy data. If OpenClipboard(0&) = 0 Then MsgBox "Unable to open the Clipboard. Copy interrupted." Exit Function End If ' Clear clipboard. x = EmptyClipboard() ' Copy data to clipboard. hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) OutOfHere2: If CloseClipboard() = 0 Then MsgBox "Unable to close clipboard." End If End Function