· 8 years ago · Feb 17, 2018, 10:12 AM
1'Created by: Daniel Dabrowski dabrowski.daniel@interia.pl
2'Please enjoy shearing.This macro has been tested on excel 2010,2013.
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'This version should automatically add all libraries.
10'
11'In order to use it please follow steps below.
12'
13'
14'1.Go to Tab Developer --> Macro Security on Excel Ribbon.
15'Be sure that "Trust Access to the VBA project object model" is checked.
16'
17'2.Copy all code e.g. to Module1
18'
19'3.Run first subroutine CompentsExistenceCheck only!.
20'
21'4.Go back to Excel. If code run properly, Sheet1 will be populated with four buttons and one checkbox.
22'As well B1 Cell will be populated with "Fill cell below with required" and B2 Cell borders will be in colour red.
23'
24
25'If Error appears you need to add below libraries manually.
26'In order to do it, click on Tools-->References
27'-Visual Basic For Applications
28'-Microsoft Excel 15.0 Object Library
29'-OLE Automation
30'-Microsoft Office 15.0 Object Library
31'-Microsoft Visual Basic for Applications Extensibility 5.3
32'-Microsoft Internet Controls
33'-Microsoft HTML Object Library
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}", 1, 0
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("L2").Font.Color = vbWhite
206 Sheet1.Range("Q1").Font.Color = vbWhite
207 Sheet1.Range("B2").BorderAround ColorIndex:=3
208 Sheet1.Range("B2").Value = "10047"
209 Sheet1.Range("G1").ColumnWidth = 3
210 Sheet1.Range("B1").ColumnWidth = 35
211 Sheet1.Range("J1").ColumnWidth = 3
212 Sheet1.Range("M1").ColumnWidth = 3
213 Sheet1.Range("P1").ColumnWidth = 3
214
215
216 End Sub
217
218
219
220
221Sub ComponentsLoading()
222
223 Dim btn As Button
224 Dim t As Range
225 Dim Obj1 As Object
226 Dim Obj2 As Object
227 Dim Obj3 As Object
228 Dim Obj4 As Object
229 Dim Obj5 As Object
230 Dim Code As String
231
232 Sheet1.Activate
233
234 Set t = ActiveSheet.Range("E1:F2")
235
236 Set Obj1 = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
237 Link:=False, DisplayAsIcon:=False, Left:=t.Left, Top:=t.Top, Width:=t.Width, Height:=t.Height)
238
239 Set t = ActiveSheet.Range("H1:I2")
240
241 Set Obj2 = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
242 Link:=False, DisplayAsIcon:=False, Left:=t.Left, Top:=t.Top, Width:=t.Width, Height:=t.Height)
243
244 Set t = ActiveSheet.Range("K1:L2")
245
246 Set Obj3 = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
247 Link:=False, DisplayAsIcon:=False, Left:=t.Left, Top:=t.Top, Width:=t.Width, Height:=t.Height)
248
249
250 Set t = ActiveSheet.Range("N1:O2")
251
252 Set Obj4 = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
253 Link:=False, DisplayAsIcon:=False, Left:=t.Left, Top:=t.Top, Width:=t.Width, Height:=t.Height)
254
255 Set t = ActiveSheet.Range("Q1:R2")
256
257 Set Obj5 = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1", _
258 Link:=False, DisplayAsIcon:=False, Left:=t.Left, Top:=t.Top, Width:=t.Width, Height:=t.Height)
259
260 ActiveSheet.OLEObjects(1).Object.Caption = "Search"
261 ActiveSheet.OLEObjects(2).Object.Caption = "Clear Search Output"
262 ActiveSheet.OLEObjects(3).Object.Caption = "Paste"
263 ActiveSheet.OLEObjects(4).Object.Caption = "Clear Search Input"
264 ActiveSheet.OLEObjects(5).Object.Caption = "Auto Search"
265
266 Call CreateEventProcedure1
267 Call CreateEventProcedure2
268 Call CreateEventProcedure3
269 Call CreateEventProcedureSelectionChange
270
271
272End Sub
273
274
275
276
277
278
279Sub CreateEventProcedure1()
280
281 Dim VBProj As VBIDE.VBProject
282 Dim VBComp As VBIDE.VBComponent
283 Dim CodeMod As VBIDE.CodeModule
284 Dim LineNum As Long
285
286
287 Set VBProj = ActiveWorkbook.VBProject
288 Set VBComp = VBProj.VBComponents("Sheet1")
289 Set CodeMod = VBComp.CodeModule
290
291 With CodeMod
292 LineNum = .CreateEventProc("Click", "CommandButton1")
293 LineNum = LineNum + 1
294
295 .InsertLines LineNum, ""
296 .InsertLines LineNum + 1, "Dim Val1 As String"
297 .InsertLines LineNum + 2, " "
298 .InsertLines LineNum + 3, "On Error Resume Next"
299 .InsertLines LineNum + 4, " "
300 .InsertLines LineNum + 5, vbTab & "Val1 = Range(""B2"").Value"
301 .InsertLines LineNum + 6, " "
302 .InsertLines LineNum + 7, " "
303 .InsertLines LineNum + 8, vbTab & "Call ClearContent"
304 .InsertLines LineNum + 9, " "
305 .InsertLines LineNum + 10, " "
306 .InsertLines LineNum + 11, " "
307 .InsertLines LineNum + 12, " If Val1 = """" Then"
308 .InsertLines LineNum + 13, " "
309 .InsertLines LineNum + 14, vbTab & "MsgBox ""Please fill cell with required number"", vbInformation," & """No Data"""
310 .InsertLines LineNum + 15, vbTab & "Range(""B2"").Select"
311 .InsertLines LineNum + 16, " "
312 .InsertLines LineNum + 17, " Else"
313 .InsertLines LineNum + 18, " "
314 .InsertLines LineNum + 19, vbTab & "Call ConnecToWeb(Val1)"
315 .InsertLines LineNum + 20, ""
316 .InsertLines LineNum + 21, "End if"
317
318
319 End With
320
321
322End Sub
323
324
325Sub CreateEventProcedure2()
326
327 Dim VBProj As VBIDE.VBProject
328 Dim VBComp As VBIDE.VBComponent
329 Dim CodeMod As VBIDE.CodeModule
330 Dim LineNum As Long
331
332
333 Set VBProj = ActiveWorkbook.VBProject
334 Set VBComp = VBProj.VBComponents("Sheet1")
335 Set CodeMod = VBComp.CodeModule
336
337 With CodeMod
338
339 LineNum = .CreateEventProc("Click", "CommandButton2")
340 LineNum = LineNum + 1
341 .InsertLines LineNum + 1, vbTab & "Call ClearContent"
342 .InsertLines LineNum + 2, " "
343 LineNum = LineNum + 1
344 LineNum = .CreateEventProc("Click", "CommandButton3")
345 .InsertLines LineNum + 1, " "
346 .InsertLines LineNum + 2, vbTab & "Call PastingFromTheClipboard"
347 LineNum = LineNum + 1
348 LineNum = .CreateEventProc("Click", "CommandButton4")
349 .InsertLines LineNum + 1, " "
350 .InsertLines LineNum + 2, vbTab & " Range(""B2"").Value = """
351
352 End With
353
354
355
356End Sub
357
358
359
360
361Sub CreateEventProcedure3()
362
363 Dim VBProj As VBIDE.VBProject
364 Dim VBComp As VBIDE.VBComponent
365 Dim CodeMod As VBIDE.CodeModule
366 Dim LineNum As Long
367
368
369 Set VBProj = ActiveWorkbook.VBProject
370 Set VBComp = VBProj.VBComponents("Sheet1")
371 Set CodeMod = VBComp.CodeModule
372
373
374 With CodeMod
375
376 LineNum = .CreateEventProc("Click", "CheckBox1")
377 LineNum = LineNum + 1
378 .InsertLines LineNum + 1, " If Range(""L2"").Value = 1 Then"
379 .InsertLines LineNum + 2, " "
380 .InsertLines LineNum + 3, vbTab & "Range(""L2"").Value = 0"
381 .InsertLines LineNum + 4, " "
382 .InsertLines LineNum + 5, " Else"
383 .InsertLines LineNum + 6, ""
384 .InsertLines LineNum + 7, vbTab & "Range(""L2"").Value = 1"
385 .InsertLines LineNum + 8, " "
386 .InsertLines LineNum + 9, " End if"
387 .InsertLines LineNum + 10, ""
388
389 End With
390
391
392End Sub
393
394
395
396Sub CreateEventProcedureSelectionChange()
397
398 Dim VBProj As VBIDE.VBProject
399 Dim VBComp As VBIDE.VBComponent
400 Dim CodeMod As VBIDE.CodeModule
401 Dim LineNum As Long
402
403
404 Set VBProj = ActiveWorkbook.VBProject
405 Set VBComp = VBProj.VBComponents("Sheet1")
406 Set CodeMod = VBComp.CodeModule
407
408
409 With CodeMod
410
411 LineNum = .CreateEventProc("SelectionChange", "Worksheet")
412 LineNum = LineNum + 1
413 .InsertLines LineNum + 1, " Dim r As Range"
414 .InsertLines LineNum + 2, " "
415 .InsertLines LineNum + 3, " If target.Cells.Count > 1 Then Exit Sub"
416 .InsertLines LineNum + 4, " "
417 .InsertLines LineNum + 5, " For Each r In target"
418 .InsertLines LineNum + 6, ""
419 .InsertLines LineNum + 7, vbTab & " If r.Address = ""$B$2"" Or r.Address = ""$B$3"" Then"
420 .InsertLines LineNum + 8, " "
421 .InsertLines LineNum + 9, " Call PastingFromTheClipboard"
422 .InsertLines LineNum + 10, ""
423 .InsertLines LineNum + 11, vbTab & " If Range(""L2"").Value = 0 Then"
424 .InsertLines LineNum + 12, vbTab & " Call CommandButton1_Click"
425 .InsertLines LineNum + 13, vbTab & " End if"
426 .InsertLines LineNum + 14, ""
427 .InsertLines LineNum + 15, " End if"
428 .InsertLines LineNum + 16, ""
429 .InsertLines LineNum + 17, " Next r"
430 .InsertLines LineNum + 18, ""
431
432 End With
433
434
435
436End Sub
437
438'///////////////////////////////////////////////////////////////////////////////
439'Main Module
440Sub ConnecToWeb(ByRef Val1 As String)
441
442
443 Dim IE As SHDocVw.InternetExplorer
444 Dim HTMLDoc As MSHTML.HTMLDocument
445 Dim HTMLButton As MSHTML.IHTMLElement, HTMLInput As MSHTML.IHTMLElement
446 Dim SearchCollection As MSHTML.IHTMLElementCollection
447 Dim SWs As SHDocVw.ShellWindows
448 Dim vIE As SHDocVw.InternetExplorer
449 Dim WebAdress As String, SearchCompound As String
450
451 SearchCompound = Val1
452
453 SearchCompound = SearchCompound
454 Set IE = New SHDocVw.InternetExplorer
455
456On Error GoTo ErrorHandler
457 '''''''''''''''''''''''''''''''''''''''''''''''
458 'Establish a connection to Webpage.
459 '''''''''''''''''''''''''''''''''''''''''''''''
460 IE.Visible = False
461 IE.Navigate "http://ec.europa.eu/growth/tools-databases/cosing/index.cfm?fuseaction=search.simple"
462
463
464 Do While IE.ReadyState <> READYSTATE_COMPLETE
465
466 Loop
467
468 '''''''''''''''''''''''''''''''''''''''''''''''
469 'Set HTML elements in order to fill appropriate fields.
470 'Then find and click a go button.
471 '''''''''''''''''''''''''''''''''''''''''''''''
472 Set HTMLDoc = IE.Document
473 Set SearchCollection = HTMLDoc.getElementsByClassName("button-normal")
474 Set HTMLInput = HTMLDoc.getElementById("search_simple_name")
475
476 HTMLInput.Value = SearchCompound
477
478 On Error GoTo 0
479
480 For Each HTMLButton In SearchCollection '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
481 'For each loop finds button in wepbage.Only way to reference to button
482 HTMLButton.Click 'is by html class.Fortunately in the website there is only one instance of this class
483 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
484 Next HTMLButton
485
486 Do While IE.ReadyState <> READYSTATE_COMPLETE
487 ' DoEvents
488 Loop
489
490 ''''''''''''''''''''''''''''''''''''''''''''''''
491 'Call subritine responsible for stop macro until
492 'a new webpage is fully loaded.
493 '''''''''''''''''''''''''''''''''''''''''''''''
494 Call PauseMessageBox
495
496
497 '''''''''''''''''''''''''''''''''''''''''''''''''
498 'Create a new HTML Document for a new webpage.
499 '''''''''''''''''''''''''''''''''''''''''''''''
500
501 Set HTMLDoc = Nothing
502 Set HTMLDoc = IE.Document
503
504 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
505 'This section browse through tables,rows,cells of HTML document
506 'in order to get required data.
507 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
508
509 Dim HTMLTable As MSHTML.IHTMLElement
510 Dim HTMLTables As MSHTML.IHTMLElementCollection
511 Dim HTMLRow As MSHTML.IHTMLElement
512 Dim HTMLCell As MSHTML.IHTMLElement
513 Dim HTMLNoResult As MSHTML.IHTMLElement
514 Dim HTMLNoResults As MSHTML.IHTMLElementCollection
515 Dim RowNum As Long, ColNum As Integer, RowCounter As Integer
516
517 RowCounter = 0
518
519 Sheet1.Activate
520 Range("A3").Activate
521
522
523 Set HTMLTables = HTMLDoc.getElementsByTagName("table")
524
525 Application.ScreenUpdating = False
526
527 For Each HTMLTable In HTMLTables
528
529 RowNum = 4
530
531 For Each HTMLRow In HTMLTable.getElementsByTagName("tr")
532 ' For Each HTMLRow In HTMLTables
533 RowCounter = RowCounter + 1
534
535 If RowCounter >= 5 Then
536
537 ' Debug.Print vbTab & HTMLRow.innerText
538 ColNum = 1
539 For Each HTMLCell In HTMLRow.Children
540 Cells(RowNum, ColNum) = HTMLCell.innerText
541 ColNum = ColNum + 1
542 Next HTMLCell
543 RowNum = RowNum + 1
544
545 End If
546
547
548 Next HTMLRow
549
550 Next HTMLTable
551
552 Application.ScreenUpdating = True
553 ' Set HTMLPage = Nothing
554
555
556 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
557 'Call subroutines reponsible for maintain worksheet and to close all IE instances.
558 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
559 Call clearTotal
560 Call CloseIE
561 Exit Sub
562''''''''''''''''''''''
563'Error Handler Section
564''''''''''''''''''''''
565ErrorHandler:
566
567 MsgBox "There is a IE connection problem?" & vbNewLine & "Please try again.", vbCritical
568 Exit Sub
569
570End Sub
571
572'///////////////////////////////////////////////////////////////////////////////////////
573'End of main module
574
575Sub PauseMessageBox()
576
577 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
578 ' This soubrutine run mesagbox. After one second messagebox will close automatically.
579 ' It stops macro and therefore helps load second website(containing required data) and create
580 ' a new HTML document.
581 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
582
583 Dim AckTime As Integer, InfoBox As Object
584
585
586 Set InfoBox = CreateObject("WScript.Shell")
587 AckTime = 1
588 Select Case InfoBox.Popup("Processing Hold On", _
589 1, "Browsing in progress", 0)
590
591 Case 1, -1
592 Exit Sub
593 End Select
594
595End Sub
596
597
598Sub clearTotal()
599
600 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
601 ' This subroutine shows "no result" message box if there is no relevant data.It is based on # sign.
602 ' Every table with results contains a # sign, therefore data without it, can be considered as irrelevant and
603 ' deleted. This code also erase record number data which can be consider as irrelevant for user as well.
604 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
605
606 Sheet1.Activate
607
608 If Range("A4").Value <> "#" Then
609
610 Range("A4", Range("A4").End(xlToRight)).Value = ""
611 MsgBox "No matching results found.", vbInformation, "No results"
612 Range("A4").Activate
613 Exit Sub
614
615 Else
616 Range("A4").End(xlDown).Value = ""
617 End If
618
619
620
621End Sub
622
623
624
625
626Public Sub CloseIE()
627 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
628 'Closing all instances of IE by Shell. For Each
629 'search through Shell instances and close only IE HTML like instances.
630 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
631 Dim Shell As Object
632 Dim IE As Object
633
634 Set Shell = CreateObject("Shell.Application")
635
636 For Each IE In Shell.Windows
637 If TypeName(IE.Document) = "HTMLDocument" Then
638 IE.Quit
639 End If
640 Next
641
642End Sub
643
644
645Sub ClearContent()
646
647 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
648 'Clear out data results from worksheet.
649 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
650
651 Sheet1.Activate
652
653 Range("A4", Range("A4").End(xlToRight).End(xlDown)).Delete
654
655End Sub
656
657
658'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
659'This module is for a copy data from a clipboard.It has been created to
660'faster work by copying CAS number automatically from clipboard to
661'specified cell in worksheet.It consists only one subroutine PastingFromTheClipboard.
662'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
663Public Sub PastingFromTheClipboard()
664
665 Dim MyDataObj As New DataObject
666 MyDataObj.GetFromClipboard
667
668On Error GoTo ErrorHandler
669 Dim MyVar As Variant
670 MyVar = MyDataObj.GetText
671 Range("B2").Value = MyVar
672 Exit Sub
673
674''''''''''''''''''''''
675'Error Hadler Section
676''''''''''''''''''''''
677
678ErrorHandler:
679 Exit Sub
680
681
682
683End Sub