· 8 years ago · Feb 15, 2018, 10:06 PM
1'Created by: Daniel Dabrowski dabrowski.daniel@interia.pl
2'Please enjoy shearing.This macro has been tested on excel 2013,2016.
3'
4'--------------------------------------------------------------------------------------------------------------------------
5'!HOW TO RUN THIS MACRO?
6'
7'This macro automatically creates all ActiveX components and associated event procedures.
8'Please bear in mind this code will run properly only if Worksheet "Sheet1" exists.
9'Contrary to previous macro this one can add libraries automatically except Microsoft HTML Object Library.
10'
11'In order to use it please follow steps below.
12'1.Click on Tab Tools --> Reference on VBA Editor Ribbon.
13'Check below library.
14'-Microsoft HTML Object Library
15'
16'If Error appears you need to Check below libraries as well.
17'-Visual Basic For Applications
18'-Microsoft Excel 15.0 Object Library
19'-OLE Automation
20'-Microsoft Office 15.0 Object Library
21'-Microsoft Visual Basic for Applications Extensibility 5.3
22'-Microsoft Internet Controls
23'
24'2.Go to Tab Developer --> Macro Security on Excel Ribbon.
25'Be sure that "Trust Access to the VBA project object model" is checked.
26'
27'3.Copy all code e.g. to Module1
28'
29'4.Run first subroutine CompentsExistenceCheck only.
30'
31'5.Go back to Excel. If code run properly, Sheet1 will be populated with four buttons and one checkbox.
32'As well B1 Cell will be populated with "Fill cell below with required" and B2 Cell borders will be in colour red.
33'
34'----------------------------------------------------------------------------------------------------------------------------
35'----------------------------------------------------------------------------------------------------------------------------
36'!WHAT IS THIS MACRO FOR?
37'
38'
39'This macro has been created in order to make browse for CAS number easier.
40'User(Customer) can browse specified website(http://ec.europa.eu/growth/tools-databases/cosing/index.cfm?fuseaction=search.simple)
41'by using Excel. Afterwards data is retrieved from website and put into "Sheet1". CAS number referred to a unique numerical
42'identifier for chemical compound or substance.This macro required Internet Explorer, please bear in mind that in some
43'cases search can take a little bit longer. It depends on how fast is your internet download speed.
44'
45'
46'----------------------------------------------------------------------------------------------------------------------------
47'----------------------------------------------------------------------------------------------------------------------------
48'
49'!HOW TO USE THIS MACRO?
50'
51'
52'Populate "search cell"(red frame) with appropriate CAS number. Please try exemplary one's like
53'1004791-75-6, 7790-76-3, 103-90-2, 10047. Click on "Search" button, if required number is in database
54'relavant data will populate worksheet.
55'
56'Other Buttons descreption:
57'
58'"Clear Search Output" - Clear up results from worksheets
59'"Paste" - You can put into search cell previously copied data from clipboard by clicking this button.
60'"Clear Search Input" - Clear up "search cell"
61'"Auto Search" - If this button is clicked there is no need to press Search Button. Macro will automatically
62'populate this cell with data from clipboard.
63'
64'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
65
66'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
67'CAUTION: Many virus scanners may automatically and without warning or confirmation delete modules
68'that reference the VBProject object, causing a permanent and irretrievable loss of code.
69'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
70Sub CompentsExistenceCheck()
71
72 Dim shp As Shape
73
74 On Error Resume Next 'incase shape does not exist
75
76 Set shp = Sheets("Sheet1").Shapes("CommandButton1")
77
78 Call AddReferenceMicrosoftInternetControls
79 Call AddReferenceMicrosoftOfficeObjectLibrary
80 Call AddReferenceOLEAutomation
81 Call AddReferenceMicrosoftMicrosoftHTMLObjectLibrary
82 Call AddReferenceToMicrosoftVisualBasicforApplicationsExtensibility
83 Call AddReferenceMicrosoftMicrosoftHTMLObjectLibrary
84 Call AddReferenceVisualBasicforApplications
85
86
87 If shp Is Nothing Then
88
89 Call ComponentsLoading
90 Call InputCellCreate
91
92 Else
93
94 Exit Sub
95
96 End If
97
98 Set shp = Nothing
99
100 Call InputCellCreate
101
102
103End Sub
104
105
106
107
108Private Sub AddReferenceVisualBasicforApplications()
109
110 Dim Reference As Object
111 With ThisWorkbook.VBProject
112 For Each Reference In .References
113 If Reference.Description Like "Visual Basic for Applications*" Then Exit Sub
114 Next
115 .References.AddFromGuid "{000204EF-0000-0000-C000-000000000046}", 7, 1
116 End With
117
118End Sub
119
120
121Private Sub AddReferenceMicrosoftExcelObjectLibrary()
122
123 Dim Reference As Object
124 With ThisWorkbook.VBProject
125 For Each Reference In .References
126 If Reference.Description Like "Microsoft Excel 15.0 Object Library*" Then Exit Sub
127 Next
128 .References.AddFromGuid "{00020813-0000-0000-C000-000000000046}", 15, 0
129 End With
130
131End Sub
132
133
134Private Sub AddReferenceOLEAutomation()
135
136 Dim Reference As Object
137 With ThisWorkbook.VBProject
138 For Each Reference In .References
139 If Reference.Description Like "OLE Automation*" Then Exit Sub
140 Next
141 .References.AddFromGuid "{00020430-0000-0000-C000-000000000046}", 1, 0
142 End With
143
144End Sub
145
146Private Sub AddReferenceMicrosoftOfficeObjectLibrary()
147
148 Dim Reference As Object
149 With ThisWorkbook.VBProject
150 For Each Reference In .References
151 If Reference.Description Like "Microsoft Office 15.0 Object Library*" Then Exit Sub
152 Next
153 .References.AddFromGuid "{2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}", 15, 0
154 End With
155
156End Sub
157
158
159Private Sub AddReferenceMicrosoftMicrosoftHTMLObjectLibrary()
160
161 Dim Reference As Object
162 With ThisWorkbook.VBProject
163 For Each Reference In .References
164 If Reference.Description Like "Microsoft HTML Object Library*" Then Exit Sub
165 Next
166 .References.AddFromGuid "{3050F1C5-98B5-11CF-BB82-00AA00BDCE0B}", 5, 5
167 End With
168
169End Sub
170
171Private Sub AddReferenceMicrosoftInternetControls()
172
173 Dim Reference As Object
174 With ThisWorkbook.VBProject
175 For Each Reference In .References
176 If Reference.Description Like "Microsoft Internet Controls*" Then Exit Sub
177 Next
178 .References.AddFromGuid "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}", 1, 0
179 End With
180
181End Sub
182
183Private Sub AddReferenceToMicrosoftVisualBasicforApplicationsExtensibility()
184
185 Dim Reference As Object
186 With ThisWorkbook.VBProject
187 For Each Reference In .References
188 If Reference.Description Like "Microsoft Visual Basic for Applications Extensibility*" Then Exit Sub
189 Next
190 .References.AddFromGuid "{0002E157-0000-0000-C000-000000000046}", 5, 3
191 End With
192
193End Sub
194
195
196
197
198
199
200 Sub InputCellCreate()
201
202 Sheet1.Range("B1").Value = "Fill cell below with required number"
203 Sheet1.Range("B1").Font.Bold = True
204 Sheet1.Range("L2").Value = 1
205 Sheet1.Range("Q1").Font.Color = vbWhite
206 Sheet1.Range("B2").BorderAround ColorIndex:=3
207 Sheet1.Range("B2").Value = "10047"
208 Sheet1.Range("G1").ColumnWidth = 3
209 Sheet1.Range("B1").ColumnWidth = 35
210 Sheet1.Range("J1").ColumnWidth = 3
211 Sheet1.Range("M1").ColumnWidth = 3
212 Sheet1.Range("P1").ColumnWidth = 3
213
214
215 End Sub
216
217
218
219
220Sub ComponentsLoading()
221
222 Dim btn As Button
223 Dim t As Range
224 Dim Obj1 As Object
225 Dim Obj2 As Object
226 Dim Obj3 As Object
227 Dim Obj4 As Object
228 Dim Obj5 As Object
229 Dim Code As String
230
231 Sheet1.Activate
232
233 Set t = ActiveSheet.Range("E1:F2")
234
235 Set Obj1 = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
236 Link:=False, DisplayAsIcon:=False, Left:=t.Left, Top:=t.Top, Width:=t.Width, Height:=t.Height)
237
238 Set t = ActiveSheet.Range("H1:I2")
239
240 Set Obj2 = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
241 Link:=False, DisplayAsIcon:=False, Left:=t.Left, Top:=t.Top, Width:=t.Width, Height:=t.Height)
242
243 Set t = ActiveSheet.Range("K1:L2")
244
245 Set Obj3 = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
246 Link:=False, DisplayAsIcon:=False, Left:=t.Left, Top:=t.Top, Width:=t.Width, Height:=t.Height)
247
248
249 Set t = ActiveSheet.Range("N1:O2")
250
251 Set Obj4 = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
252 Link:=False, DisplayAsIcon:=False, Left:=t.Left, Top:=t.Top, Width:=t.Width, Height:=t.Height)
253
254 Set t = ActiveSheet.Range("Q1:R2")
255
256 Set Obj5 = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1", _
257 Link:=False, DisplayAsIcon:=False, Left:=t.Left, Top:=t.Top, Width:=t.Width, Height:=t.Height)
258
259 ActiveSheet.OLEObjects(1).Object.Caption = "Search"
260 ActiveSheet.OLEObjects(2).Object.Caption = "Clear Search Output"
261 ActiveSheet.OLEObjects(3).Object.Caption = "Paste"
262 ActiveSheet.OLEObjects(4).Object.Caption = "Clear Search Input"
263 ActiveSheet.OLEObjects(5).Object.Caption = "Auto Search"
264
265 Call CreateEventProcedure1
266 Call CreateEventProcedure2
267 Call CreateEventProcedure3
268 Call CreateEventProcedureSelectionChange
269
270
271End Sub
272
273
274
275
276
277
278Sub CreateEventProcedure1()
279
280 Dim VBProj As VBIDE.VBProject
281 Dim VBComp As VBIDE.VBComponent
282 Dim CodeMod As VBIDE.CodeModule
283 Dim LineNum As Long
284
285
286 Set VBProj = ActiveWorkbook.VBProject
287 Set VBComp = VBProj.VBComponents("Sheet1")
288 Set CodeMod = VBComp.CodeModule
289
290 With CodeMod
291 LineNum = .CreateEventProc("Click", "CommandButton1")
292 LineNum = LineNum + 1
293
294 .InsertLines LineNum, ""
295 .InsertLines LineNum + 1, "Dim Val1 As String"
296 .InsertLines LineNum + 2, " "
297 .InsertLines LineNum + 3, "On Error Resume Next"
298 .InsertLines LineNum + 4, " "
299 .InsertLines LineNum + 5, vbTab & "Val1 = Range(""B2"").Value"
300 .InsertLines LineNum + 6, " "
301 .InsertLines LineNum + 7, " "
302 .InsertLines LineNum + 8, vbTab & "Call ClearContent"
303 .InsertLines LineNum + 9, " "
304 .InsertLines LineNum + 10, " "
305 .InsertLines LineNum + 11, " "
306 .InsertLines LineNum + 12, " If Val1 = """" Then"
307 .InsertLines LineNum + 13, " "
308 .InsertLines LineNum + 14, vbTab & "MsgBox ""Please fill cell with required number"", vbInformation," & """No Data"""
309 .InsertLines LineNum + 15, vbTab & "Range(""B2"").Select"
310 .InsertLines LineNum + 16, " "
311 .InsertLines LineNum + 17, " Else"
312 .InsertLines LineNum + 18, " "
313 .InsertLines LineNum + 19, vbTab & "Call ConnecToWeb(Val1)"
314 .InsertLines LineNum + 20, ""
315 .InsertLines LineNum + 21, "End if"
316
317
318 End With
319
320
321End Sub
322
323
324Sub CreateEventProcedure2()
325
326 Dim VBProj As VBIDE.VBProject
327 Dim VBComp As VBIDE.VBComponent
328 Dim CodeMod As VBIDE.CodeModule
329 Dim LineNum As Long
330
331
332 Set VBProj = ActiveWorkbook.VBProject
333 Set VBComp = VBProj.VBComponents("Sheet1")
334 Set CodeMod = VBComp.CodeModule
335
336 With CodeMod
337
338 LineNum = .CreateEventProc("Click", "CommandButton2")
339 LineNum = LineNum + 1
340 .InsertLines LineNum + 1, vbTab & "Call ClearContent"
341 .InsertLines LineNum + 2, " "
342 LineNum = LineNum + 1
343 LineNum = .CreateEventProc("Click", "CommandButton3")
344 .InsertLines LineNum + 1, " "
345 .InsertLines LineNum + 2, vbTab & "Call PastingFromTheClipboard"
346 LineNum = LineNum + 1
347 LineNum = .CreateEventProc("Click", "CommandButton4")
348 .InsertLines LineNum + 1, " "
349 .InsertLines LineNum + 2, vbTab & " Range(""B2"").Value = """
350
351 End With
352
353
354
355End Sub
356
357
358
359
360Sub CreateEventProcedure3()
361
362 Dim VBProj As VBIDE.VBProject
363 Dim VBComp As VBIDE.VBComponent
364 Dim CodeMod As VBIDE.CodeModule
365 Dim LineNum As Long
366
367
368 Set VBProj = ActiveWorkbook.VBProject
369 Set VBComp = VBProj.VBComponents("Sheet1")
370 Set CodeMod = VBComp.CodeModule
371
372
373 With CodeMod
374
375 LineNum = .CreateEventProc("Click", "CheckBox1")
376 LineNum = LineNum + 1
377 .InsertLines LineNum + 1, " If Range(""L2"").Value = 1 Then"
378 .InsertLines LineNum + 2, " "
379 .InsertLines LineNum + 3, vbTab & "Range(""L2"").Value = 0"
380 .InsertLines LineNum + 4, " "
381 .InsertLines LineNum + 5, " Else"
382 .InsertLines LineNum + 6, ""
383 .InsertLines LineNum + 7, vbTab & "Range(""L2"").Value = 1"
384 .InsertLines LineNum + 8, " "
385 .InsertLines LineNum + 9, " End if"
386 .InsertLines LineNum + 10, ""
387
388 End With
389
390
391End Sub
392
393
394
395Sub CreateEventProcedureSelectionChange()
396
397 Dim VBProj As VBIDE.VBProject
398 Dim VBComp As VBIDE.VBComponent
399 Dim CodeMod As VBIDE.CodeModule
400 Dim LineNum As Long
401
402
403 Set VBProj = ActiveWorkbook.VBProject
404 Set VBComp = VBProj.VBComponents("Sheet1")
405 Set CodeMod = VBComp.CodeModule
406
407
408 With CodeMod
409
410 LineNum = .CreateEventProc("SelectionChange", "Worksheet")
411 LineNum = LineNum + 1
412 .InsertLines LineNum + 1, " Dim r As Range"
413 .InsertLines LineNum + 2, " "
414 .InsertLines LineNum + 3, " If target.Cells.Count > 1 Then Exit Sub"
415 .InsertLines LineNum + 4, " "
416 .InsertLines LineNum + 5, " For Each r In target"
417 .InsertLines LineNum + 6, ""
418 .InsertLines LineNum + 7, vbTab & " If r.Address = ""$B$2"" Or r.Address = ""$B$3"" Then"
419 .InsertLines LineNum + 8, " "
420 .InsertLines LineNum + 9, " Call PastingFromTheClipboard"
421 .InsertLines LineNum + 10, ""
422 .InsertLines LineNum + 11, vbTab & " If Range(""L2"").Value = 0 Then"
423 .InsertLines LineNum + 12, vbTab & " Call CommandButton1_Click"
424 .InsertLines LineNum + 13, vbTab & " End if"
425 .InsertLines LineNum + 14, ""
426 .InsertLines LineNum + 15, " End if"
427 .InsertLines LineNum + 16, ""
428 .InsertLines LineNum + 17, " Next r"
429 .InsertLines LineNum + 18, ""
430
431 End With
432
433
434
435End Sub
436
437'///////////////////////////////////////////////////////////////////////////////
438'Main Module
439Sub ConnecToWeb(ByRef Val1 As String)
440
441
442 Dim IE As SHDocVw.InternetExplorer
443 Dim HTMLDoc As MSHTML.HTMLDocument
444 Dim HTMLButton As MSHTML.IHTMLElement, HTMLInput As MSHTML.IHTMLElement
445 Dim SearchCollection As MSHTML.IHTMLElementCollection
446 Dim SWs As SHDocVw.ShellWindows
447 Dim vIE As SHDocVw.InternetExplorer
448 Dim WebAdress As String, SearchCompound As String
449
450 SearchCompound = Val1
451
452 SearchCompound = SearchCompound
453 Set IE = New SHDocVw.InternetExplorer
454
455On Error GoTo ErrorHandler
456 '''''''''''''''''''''''''''''''''''''''''''''''
457 'Establish a connection to Webpage.
458 '''''''''''''''''''''''''''''''''''''''''''''''
459 IE.Visible = False
460 IE.Navigate "http://ec.europa.eu/growth/tools-databases/cosing/index.cfm?fuseaction=search.simple"
461
462
463 Do While IE.ReadyState <> READYSTATE_COMPLETE
464
465 Loop
466
467 '''''''''''''''''''''''''''''''''''''''''''''''
468 'Set HTML elements in order to fill appropriate fields.
469 'Then find and click a go button.
470 '''''''''''''''''''''''''''''''''''''''''''''''
471 Set HTMLDoc = IE.Document
472 Set SearchCollection = HTMLDoc.getElementsByClassName("button-normal")
473 Set HTMLInput = HTMLDoc.getElementById("search_simple_name")
474
475 HTMLInput.Value = SearchCompound
476
477 On Error GoTo 0
478
479 For Each HTMLButton In SearchCollection '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
480 'For each loop finds button in wepbage.Only way to reference to button
481 HTMLButton.Click 'is by html class.Fortunately in the website there is only one instance of this class
482 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
483 Next HTMLButton
484
485 Do While IE.ReadyState <> READYSTATE_COMPLETE
486 ' DoEvents
487 Loop
488
489 ''''''''''''''''''''''''''''''''''''''''''''''''
490 'Call subritine responsible for stop macro until
491 'a new webpage is fully loaded.
492 '''''''''''''''''''''''''''''''''''''''''''''''
493 Call PauseMessageBox
494
495
496 '''''''''''''''''''''''''''''''''''''''''''''''''
497 'Create a new HTML Document for a new webpage.
498 '''''''''''''''''''''''''''''''''''''''''''''''
499
500 Set HTMLDoc = Nothing
501 Set HTMLDoc = IE.Document
502
503 ''''''''''''''''''''''''''''''''''''''''''''''''''
504 'Call subroutine responsible for retrive data.
505 ''''''''''''''''''''''''''''''''''''''''''''''''''
506 ProcessHTMLPage HTMLDoc
507
508 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
509 'Call subroutines reponsible for maintain worksheet and to close all IE instances.
510 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
511 Call clearTotal
512 Call CloseIE
513 Exit Sub
514''''''''''''''''''''''
515'Error Handler Section
516''''''''''''''''''''''
517ErrorHandler:
518
519 MsgBox "There is a IE connection problem?" & vbNewLine & "Please try again.", vbCritical
520 Exit Sub
521
522End Sub
523
524
525
526
527
528Sub ProcessHTMLPage(HTMLPage As MSHTML.HTMLDocument)
529
530 Dim HTMLTable As MSHTML.IHTMLElement
531 Dim HTMLTables As MSHTML.IHTMLElementCollection
532 Dim HTMLRow As MSHTML.IHTMLElement
533 Dim HTMLCell As MSHTML.IHTMLElement
534 Dim HTMLNoResult As MSHTML.IHTMLElement
535 Dim HTMLNoResults As MSHTML.IHTMLElementCollection
536 Dim RowNum As Long, ColNum As Integer, RowCounter As Integer
537
538 RowCounter = 0
539
540 Sheet1.Activate
541 Range("A3").Activate
542
543 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
544 'This section browse through tables,rows,cells of HTML document
545 'in order to get required data.
546 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
547
548 Set HTMLTables = HTMLPage.getElementsByTagName("table")
549
550 Application.ScreenUpdating = False
551
552 For Each HTMLTable In HTMLTables
553
554 RowNum = 4
555
556 For Each HTMLRow In HTMLTable.getElementsByTagName("tr")
557 ' For Each HTMLRow In HTMLTables
558 RowCounter = RowCounter + 1
559
560 If RowCounter >= 5 Then
561
562 ' Debug.Print vbTab & HTMLRow.innerText
563 ColNum = 1
564 For Each HTMLCell In HTMLRow.Children
565 Cells(RowNum, ColNum) = HTMLCell.innerText
566 ColNum = ColNum + 1
567 Next HTMLCell
568 RowNum = RowNum + 1
569
570 End If
571
572
573 Next HTMLRow
574
575 Next HTMLTable
576
577 Application.ScreenUpdating = True
578 ' Set HTMLPage = Nothing
579
580End Sub
581
582
583'///////////////////////////////////////////////////////////////////////////////////////
584'End of main module
585
586Sub PauseMessageBox()
587
588 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
589 ' This soubrutine run mesagbox. After one second messagebox will close automatically.
590 ' It stops macro and therefore helps load second website(containing required data) and create
591 ' a new HTML document.
592 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
593
594 Dim AckTime As Integer, InfoBox As Object
595
596
597 Set InfoBox = CreateObject("WScript.Shell")
598 AckTime = 1
599 Select Case InfoBox.Popup("Processing Hold On", _
600 1, "Browsing in progress", 0)
601
602 Case 1, -1
603 Exit Sub
604 End Select
605
606End Sub
607
608
609Sub clearTotal()
610
611 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
612 ' This subroutine shows "no result" message box if there is no relevant data.It is based on # sign.
613 ' Every table with results contains a # sign, therefore data without it, can be considered as irrelevant and
614 ' deleted. This code also erase record number data which can be consider as irrelevant for user as well.
615 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
616
617 Sheet1.Activate
618
619 If Range("A4").Value <> "#" Then
620
621 Range("A4", Range("A4").End(xlToRight)).Value = ""
622 MsgBox "No matching results found.", vbInformation, "No results"
623 Range("A4").Activate
624 Exit Sub
625
626 Else
627 Range("A4").End(xlDown).Value = ""
628 End If
629
630
631
632End Sub
633
634
635
636
637Public Sub CloseIE()
638 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
639 'Closing all instances of IE by Shell. For Each
640 'search through Shell instances and close only IE HTML like instances.
641 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
642 Dim Shell As Object
643 Dim IE As Object
644
645 Set Shell = CreateObject("Shell.Application")
646
647 For Each IE In Shell.Windows
648 If TypeName(IE.Document) = "HTMLDocument" Then
649 IE.Quit
650 End If
651 Next
652
653End Sub
654
655
656Sub ClearContent()
657
658 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
659 'Clear out data results from worksheet.
660 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
661
662 Sheet1.Activate
663
664 Range("A4", Range("A4").End(xlToRight).End(xlDown)).Delete
665
666End Sub
667
668
669'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
670'This module is for a copy data from a clipboard.It has been created to
671'faster work by copying CAS number automatically from clipboard to
672'specified cell in worksheet.It consists only one subroutine PastingFromTheClipboard.
673'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
674Public Sub PastingFromTheClipboard()
675
676 Dim MyDataObj As New DataObject
677 MyDataObj.GetFromClipboard
678
679On Error GoTo ErrorHandler
680 Dim MyVar As Variant
681 MyVar = MyDataObj.GetText
682 Range("B2").Value = MyVar
683 Exit Sub
684
685''''''''''''''''''''''
686'Error Hadler Section
687''''''''''''''''''''''
688
689ErrorHandler:
690 Exit Sub
691
692
693
694End Sub