Link ipertestuale nella mia userform

Question

Buongiorno a tutti.

Io ho una userform nel mio foglio 1 con all'interno il codice qui di seguito riportato:

Option Explicit

Private Const mcstrFoglio As String = "Foglio1"

Private Const mcstrStart  As String = "A4"

Private Const mcstrStop   As String = "A81"

Private Const mcstrColST_ As String = "A"

Private Const mcstrColOgg As String = "B"

Private Const mcstrColRFR As String = "C"

Private Const mcstrColOwn As String = "D"

Private Const mcstrColApp As String = "E"

Private Const mcstrColAmb As String = "G"

Private Const mcstrColDat As String = "H"

Private Const mcstrColNot As String = "L"

Private mblnQuitOnClose   As Boolean

Private Sub cmdInserisci_Click()

On Error GoTo ExtP

Dim wbk As Excel.Workbook

Dim wsh As Excel.Worksheet

Dim r   As Long

Dim ctl As MSForms.Control

Dim bOK As Boolean

With Me

bOK = Len(.txtST.Text) > 0 _

And Len(.txtoggetto.Text) > 0 _

And .cboowner.Value <> vbNullString _

And .cboapplicativo <> txtST _

And .cboambiente.Value <> vbNullString _

And .cbodata.Value <> vbNullString _

If Not bOK Then

Call MsgBox(Prompt:="Non hai compilato tutti i campi obbligatori", _

Buttons:=vbCritical, _

Title:="ATTENZIONE")

Exit Sub

End If

End With

Set wbk = Excel.Application.ThisWorkbook

Set wsh = wbk.Worksheets(mcstrFoglio)

With wsh

r = .Range(mcstrStop).End(xlUp).Row + 1

If r = .Range(mcstrStart).Row Then

MsgBox "L'area dati è piena.", _

vbOKOnly Or vbExclamation, _

"Inserisci"

Else

.Range(mcstrColST_ & r).Value = Me.txtST.Value

.Range(mcstrColOgg & r).Value = Me.txtoggetto.Value

.Range(mcstrColRFR & r).Value = Me.txtRFR.Value

.Range(mcstrColOwn & r).Value = Me.cboowner.Value

.Range(mcstrColApp & r).Value = Me.cboapplicativo.Value

.Range(mcstrColAmb & r).Value = Me.cboambiente.Value

.Range(mcstrColDat & r).Value = Me.cbodata.Value

.Range(mcstrColNot & r).Value = Me.txtnote.Value

End If

End With

With Me

For Each ctl In .Controls

With ctl

If TypeName(ctl) = "CommandButton" Then

If ctl Is Me.cmdNew Then

.Enabled = True

.SetFocus

End If

Else

.Enabled = False

End If

End With

Next

.cmdInserisci.Enabled = False

End With

ExtP:

With Err

If .Number Then MsgBox .Description, _

vbOKOnly Or vbCritical, _

"ERRORE#" & .Number

End With

On Error Resume Next

Set ctl = Nothing

Set wsh = Nothing

Set wbk = Nothing

End Sub

Private Sub cmdNew_Click()

Dim ctl As MSForms.Control

With Me

For Each ctl In .Controls

With ctl

If TypeName(ctl) = "CommandButton" Then

If ctl Is Me.cmdInserisci Then .Enabled = True

Else

Select Case TypeName(ctl)

Case "ComboBox", "TextBox"

.Enabled = True

.Value = Null

Case "Label"

.Enabled = True

Case Else

' DO NOTHING

End Select

End If

End With

Next

.cmdNew.Enabled = False

.txtST.SetFocus

End With

Set ctl = Nothing

End Sub

Private Sub UserForm_Initialize()

Dim rng As Excel.Range

Call deleteCaption(Me)

For Each rng In ThisWorkbook.Worksheets("Foglio1").Range("Z83:Z89")

Me.cbodata.AddItem VBA.FORMAT$(rng.Value, "dddd dd mmmm yyyy")

Next

Set rng = Nothing  

With Me

.BorderStyle = fmBorderStyleSingle

End With

'interrompo eventuali Alert e ridimensiono

'a tutto schermo il file di Excel

With Application

.DisplayAlerts = False

.WindowState = xlMaximized

End With

'ridimensiono la UserForm

With Application

Me.Top = .Top

Me.Left = .Left

Me.Height = .Height

Me.Width = .Width

End With

End Sub

Private Sub cmdTEST_Click()

Unload Me

With ThisWorkbook

.Activate

.Worksheets("Foglio1").Range("U5").Select

End With

End Sub

Private Sub cmdcontrollo_Click()

Unload Me

With ThisWorkbook

.Activate

.Worksheets("Foglio1").Range("A5").Select

End With

End Sub

Private Sub cmdQuit_Click()

mblnQuitOnClose = True

Unload Me

End Sub

Private Sub UserForm_Terminate()

If mblnQuitOnClose Then

With ThisWorkbook

If Not .Saved Then .Save

.Application.Quit

End With

End If

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) 'Disabilita la X di dx

If CloseMode = vbFormControlMenu Then

Cancel = True

End If

End Sub

Private Sub txtST_Exit(ByVal Cancel As MSForms.ReturnBoolean)

Dim s As String

Dim n As Long

s = Me.txtST.Value

If Len(s) = 0 Then Exit Sub

If Len(s) <> 5 Then

Cancel = True

Else

On Error Resume Next

n = CLng(s)

If Err.Number Then Cancel = True

On Error GoTo 0

If CStr(n) <> s Then Cancel = True

End If

If Cancel Then

With Me.txtST

.SelStart = 0

.SelLength = Len(.Value)

End With

MsgBox "Immettere un numero di 5 cifre", _

vbOKOnly Or vbExclamation, _

"ATTENZIONE"

End If

End Sub

Vorrei aggiungere alla mia userform un collegamento ipertestuale ad un altro file excel (tramite un link) ma non so come e dove scrivere il codice in aggiunta a quanto sopra e anche come inserirlo nella userform a livello grafico.

Qualcuno può gentilmente aiutarmi?

Il massimo poi sarebbe che il link visibile sulla userform fosse una immagine che andandoci a cliccare sopra ti dovrebbe aprire il file excel collegato.

Ringrazio tutti in anticipo.

Massimo

Answer 1

Ciao pedmas,

dato che si tratta di aprire un solo file e sempre e soltanto quello (così almeno ho capito) puoi scegliere fra varie modalità di cui le principali sono:

1. Pulsante di comando
2. Etichetta

e siccome ti riferisci sempre all'aprire un file usando la parola link potresti appunto simulare un link con una etichetta con sfondo trasparente, carattere sottolineato e di colore blu che abbia, inoltre, le proprietà così impostate:

per ottenere una finestra del tipo:

e con il seguente codice:

' Module    : UserForm1

' Controls  : Label1

'

Option Explicit

Private Sub Label1_Click()

Dim xlApp As Excel.Application

      Set xlApp = CreateObject("Excel.Application")

      With xlApp

        .Visible = True

        .WindowState = xlMinimized

        .Workbooks.Open Me.Label1.Caption

        .WindowState = xlMaximized

      End With

ExtP: On Error Resume Next

      Set xlApp = Nothing

      On Error GoTo 0

      Exit Sub

ErrH: MsgBox Err.Description

      Resume ExtP

End Sub

Answer 2

Buongiorno Maurizio!

Grazie mille per la risposta però non capisco proprio dove devo inserire i diversi codici (ok per quello da inserire nella USERFORM1 ma gli altri non capisco...)

Io ho la seguente VBAProject:

 

Mi indichi per cortesia dove inserire i primi due codici?

Calcola che la mia userform è la 2. 

Grazie mille!

Massimo

Answer 3

Ciao pedmas,

una sorta di anteprima, dici?... Vedi un po' se questo abbozzo può andare:

____________________________________________________________

' Module : Macro

'

Option Explicit

Public Sub Main()

      UserForm1.Show vbModal

End Sub

____________________________________________________________

' Module : modGlobal

'

Option Explicit

Option Private Module

Public Sub WorkbookToImage(ByVal ImageControl As MSForms.Image, _

                           ByVal Fullname As String)

On Error GoTo ErrH

Const cstrFlt As String = "BMP"

Const cstrPic As String = "TEMP." & cstrFlt

Dim objXlApp  As Excel.Application

Dim objXlWbk  As Excel.Workbook

Dim objXlRng  As Excel.Range

Dim myWbk     As Excel.Workbook

Dim myCht     As Excel.Chart

Dim strTemp   As String

      With Application

        strTemp = Environ("TEMP") & .PathSeparator & cstrPic

        Set myWbk = .ThisWorkbook

      End With

      Set myCht = myWbk.Charts.Add

      myCht.ChartArea.Clear

      Set objXlApp = CreateObject("Excel.Application")

      With objXlApp

        .ScreenUpdating = False

        .DisplayAlerts = False

        .EnableEvents = False

        Set objXlWbk = .Workbooks.Open(Fullname, AddToMru:=False)

        Set objXlRng = .ActiveWindow.VisibleRange

      End With

      objXlRng.CopyPicture xlScreen, xlPicture

      With myCht

        .Paste

        Set myCht = .Location(xlLocationAsObject, _

                              myWbk.Worksheets(1).Name)

      End With

      With myCht

        .Export strTemp, Filtername:=cstrFlt

        .Parent.Delete

      End With

      With ImageControl

        .Picture = LoadPicture(strTemp)

        .Parent.Repaint

      End With

ExtP: On Error Resume Next

      Kill strTemp

      objXlWbk.Close SaveChanges:=False

      objXlApp.Quit

      Set objXlRng = Nothing

      Set objXlWbk = Nothing

      Set objXlApp = Nothing

      Set myCht = Nothing

      Set myWbk = Nothing

      On Error GoTo 0

      Exit Sub

ErrH: MsgBox Err.Description

      Resume ExtP

End Sub

____________________________________________________________

' Module : UserForm1

'

Option Explicit

Private Sub Image1_Click()

      WorkbookToImage Me.Image1, "D:\Percorso\Cartella di lavoro.xlsx"

End Sub

Answer 4

Buongiorno Maurizio.

Innanzi tutto grazie per a risposta che è chiarissima.

Ho un problema però: avendo impostato la userform con apertura a tutta pagina, qindi nasconde il file excel, quando clicco sul collegamento non me lo fa vedere se non solo se esco dalla userform...non è possibile forzare l'apertura del collegamento in modo che mi appaia in primo piano?

O cosa ancora più interessante: non è possibile far vedere con una sorta di anteprima il file che si dovrebbe aprire con il link direttamente nella finestra della userform?

Fammi sapere.

Grazie in anticipo.

Massimo

Answer 5

[...]

Vorrei aggiungere alla mia userform un collegamento ipertestuale ad un altro file excel (tramite un link) ma non so come e dove scrivere il codice in aggiunta a quanto sopra e anche come inserirlo nella userform a livello grafico.

Qualcuno può gentilmente aiutarmi?

Il massimo poi sarebbe che il link visibile sulla userform fosse una immagine che andandoci a cliccare sopra ti dovrebbe aprire il file excel collegato.

Ciao Massimo,

senza guardare il codice che hai postato rispondo esclusivamente alla domanda quotata qui su.

Aggiungi allo UserForm un controllo di tipo Immagine, come indicato dalla freccia rossa:

Ci fai doppio clic sopra e nel corpo della routine-evento che compare scrivi (ovviamente indicando il percorso e il nome del tuo file):

Private Sub Image1_Click()

    Application.Workbooks.Open "D:\Percorso\Cartella di lavoro.xlsx"

End Sub

Per assegnare un'immagine al controllo Immagine vedi la freccia blu.