Log In
Register
Home
June 26, 2016
Offline
Hi everyone, my name is Maurizio and my new problem is this:
(I state)
Che: I would like to work exclusively with L'userform without having to go through excel!
Having said that: on a Userform I have inserted a label which as Caption has as its receiver a Link taken from a website which is this ("https://www.meteolive.it/resources/images_for_css/icone-previsioni/sunny. png ")
The image is inherent in a Weather Forecast Image which works very well at the Excel sheet level; But not at the level of (Userform)?
Therefore my question is this:
1) Is there a way to insert in the Folder (Temp) such image that has as Extension (Png)
2) Turn it into (jpg)
3) Recall it from the Folder (Temp)
4) And have it displayed in the userform (Image2)?
Thanks to All those who want to give me a hand about Greetings from Maurizio
February 20, 2020
Offline
Hello,
the following codes are just one solution, but need a sheet and more...
Put the following in a module:
Public Sub download_Image_from_Label_Caption() ' download from url to folder
Dim imgName As String
Dim urlName As String
Dim UrlHttp As Object
Dim objStream As Object
Dim CurrentFolder As String
If Folder_Download_Img_From_Url = "Error" Then ' folder exist ?
MsgBox "• Access denied:" & Chr(10) & Chr(10) & "• Unable to locate or create destination folder!", vbCritical, "Critical error"
Exit Sub
End If
CurrentFolder = Folder_Download_Img_From_Url & "\"
imgName = "MyMeteoImg" ' you can change the name
urlName = UserForm1.Label1.Caption ' change to your userform name & your label name
Set UrlHttp = CreateObject("MSXML2.XMLHTTP.6.0")
Set objStream = CreateObject("ADODB.Stream")
adTypeBinary = 1
objStream.Type = adTypeBinary
sPath = CurrentFolder & imgName & ".jpg"
sURI = urlName
On Error GoTo UrlError
UrlHttp.Open "GET", sURI, False
UrlHttp.send
aBytes = UrlHttp.responseBody
On Error GoTo 0
objStream.Open
objStream.Write aBytes
adSaveCreateOverWrite = 2
objStream.SaveToFile sPath, adSaveCreateOverWrite
objStream.Close
' MsgBox "sucefull"
ExitSub:
If Not UrlHttp Is Nothing Then Set UrlHttp = Nothing
If Not objStream Is Nothing Then Set objStream = Nothing
Exit Sub
UrlError:
MsgBox "• An error has occurred", vbCritical, "Error"
Resume ExitSub
End Sub
Public Function Folder_Download_Img_From_Url() As String ' determine if folder exists ? if not create one if is possible
Dim WshShell As Object
Dim fso As Object
Dim SpecialPath As String
Set WshShell = CreateObject("WScript.Shell")
Set fso = CreateObject("scripting.filesystemobject")
SpecialPath = ThisWorkbook.Path
If Right(SpecialPath, 1) <> "\" Then
SpecialPath = SpecialPath & "\"
End If
If fso.FolderExists(SpecialPath & "DownloadPictures") = False Then
On Error Resume Next
MkDir SpecialPath & "DownloadPictures"
On Error GoTo 0
End If
If fso.FolderExists(SpecialPath & "DownloadPictures") = True Then
Folder_Download_Img_From_Url = SpecialPath & "DownloadPictures"
Else
Folder_Download_Img_From_Url = "Error"
End If
End Function
Public Function PauseInEvent(ByVal Delay As Double) ' WAIT A MOMENT WITH LOOP
Dim TheEndOfTime As Double
TheEndOfTime = Timer + Delay
Do While Timer < TheEndOfTime
DoEvents
Loop
End Function
put in the userform module:
Private Sub CommandButton1_Click()
Call download_Image_from_Label_Caption
PauseInEvent (0.01) ' (MACRO) to make a pause ' you can change the pause value (this is to prevent PC delays or errors)
Call AddPicture
PauseInEvent (0.01) ' (MACRO) to make a pause ' you can change the pause value (this is to prevent PC delays or errors)
Call UploadPicture
End Sub
Private Sub AddPicture() ' ADD PICTURE FROM PC FOLDER TO SHEET RANGE
Dim ws As Worksheet
Dim imagePath As String
Dim imgLeft As Double
Dim imgTop As Double
Dim shp As Shape
Dim CurrentFolder As String
Dim newSheetName As String
Dim checkSheetName As String
newSheetName = "Folha1" ' change sheet name
'you can remove this part of creating an excel sheet and indicate an excel sheet
On Error Resume Next
checkSheetName = Worksheets(newSheetName).Name
If checkSheetName = "" Then
Worksheets.Add.Name = newSheetName
End If
On Error GoTo 0
If Folder_Download_Img_From_Url = "Error" Then ' folder exist ? ' you can remove this part and add folder path
MsgBox "• Access denied:" & Chr(10) & Chr(10) & "• Unable to locate or create destination folder!", vbCritical, "Critical error"
Exit Sub
End If
CurrentFolder = Folder_Download_Img_From_Url & "\"
Set ws = ActiveSheet
Range("A10").Select ' change range if you want
On Error GoTo NoLocalizado:
imagePath = CurrentFolder & "MyMeteoImg.jpg"
imgLeft = ActiveCell.Left
imgTop = ActiveCell.Top
'Width & Height = -1 original size
Set shp = ws.Shapes.AddPicture(Filename:=imagePath, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
Left:=imgLeft, Top:=imgTop, Width:=-1, Height:=-1)
shp.Name = "myPicture"
If Not shp Is Nothing Then Set shp = Nothing
Exit Sub
NoLocalizado:
MsgBox Err.Description
Exit Sub
End Sub
Private Sub DeletePicture() 'DELETE PICTURE IN SHEET IF EXISTS
On Error GoTo NoLocalizado:
Dim myImage As Shape
Set myImage = ActiveSheet.Shapes("myPicture") ' you can change the name
myImage.Delete
Exit Sub
NoLocalizado:
'MsgBox Err.Description
Exit Sub
End Sub
Private Sub UploadPicture()
Application.ThisWorkbook.Worksheets("Folha1").Select ' (the same sheet with the image)
Dim shp1 As Shape
Dim xchart As ChartObject
Set shp1 = ActiveSheet.Shapes("myPicture")
shp1.Select
Selection.CopyPicture xlScreen
Set xchart = Sheets("Folha1").ChartObjects.Add(0, 1000, 10, 10)
xchart.Name = "testchart"
xchart.Width = Selection.Width
xchart.Height = Selection.Height
Sheets("Folha1").ChartObjects("testchart").Activate
ActiveChart.Paste
ActiveChart.Export ThisWorkbook.Path & Application.PathSeparator & "meteo.jpg"
xchart.Delete
Me.Image1.Picture = LoadPicture(ThisWorkbook.Path & Application.PathSeparator & "meteo.jpg")
Me.Image1.AutoSize = True
Me.Image1.BackStyle = fmBackStyleTransparent
Me.Image1.BorderStyle = fmBorderStyleNone
If Not shp1 Is Nothing Then Set shp1 = Nothing
If Not xchart Is Nothing Then Set xchart = Nothing
End Sub
you can adapte to your needs
Miguel
February 20, 2020
Offline
Hello, sorry, I needed to add some parts and I couldn't edit my post you can replace in Private Sub UploadPicture() ... ActiveChart.Export (VBA.Environ("TEMP") & Application.PathSeparator & "meteo.jpg") ... Me.Image1.Picture = LoadPicture(VBA.Environ("TEMP") & Application.PathSeparator & "meteo.jpg") ... and if you want, you can delete the image on the excel sheet with Private Sub DeletePicture() 'DELETE PICTURE IN SHEET IF EXISTS update Private Sub AddPicture() ' ADD PICTURE FROM PC FOLDER TO SHEET RANGE If Not ws Is Nothing Then Set ws = Nothing ' place this line in the end after: If Not shp Is Nothing Then Set shp = Nothing
and lastly, if you don't want files or folders to remain, you can delete everything use this
Private Sub DeleteAll() ' delete all files in the folder & the folder
On Error Resume Next
Kill ThisWorkbook.path & "\" & "DownloadPictures\*.*" ' delete all files in the folder
RmDir ThisWorkbook.path & "\" & "DownloadPictures\" ' delete folder (RmDir delete only a empty folder)
On Error GoTo 0
End Sub
Miguel
June 26, 2016
Offline
Hi Miguel Santos
It is true that for the moment I have not yet been able to test your project.
But it is also true that as regards working with cells in the excel sheet and a Form Image.
I had managed to do everything a few years ago.
And the difficulty lies in this.
Working only with (L'userform) I also tried to develop a sort of program following an old book of vb6.0 that exploits the bees of windows.
But as always I had to run aground; As I can no longer go on here!
If you have a look at the listing and this:
1° )
'@brief Showing the image with the given path Private Sub showImage(ByVal path As String) LoadPictureGDI Frame1, path End Sub ' Procedure: LoadPictureGDI ' Purpose: Loads an image using GDI+ ' Returns: The image as an IPicture Object Public Sub LoadPictureGDI(ByVal c As Object, ByVal sFilename As String) Dim uGdiInput As GdiplusStartupInput Dim lResult As Long #If VBA7 Then Dim hGdiPlus As LongPtr Dim hGdiImage As LongPtr Dim hBitmap As LongPtr #Else Dim hGdiPlus As Long Dim hGdiImage As Long Dim hBitmap As Long #End If 'Initialize GDI+ uGdiInput.GdiplusVersion = 1 lResult = GdiplusStartup(hGdiPlus, uGdiInput) If lResult = 0 Then 'Load the image lResult = GdipCreateBitmapFromFile(StrPtr(sFilename), hGdiImage) If lResult = 0 Then 'Create a bitmap handle from the GDI image lResult = GdipCreateHBITMAPFromBitmap(hGdiImage, hBitmap, 0) 'Create the IPicture object from the bitmap handle 'and show it in the frame. Set c.Picture = CreateIPicture(hBitmap) 'Tidy up GdipDisposeImage hGdiImage End If 'Shutdown GDI+ GdiplusShutdown hGdiPlus End If End Sub ' Procedure: CreateIPicture ' Purpose: Converts a image handle into an IPicture object. ' Returns: The IPicture object #If VBA7 Then Private Function CreateIPicture(ByVal hPic As LongPtr) As IPicture #Else Private Function CreateIPicture(ByVal hPic As Long) As IPicture #End If Dim lResult As Long Dim uPicInfo As PICTDESC Dim IID_IDispatch As GUID Dim IPic As IPicture 'OLE Picture types Const PICTYPE_BITMAP = 1 ' Create the Interface GUID (for the IPicture interface) With IID_IDispatch .Data1 = &H7BF80980 .Data2 = &HBF32 .Data3 = &H101A .Data4(0) = &H8B .Data4(1) = &HBB .Data4(2) = &H0 .Data4(3) = &HAA .Data4(4) = &H0 .Data4(5) = &H30 .Data4(6) = &HC .Data4(7) = &HAB End With ' Fill uPicInfo with necessary parts. With uPicInfo .Size = Len(uPicInfo) .Type = PICTYPE_BITMAP .hPic = hPic .hPal = 0 End With ' Create the Picture object. lResult = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic) ' Return the new Picture object. Set CreateIPicture = IPic End Function
2° )
'@author Stephen Bullen, Rob Bovey
'@url http://www.rondebruin.nl/win/s.....win009.htm
'Declare a UDT to store a GUID for the IPicture OLE Interface
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
#If VBA7 Then
'Declare a UDT to store the bitmap information
Private Type PICTDESC
Size As Long
Type As Long
hPic As LongPtr
hPal As LongPtr
End Type
'Declare a UDT to store the GDI+ Startup information
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As LongPtr
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
'PtrSafe
'Windows API calls into the GDI+ library
Private Declare Function GdiplusStartup Lib "GDIPlus" (token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As LongPtr = 0) As Long
Private Declare PtrSafe Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As LongPtr, bitmap As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal bitmap As LongPtr, hbmReturn As LongPtr, ByVal background As LongPtr) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus" (ByVal image As LongPtr) As Long
Private Declare PtrSafe Sub GdiplusShutdown Lib "GDIPlus" (ByVal token As LongPtr)
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
#Else
'Declare a UDT to store the bitmap information
Private Type PICTDESC
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
'Declare a UDT to store the GDI+ Startup information
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
'Windows API calls into the GDI+ library
Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, bitmap As Long) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal bitmap As Long, hbmReturn As Long, ByVal background As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal image As Long) As Long
Private Declare Sub GdiplusShutdown Lib "GDIPlus" (ByVal token As Long)
Private Declare Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
#End If
################################
As you can see, everything is very complicated; But doable.
The problem is how?
It would be enough for me even just a code that knows how to convert the image with the extension (PNG) to (JPG or BNP) found on my desktop and more would be done.
But I repeat all this should be able to do it?
Hello Thanks Miguel You are still Fantasti for the things you do
Sincere greetings from A: Maurizio
(P: S) I ask to work with L'userform, because if it is true that the form is a form apart from the excel group.
It is also true that you should also be able to create these things without necessarily passing through the excl sheet to be made.
We also take only the concept of the (Calculator) it can be created both using the userform and also using the cells of the excel sheet as if they were Numeric Buttons!
Therefore why not being able to do everything even just using a form for the presentation of the weather forecast; Which draws the other things I have already completed
Only this blessed Image is missing.
Hello my dear
Sooner or later we will do it?
June 26, 2016
Offline
Hi Miguel
I have only tried your project now
And I must say that as always you have overcome yourself.
In that: Now making some changes of the case, I could insert in the Userform another key to delete both the image from the Sheet with the construct (Delete) in case there were more than one (Shapes) and all inside the Object image.
I am quite satisfied in how much at least I start with something concrete; Because of you.
What I did not understand and why if I want to try to recover the image from the DownloadPicture folder (MyImage) by inserting it directly in the (Image) property of the image itself.
It gives me credential error.
While if I recover the one that leaves me on the desktop but exposes it in the Userbox Picturebox
He perhaps because the one in the folder and the same image that is taken from the link then with the format (PNG) while the one displayed on my Desktop has been converted to the format (JPG)?
Anyway, you did a nice job Thanks again for everything You are Il (Vasco Rossi) of computer science.
Bye and have a good day
February 20, 2020
Offline
Hello,
You are welcome,
Sorry for the download name of the image, even if the file has (.jpg) in the name, if the source was (.png), it remains in (.png) format...
Change the name of the image to download to (.png)
sPath = CurrentFolder & imgName & ".png"
Regards,
Miguel
June 26, 2016
Offline
Don't worry Miguel
Thanks anyway!
This is unimportant and important stuff
Even if to be honest; However, I don't need much because: I repeat I would only like to work with the form and not confirm the Excel sheet.
That's all!
Thanks anyway for your help it will certainly be useful in the future.
Bye and have a good day. by Maurizio
1 Guest(s)
