MS Excel

Tlačítkem "Nahrát fotografii" ji nahraji do malého okna Image1 a tlačítkem "Zápis TPM!" potřebuji zapsat do databáze excelu její cestu.citovat

Děkuji za odpověď.

Jde o to, že ta cesta k obrázku bude pokaždé jiná a pokaždé bude název obrázku také jiný.

Zde dávám kódy, které mám v obou tlačítkách.

Tlačítko nahrát fotografii

<code>Private Sub cmbNahratFoto_Click()

Dim ImageLocation As String
Dim J As String
Const cFile As String = "Image Files(*.bmp; *.jpg; *.jepg; *.png; *.tif),"

Application.FileDialog(msoFileDialogOpen).Show

Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False

ImageLocation = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
Image1.Picture = LoadPicture(ImageLocation)
Image1.PictureSizeMode = fmPictureSizeModeStretch
'FileCopy ImageLocation, "" & J & ".JPG"

End Sub</code>

A tlačítko Zápis TPM!

<code>Private Sub btZapisTPM_Click()

Dim StrZadavatel As String
Dim StrPopiszavady As String
Dim StrcbZodpovednost As String
Dim StrMisto As String
Dim StrKontakt As String
Dim StrPatro As String
''Zkouška vepsání cesty obrázku do 11 sloupce
Dim fullPath As String
''

''Zkouška emailu
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
''
Dim dataSheet As Worksheet
Dim FirstEmptyRow As Long

Dim id As Integer
Dim i As Integer
Dim Poradove As Integer

Dim dateNow As Date
Dim timeNow As Date

dateNow = Date
timeNow = Time

Set dataSheet = ThisWorkbook.Worksheets("TPM")

FirstEmptyRow = dataSheet.Cells(Rows.Count, 2).End(xlUp).Row + 1

'Nastavení funkcí k promennym

StrPopiszavady = txbPopisZavady.Value
StrZadavatel = Application.UserName
StrPatro = cbxPatro.Value
StrMisto = cbxMisto.Value
StrcbZodpovednost = cbxZodpovednost.Value

id = dataSheet.Cells(FirstEmptyRow - 1, 2).Value
Poradove = dataSheet.Cells(FirstEmptyRow - 1, 1).Value

Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

dataSheet.Unprotect "heslo"
ActiveWorkbook.Unprotect "heslo"
''Zkouška cesty sloupec 11
On Error Resume Next
fullPath = Selection.ShapeRange(1).LinkFormat.SourceFullName
fullPath = Selection.InlineShapes(1).LinkFormat.SourceFullName
MsgBox fullPath
''
'funkce maker

dataSheet.Cells(FirstEmptyRow, 1).Value = Poradove + 1
dataSheet.Cells(FirstEmptyRow, 2).Value = id + 1
dataSheet.Cells(FirstEmptyRow, 3).Value = dateNow
dataSheet.Cells(FirstEmptyRow, 4).Value = StrZadavatel
dataSheet.Cells(FirstEmptyRow, 5).Value = StrPopiszavady
dataSheet.Cells(FirstEmptyRow, 6).Value = StrcbZodpovednost
dataSheet.Cells(FirstEmptyRow, 7).Value = StrMisto
dataSheet.Cells(FirstEmptyRow, 8).Value = StrPatro
dataSheet.Cells(FirstEmptyRow, 11).Value = fullPath

dataSheet.Protect "heslo"
ActiveWorkbook.Protect "heslo"

Unload TPM

''EMAIL

On Error Resume Next
With OutMail
If cbxZodpovednost = "Údržba" Then
.to = "email"
ElseIf cbxZodpovednost = "Správce budov" Then
.to = "email"
End If
.CC = ""
.BCC = ""
.Subject = "Nové TPM"
.Body = "Máte nové TPM - pro přehled všech TPM navštivte adresu"
.Attachments.Add ActiveWorkbook.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing

End Sub</code>

Předem moc děkujicitovat

Príklad úpravy
Private Sub cmbNahratFoto_Click()
Dim ImageLocation As String

With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Filters.Add "Images", "*.bmp; *.jpg; *.jepg; *.png; *.tif", 1
If .Show = -1 Then ImageLocation = .SelectedItems(1)
End With
If ImageLocation <> "" Then
With Image1
.Tag = ImageLocation
On Error GoTo ERROR
.Picture = LoadPicture(ImageLocation)
.PictureSizeMode = fmPictureSizeModeStretch
End With
End If
Exit Sub
ERROR:
MsgBox "Při načítání obrázku došlo k chybě !", vbExclamation
End Sub
Private Sub btZapisTPM_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim FirstEmptyRow As Long
Dim aZapis(7)
Const PW As String = "heslo"

'Nastavení pole zápisu hodnot
aZapis(2) = Now
aZapis(3) = Application.UserName
aZapis(4) = txbPopisZavady.Text
aZapis(5) = cbxZodpovednost.Text
aZapis(6) = cbxMisto.Text
aZapis(7) = cbxPatro.Text

With ThisWorkbook.Worksheets("TPM")
FirstEmptyRow = .Cells(Rows.Count, 2).End(xlUp).Row + 1

aZapis(0) = .Cells(FirstEmptyRow - 1, 1).Value
If IsNumeric(aZapis(0)) Then aZapis(0) = aZapis(0) + 1 Else aZapis(0) = 1
aZapis(1) = .Cells(FirstEmptyRow - 1, 2).Value
If IsNumeric(aZapis(1)) Then aZapis(1) = aZapis(1) + 1 Else aZapis(1) = 1

Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

.Unprotect PW
ThisWorkbook.Unprotect PW
'Zápis hodnot
.Cells(FirstEmptyRow, 1).Resize(, 8).Value = aZapis
If LenB(Image1.Tag) > 0 Then
.Cells(FirstEmptyRow, 11).Value = Image1.Tag
.Hyperlinks.Add Anchor:=.Cells(FirstEmptyRow, 11), Address:=Image1.Tag
End If

.Protect PW
ThisWorkbook.Protect PW

Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End With

Unload TPM

''EMAIL
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
Err.Clear
If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With OutMail
If cbxZodpovednost = "Údržba" Then
.to = "email"
ElseIf cbxZodpovednost = "Správce budov" Then
.to = "email"
End If
.CC = ""
.BCC = ""
.Subject = "Nové TPM"
.Body = "Máte nové TPM - pro přehled všech TPM navštivte adresu"
.Attachments.Add ThisWorkbook.FullName
.Send 'or use .Display
End With

If Err.Number <> 0 Then MsgBox "Chyba pri vytváření mailu.", vbExclamation
On Error GoTo 0

Set OutMail = Nothing: Set OutApp = Nothing
End Subcitovat

Jste nejlepší, mockrát děkuji! Je to funkční. Celý ten vtip byl pravděpodobně v tom .tag. Ještě by bylo super mít to jako hypertextový odkaz do složky, ale s tím si snad poradím, ještě jednou díky.citovat