ba5tz

ScreenShoot

Dec 1st, 2021
758
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Sub ShScreenShoot_Click()
  2. Dim Sht As Variant, Sh As Variant
  3. Dim sFolder As String
  4. Dim RnT As Range
  5.     With Application.FileDialog(msoFileDialogFolderPicker)
  6.         If .Show = -1 Then ' if OK
  7.             sFolder = .SelectedItems(1)
  8.         End If
  9.     End With
  10.    
  11.     If sFolder = "" Then Exit Sub
  12.    
  13.     Sht = Array("OM D0", "OM CO1", "OM CO2", "OM CO3" _
  14.                 , "D0(PE)", "CO1", "CO2", "CO3", "D0", _
  15.                 "CO1-", "CO2-", "CO3-", "TL", "OM")
  16.     For Each Sh In Sht
  17.         Set RnT = getRange(Sh)
  18.         BuatScreenShoot RnT, sFolder & "\Img" & Sh & ".jpg"
  19.     Next
  20. End Sub
  21.  
  22. Sub BuatScreenShoot(Rng As Range, Alamat As String)
  23. Dim i As Integer
  24. Dim intCount As Integer
  25. Dim objPic As Shape
  26. Dim objChart As Chart
  27. Call Rng.CopyPicture(xlScreen, xlPicture)
  28.  
  29. intCount = Sheets("Temp").Shapes.Count
  30. For i = 1 To intCount
  31.     Sheets("Temp").Shapes.Item(1).Delete
  32. Next i
  33.  
  34. With Sheets("Temp")
  35.     .Shapes.AddChart
  36.     .Activate
  37.     .Shapes.Item(1).Select
  38.     Set objChart = ActiveChart
  39.  
  40.     .Shapes.Item(1).Line.Visible = msoFalse
  41.     .Shapes.Item(1).Width = Rng.Width
  42.     .Shapes.Item(1).Height = Rng.Height
  43. End With
  44.  
  45. objChart.Paste
  46. Debug.Print Alamat
  47. objChart.Export (Alamat)
  48.  
  49. End Sub
  50.  
  51. Function getRange(Sh As Variant) As Range
  52. Dim brs As Long
  53. Dim Klm As Long
  54. Dim MaxKl As Long
  55. Dim Sht As Worksheet
  56.  
  57. Set Sht = Sheets(Sh)
  58. brs = Sht.Range("B" & Sht.Rows.Count).End(xlUp).Row
  59. For i = 1 To brs
  60.     Klm = Sht.Cells(i, Sht.Columns.Count).End(xlToLeft).Column
  61.     If MaxKl < Klm Then
  62.         MaxKl = Klm
  63.     End If
  64. Next i
  65.  
  66. Set getRange = Sht.Range(Sht.Cells(1, 1), Sht.Cells(brs, MaxKl))
  67.  
  68. End Function
RAW Paste Data