Nom du fichier dans un webbrowser

Signaler
Messages postés
151
Date d'inscription
samedi 17 juillet 2004
Statut
Membre
Dernière intervention
11 mai 2012
-
Messages postés
17288
Date d'inscription
mercredi 2 janvier 2002
Statut
Modérateur
Dernière intervention
27 septembre 2021
-
mes ami(e)s svp aidez moi
voici mon code :


je n'arrive pas a récupérer le nom de l'image séléctionner
je ne veux pas récupérer le chemin
mon problème ce situe dans :
Private Function doc_ondblclick() As Boolean




Option Explicit
Private Declare Function GetTempPath _
Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long

Private Declare Function GetTempFileName _
Lib "kernel32" Alias "GetTempFileNameA" _
(ByVal lpszPath As String, _
ByVal lpPrefixString As String, _
ByVal wUnique As Long, _
ByVal lpTempFileName As String) As Long

Private Const MAX_PATH As Long = 260

Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2

Private Type BrowseInfo
hwndOwner As Long
pidlRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type

Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long

Dim mDoc As HTMLDocument
Dim imgHeightWidth As Long
Dim imgHeightWidthCont As Long
Dim diff2Images As Long
Dim WithEvents doc As HTMLDocument
Const RIGHT_BUTTON = 2
Public Event DblClick(path1 As String)
Public Event Click(Path As String)
Public Event mouseover(Path As String)

Private FormLoaded As Boolean
Dim alt As String
Dim TempFileName As String

Private Function OpenDirectoryTV(ohwnd As Long, Optional odtvTitle As String) As String
Dim lpIDList As Long
Dim sBuffer As String
Dim szTitle As String
Dim tBrowseInfo As BrowseInfo
szTitle = odtvTitle
With tBrowseInfo
.hwndOwner = ohwnd
.lpszTitle = lstrcat(szTitle, "")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
End With
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
OpenDirectoryTV = sBuffer
End If
End Function

Private Sub Command2_Click()
WebBrowser1.Width = WebBrowser1.Width - 60
End Sub

Private Sub Command1_Click()
Dim strPath As String
strPath = OpenDirectoryTV(UserControl.hWnd, "Select image folder")
If Len(Trim(strPath)) = 0 Then Exit Sub
txtAddress.Text = strPath
setPath
End Sub

Private Sub doc_ondataavailable()
MsgBox "downloaded"
End Sub


Private Function doc_onclick() As Boolean
Dim eventObj As IHTMLEventObj
Dim srcName As String

Set eventObj = doc.parentWindow.event
alt = ""
srcName = eventObj.srcElement.tagName

If srcName "IMG" Or srcName "SPAN" Or srcName = "INPUT" Or srcName = "DIV" Then
alt = eventObj.srcElement.getAttribute("ID")
RaiseEvent Click(alt)
End If

End Function

Private Sub doc_onmousedown()
Dim eventObj As IHTMLEventObj
Dim srcName As String

Set eventObj = doc.parentWindow.event
alt = ""
srcName = eventObj.srcElement.tagName

End Sub

Private Sub doc_onmouseover()
Dim eventObj As IHTMLEventObj
Dim srcName As String

Set eventObj = doc.parentWindow.event
alt = ""
srcName = eventObj.srcElement.tagName

If srcName "IMG" Or srcName "SPAN" Or srcName = "INPUT" Or srcName = "DIV" Then
alt = eventObj.srcElement.getAttribute("ID")
RaiseEvent mouseover(alt)
End If
' FrmInternet.Text3 = alt
' File1.list (i)
'Dim i
'Dim id As String
'For i = 0 To File1.ListCount - 1
' FrmInternet.Text3 = File1.list(i)
' Next i
End Sub

Private Sub txtAddress_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
setPath
End If
End Sub

Private Sub UserControl_Initialize()
TempFileName = GetSystemTempPath & "34rxdt92[1].html"
imgHeightWidth = 100
imgHeightWidthCont = imgHeightWidth + 10
diff2Images = 20

txtAddress.Text = App.Path
Set mDoc = New HTMLDocument
WebBrowser1.Navigate2 "about:blank"
'setPath
End Sub
Public Sub SetLocation(mFolder As String)
txtAddress.Text = mFolder
setPath
End Sub
Private Sub setPath()
Dim ImageFolderPath As String
Dim mDocContents As String
ImageFolderPath = txtAddress.Text
CreateFile (ImageFolderPath)
'Picture1.Enabled = False
If PathExists(ImageFolderPath) Then
WebBrowser1.Navigate2 "file:///" & TempFileName
End If
End Sub

Private Function CreateFile(ImageFolderPath As String) As String
Dim retValue As String
Dim TempFile As String
Dim i As Integer
Dim ID As String

If Not PathExists(ImageFolderPath) Then
MsgBox "Path does not exists", vbCritical, "Path Error"
Exit Function
End If

File1.Path = ImageFolderPath

UserControl.MousePointer = vbHourglass
UserControl.Enabled = False
retValue = ""
For i = 0 To File1.ListCount - 1
ID = File1.Path & "" & File1.list(i)
retValue = retValue & _
"" & _
"" & _
"" & _
"" & _
"" & _
"" & vbCrLf
DoEvents

Next

retValue = Replace(Text2.Text, "##IMAGE_DETAILS##", retValue)

'Attributes
'##IMAGE_BORDER_COLOR##
'##HIGHLIGHT_BACKGROUND_COLOR##
'##HIGHLIGHT_IMAGE_BORDER_COLOR##
'##BODY_BGCOLOR##

'bodycolor
'retValue = Replace(retValue, "##BODY_BGCOLOR##", "#DDDDDD")
retValue = Replace(retValue, "##BODY_BGCOLOR##", "#FFFFFF")

'Image border color
retValue = Replace(retValue, "##IMAGE_BORDER_COLOR##", "#AAAAAA")

'Image Highlight color
retValue = Replace(retValue, "##HIGHLIGHT_BACKGROUND_COLOR##", "#999999")

'HIGHLIGHT_IMAGE_BORDER_COLOR
retValue = Replace(retValue, "##HIGHLIGHT_IMAGE_BORDER_COLOR##", "#333333")

'SIZE_HEIGHT
retValue = Replace(retValue, "##SIZE_HEIGHT_WIDTH##", imgHeightWidth)

'SIZE_HEIGHT
retValue = Replace(retValue, "##SIZE_HEIGHT_WIDTH_CONT##", imgHeightWidthCont)

'difference in width of 2 images
retValue = Replace(retValue, "##DIFF_2_IMAGES##", diff2Images)

'SIZE_HEIGHT
retValue = Replace(retValue, "##OUTER_SPAN_SIZE##", imgHeightWidthCont + diff2Images)


Open TempFileName For Output As #1
Print #1, retValue
Close #1

End Function

Private Sub UserControl_Resize()
On Error Resume Next
' txtAddress.Move 0, 0, ScaleWidth - Command1.Width - 60, txtAddress.Height
' Command1.Move txtAddress.Left + txtAddress.Width + 30, 0
' WebBrowser1.Move 0, 0, UserControl.Width, UserControl.Height - WebBrowser1.Top
WebBrowser1.Move 0, 0, UserControl.Width, UserControl.Height
End Sub


Public Property Get ImageHeightWidth() As Variant
ImageHeightWidth = imgHeightWidth
End Property

Public Property Let ImageHeightWidth(ByVal vNewValue As Variant)
If vNewValue < 50 Then vNewValue = 50
imgHeightWidth = vNewValue
End Property

Private Sub UserControl_Terminate()
On Error Resume Next
Kill TempFileName
End Sub

Private Sub WebBrowser1_CommandStateChange(ByVal Command As Long, ByVal Enable As Boolean)
On Error Resume Next
'Clear the selection
If FormLoaded Then
WebBrowser1.ExecWB OLECMDID_CLEARSELECTION, OLECMDEXECOPT_DONTPROMPTUSER
End If
End Sub

Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
FormLoaded = True
Set doc = WebBrowser1.Document
UserControl.MousePointer = vbNormal
UserControl.Enabled = True
End Sub


Private Function PathExists(mPath As String) As Boolean
On Error GoTo errh
File1.Path = mPath
PathExists = True
Exit Function
errh:
PathExists = False
End Function

Public Function GetSystemTempPath() As String

Dim result As Long
Dim buff As String

buff = Space$(MAX_PATH)
result = GetTempPath(MAX_PATH, buff)
GetSystemTempPath = Left$(buff, result)
End Function

Private Function doc_ondblclick() As Boolean
Dim eventObj As IHTMLEventObj
Dim srcName As String

Set eventObj = doc.parentWindow.event
alt = ""
srcName = eventObj.srcElement.tagName

If srcName "IMG" Or srcName "SPAN" Or srcName = "INPUT" Or srcName = "DIV" Then
alt = eventObj.srcElement.getAttribute("ID")

MsgBox "le nom du fichier"

RaiseEvent DblClick(alt)
End If


End Function

merci à l'équipe

1 réponse

Messages postés
17288
Date d'inscription
mercredi 2 janvier 2002
Statut
Modérateur
Dernière intervention
27 septembre 2021
70
te suffit d'extraire le nom depuis le src de l'image, non ?

une simple manipulation de string, en somme
(voire InternetCrackURL si tu souhaites la jouer fine)

Renfield - Admin CodeS-SourceS - MVP Visual Basic