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